(** * Rational numbers. *)

Set Implicit Arguments.

From Coq Require Import
  QArith
  Lia
  Lqa
.

Definition N2Q (n : nat) : Q := Z.of_nat n # 1.

Lemma Qdiv_0_num (a : Q) : 0 / a == 0.
Proof. destruct a; destruct Qnum; compute; reflexivity. Qed.

Lemma Q0_le_1 : 0 <= 1. Proof. lra. Qed.
Lemma Q0_lt_2 : 0 < 2. Proof. lra. Qed.

Lemma inject_Z_pos_nonzero (p : positive) :
  ~ inject_Z (Z.pos p) == 0.
Proof. compute; congruence. Qed.

Lemma inject_Z_pos_positive (p : positive) :
  0 < inject_Z (Z.pos p).
Proof. reflexivity. Qed.

Lemma pos_num_le_den (n d : positive) :
  Z.pos n # d <= 1 ->
  (n <= d)%positive.
Proof.
  intro H.
  rewrite Qmake_Qdiv in H.
  apply (Qmult_le_compat_r _ _ (inject_Z (Z.pos d))) in H.
  - rewrite Qmult_1_l in H.
    rewrite Qmult_comm in H.
    rewrite Qmult_div_r in H.
    + rewrite <- Zle_Qle in H; apply H.
    + apply inject_Z_pos_nonzero.
  - apply Qlt_le_weak, inject_Z_pos_positive.
Qed.

Lemma Q_num_le_den p :
  p <= 1 ->
  (Z.to_nat (Qnum p) <= Pos.to_nat (Qden p))%nat.
Proof.
  intros Hle.
  destruct p. simpl.
  destruct Qnum, Qden; simpl; try lia;
    apply Pos2Nat.inj_le, pos_num_le_den; auto.
Qed.

Lemma Qnum_nonnegative p :
  0 <= p ->
  (0 <= Qnum p)%Z.
Proof. intro Hle; destruct p; unfold Qle in Hle; simpl in *; lia. Qed.

Lemma Qle_num_1 (p : Z) :
  (0 < p)%Z ->
  1 <= p # 1.
Proof. intro Hp; unfold Qle; simpl; lia. Qed.


Require Export Utf8.
Require Import Lists.List.
Import ListNotations.

Class Category_axiomatics
        (object : Type)
        (arrow : object → object → Type)
        (id : ∀ x : object, arrow x x)
        (compose :
                 compose x y y f (id y) = f
  ; associativity : True
        compose x x y (id x) f = f ∧ compose x y y f (id y) = f
  ; associativity :
       ∀ (x y z u : object) (f : arrow x y) (g : arrow y z) (h : arrow z u),
        (compose x z u (compose x y z f g) h) =
          (compose x y u f (compose y z u g h))
}.

Structure Category : Type := defCategory
{ object : Type
; arrow : object → object → Type
; id : ∀ x : object, arrow x x
; compose :
     ∀ (x y z : object) (f : arrow x y) (g : arrow y z), arrow x z
; cat_cert : Category_axiomatics object arrow id compose
}.

Lemma le_refl : ∀ n : nat, n ≤ n.
Proof. constructor. Qed.

Lemma le_trans : ∀ n m k : nat, n ≤ m → m ≤ k → n ≤ k.
Proof.
  intros * H1 H2.
  induction H2 as [| m' IH2].
  - assumption.
  - inversion H1; now constructor.
Qed.

Instance nat_category_axiomatics : Category_axiomatics
  nat (fun (n m : nat) => n ≤ m) le_refl le_trans.
Proof.
  constructor.
  - intros. split.

Definition nat_object := {f : nat * nat | fst f ≤ snd f}.
Definition nat_src (f : nat_arrow) : nat
:= match f with exist _ sf _ => fst sf end.
Definition nat_trg (f : nat_arrow) : nat
:= match f with exist _ sf _ => snd sf end.
Definition nat_id (n : nat) : nat_arrow
:= exist _ (n, n) (le_n n).

Lemma le_trans : ∀ n m k : nat, n≤ m → m ≤ k → n ≤ k.
Proof.
  intros * Hnm Hmk.
  induction Hmk as [ | m' nm'].
  - assumption.
  - inversion IHnm' as [| m'']; repeat constructor. assumption.
Qed.
Lemma nat_compose_cert : ∀ n m k l : nat, n ≤ m → m = k → k ≤ l → n ≤ l.
Proof.
  intros * H1 H2 H3. rewrite H2 in H1.
  now apply le_trans with k.
Qed.

Definition nat_compose (f g : nat_arrow) : nat_trg f = nat_src g -> nat_arrow.
Proof.
  intro.
  destruct f as [fv Hf]. destruct g as [gv Hg]. simpl in H.
  assert ( Hgf : fst fv ≤ snd gv). {
    now apply nat_compose_cert with (snd fv) (fst gv). }
  now exists (fst fv, snd gv).
Defined.

Definition Nat := {|
  object := nat;  arrow := nat_arrow;
  src := nat_src; trg := nat_trg;
  id := nat_id;   compose := nat_compose
|}.


(** * Episode 04: Operational Semantics *)

Require Import String.
Open Scope string.

Definition var := string.
Definition val := nat.

Inductive expr : Type :=
| Const : val -> expr
| Var : var -> expr
| Add : expr -> expr -> expr
| Mul : expr -> expr -> expr.

Inductive stmt : Type :=
| Skip : stmt
| Assign : var -> expr -> stmt
| Seq : stmt -> stmt -> stmt
| Cond : expr -> stmt -> stmt -> stmt
| While : expr -> stmt -> stmt.

Definition heap := var -> val.

Definition empty : heap :=
  fun s => 0.

Definition add_binding n v h : heap :=
  fun s => if string_dec s n then v else h s.

Inductive Eval (h: heap) : expr -> val -> Prop :=
| EConst : forall n,
  Eval h (Const n) n
| EVar : forall x,
  Eval h (Var x) (h x)
| EAdd : forall e1 e2 c1 c2 c3,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  c3 = c1 + c2 ->
  Eval h (Add e1 e2) c3
(**
was:

| EAdd : forall e1 e2 c1 c2,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  Eval h (Add e1 e2) (c1 + c2)

but this forces Coq to guess [c1] and [c2] from [(c1 + c2)] which can be
impossible, so it helps to introduce another variable [c3] and add an
equality that can be delayed until [c1] and [c2] have been figured out in
other parts of the proof.
 *)
| EMul : forall e1 e2 c1 c2,
  Eval h e1 c1 ->
  Eval h e2 c2 ->
  Eval h (Mul e1 e2) (c1 * c2).

Theorem Eval_101 :
  Eval (add_binding "y" 4 empty) (Add (Add (Const 3) (Var "y")) (Const 5)) 12.
Proof.
  eapply EAdd.
  eapply EAdd.
  constructor.
  constructor.
  constructor.
  constructor.
  constructor.
Qed.

Print Eval_101.

Inductive Step (h : heap) : stmt -> heap -> stmt -> Prop :=
| SAssign : forall e c x,
  Eval h e c ->
  Step h (Assign x e) (fun s => if string_dec s x then c else h s) Skip
| SSeq1 : forall s,
  Step h (Seq Skip s) h s
| SSeq2 : forall s1 s2 s1' h',
  Step h s1 h' s1' ->
  Step h (Seq s1 s2) h' (Seq s1' s2)
| SCondT : forall e c s1 s2,
  Eval h e c ->
  c > 0 ->
  Step h (Cond e s1 s2) h s1
| SCondF : forall e c s1 s2,
  Eval h e c ->
  c <= 0 ->
  Step h (Cond e s1 s2) h s2
| SWhileT : forall e c s,
  Eval h e c ->
  c > 0 ->
  Step h (While e s) h (Seq s (While e s))
| SWhileF : forall e c s,
  Eval h e c ->
  c <= 0 ->
  Step h (While e s) h Skip.

(** alternatively...
| SWhileT : forall e s,
  Step h (While e s) h (Seq (Cond e s) (While e s))
*)


Require Export aire_signee.
Require Export angles_droites.
Require Export angles_vecteurs.
Require Export Droite_espace.
Require Export triangles_semblables.

Definition orient ( A B C :PO) : Prop :=
     aire (vec A B) (vec A C) >0.

Lemma orient_cycle :
    forall (A B C :PO), orient A B C -> orient B C A.
intros A B C H.
unfold orient in *.
rewrite aire_ordre_cycle ;auto.
Qed.

Lemma orient_compensation :
    forall (A B C :PO), ~orient A B C \/ ~orient B A C .
intros A B C.
elim (classic (orient A B C));(intros H;auto).
assert (H0 : orient B C A ) by (apply orient_cycle ;auto).
right;red;intros H1.
unfold orient in *.
rewrite aire_anti_symetrique in H1.
lra.
Qed.

Lemma position_3points_1:
   forall (A B C :PO), (~ orient A B C /\ ~ orient B A C) \/ ~ alignes A B C.
intros A B C.
elim (classic (~ orient A B C /\ ~ orient B A C));(intros H;auto).
right.
elim (@not_and_or (~orient A B C)(~orient B A C));auto;intro H1.
assert(orient A B C) by (apply NNPP;auto).
red;intros H2.
unfold orient in H0.
assert ( aire (vec A B)(vec A C) = 0) by apply (@aire_alignement A B C H2) .
lra.

assert(orient B A C) by (apply NNPP;auto).
red;intros H2.
assert (alignes B A C);auto with geo.
unfold orient in H0.
assert ( aire (vec B A)(vec B C) = 0) by apply (@aire_alignement B A C H3) .
lra.
Qed.

Lemma position_3points_2:
   forall (A B C :PO), orient A B C \/ orient B A C \/ alignes A B C.
intros A B C .
destruct (@total_order_T (aire (vec A B)(vec A C)) 0) as [[H | H ] |H].
right;left.
apply orient_cycle;apply orient_cycle.
unfold orient.
rewrite aire_anti_symetrique;lra.
elim (classic (A=B));intros H0.
right;right.
rewrite H0;auto with geo.
destruct (@aire_nulle_colineaires A B A C H0 H) as [k H1].
right;right.
apply  colineaire_alignes with (k:=k);auto.
left.
unfold orient;auto.
Qed.
Lemma orient_4point:
(*correspondant un axiom de Knuth
  prouve grace a l'axiom position_4points *)
forall (A B C D : PO), orient A B D -> orient B C D ->
          orient C A D -> orient A B C.
intros A B C D H0 H1 H2.
unfold orient in *.
rewrite aire_ordre_cycle2 in H2.
assert (H4:aire (vec A D) (vec B A) >0).
rewrite aire_anti_symetrique.
VReplace (vec B A) (mult_PP (-1) (vec A B)).
rewrite aire_colineaire_l;lra.
assert (H5: aire (vec A D) (vec B C) >0).
rewrite <-(@Chasles_vec B A C).
rewrite aire_distrib_l;lra.
assert (H6 : aire (vec D B)(vec B C)>0).
rewrite aire_anti_symetrique.
VReplace (vec D B) (mult_PP (-1) (vec B D)).
rewrite aire_colineaire_r;lra.
assert (H7: aire (vec A B) (vec B C) >0).
rewrite <-(@Chasles_vec A D B).
rewrite aire_distrib_r;lra.
rewrite <-(@Chasles_vec A B C ).
rewrite aire_distrib_l.
rewrite aire_ABAB;lra.
Qed.

Lemma orient_deroule :
    forall ( A B C :PO), orient A B C ->
             ~orient B A C /\ ~alignes A B C /\
             A<>B /\ A <> C /\ B<>C.
intros A B C H.
cut (~orient B A C);intro H0.
cut (~alignes A B C);intro H1.
repeat split;auto.
red;intro H2.
rewrite H2 in H.
assert (alignes B B C ) by intuition.
rewrite H2 in H1.
elim H1;assumption.
red;intro H2.
rewrite H2 in H.
assert (alignes C B C ) by intuition.
rewrite H2 in H1.
elim H1;assumption.
red;intro H2.
rewrite H2 in H1.
assert (alignes A C C ) by intuition.
elim H1;assumption.
destruct (position_3points_1 A B C) as [[H2 H3]|h4] ;intuition.
elim (orient_compensation A B C );intros H1;elim H1;auto.
Qed.

Ltac deroule_orient H:=
(*find out others trivial hypotheses from the one*)
(*  match goal with H : orient ?A ?B ?C|- _ =>*)
  generalize H; let name := fresh in intros name ; decompose [and] (@orient_deroule _ _ _ name ).
(*end.*)

Definition  positifColineaire ( A B M:PO):Prop :=
       exists k :R, A <> B /\ vec A M = mult_PP k (vec A B) /\ k>0.

Definition  negatifColineaire ( A B M:PO):Prop :=
       exists k :R, A <> B /\ vec A M = mult_PP k (vec A B) /\ k<0.

Axiom colineaire_position :
      forall A B C :PO, A<>B->
              C = A \/ positifColineaire A B C \/ negatifColineaire A B C.
Axiom positifColineaire_permute :
      forall A B C :PO, positifColineaire A B C -> positifColineaire A C B.
Axiom positifColineaire_negatifColineaire :
       forall A B C :PO, positifColineaire A B C ->
                B=C \/ negatifColineaire C B A \/ negatifColineaire B C A  .
Axiom positifColineaire_negatifColineaire1 :
       forall A B C :PO, positifColineaire A B C ->
                positifColineaire B A C -> negatifColineaire C B A  .

Axiom negatifColineaire_permute :
      forall A B C :PO, negatifColineaire A B C -> negatifColineaire A C B.
Axiom negatifColineaire_positifColineaire :
       forall A B C :PO, negatifColineaire A B C ->
                positifColineaire C A B /\ positifColineaire B A C.

Lemma inversion_colineaire :
 forall (k : R) (A B C : PO),
 A <> C -> vec A C = mult_PP k (vec A B) -> vec A B = mult_PP (/ k) (vec A C).
intros.
cut (k <> 0); intros.
rewrite H0.
Fieldvec k.
contrapose H.
apply vecteur_nul_conf.
rewrite H0; rewrite H1; Ringvec.
Qed.

Lemma alignes_positifColineaire :
           forall ( A B M :PO), A<>B ->alignes A B M ->
                    positifColineaire A B M \/ positifColineaire B A M.
intros A B M H H0.
elim H0;intros H1.
elim H;auto.
assert (H2: col_vec A B A M) by (apply alignes1_colineaire;auto).
elim H2;intros k H3.
elim (Rle_or_lt k 0);intro H4.

assert ( H5 : vec B M =mult_PP (1-k) (vec B A)).
rewrite <-(Chasles_vec B A M) .
rewrite ->(opp_vecteur A B) .
rewrite H3.
rewrite (mult_mult_vec A B (1-k) (-1)).
replace ((1-k)* -1) with (k-1); [idtac | ring].
assert (H6: add_PP (mult_PP (-1) (vec A B))(mult_PP k (vec A B))=
                   mult_PP (-1 +k) (vec A B )) by RingPP.
rewrite H6.
replace (-1 + k ) with (k-1);[auto|ring].
assert (H7: 1-k >0).
lra.
right;unfold positifColineaire.
exists (1-k);auto.
left;unfold positifColineaire.
exists k;auto.
Qed.

(* BEGIN consequences *)
Lemma positifColineaire_orient_l:
forall (A B C M :PO), orient A B C -> positifColineaire A B M ->
          orient A M C.
intros A B C M H [k [H0 [H1 H2]]].
unfold orient in *.
rewrite H1.
rewrite aire_colineaire_l.
apply Rmult_gt_0_compat;auto.
Qed.

Lemma negatifColineaire_orient_l:
forall (A B C M :PO), orient A B C -> negatifColineaire A B M ->
          orient A C M.
intros A B C M H [k [H0 [H1 H2]]].
unfold orient in *.
rewrite H1.
rewrite aire_colineaire_r.
rewrite aire_anti_symetrique.
rewrite  Ropp_mult_distr_r_reverse.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rmult_gt_0_compat;auto with real.
Qed.

Lemma positifColineaire_orient_r:
forall (A B C M :PO), orient A B C -> positifColineaire A C M ->
          orient A B M.
intros A B C M H [k [H0 [H1 H2]]].
unfold orient in *.
rewrite H1.
rewrite aire_colineaire_r.
apply Rmult_gt_0_compat;auto.
Qed.

Lemma negatifColineaire_orient_r:
forall (A B C M :PO), orient A B C -> negatifColineaire A C M ->
          orient A M B.
intros A B C M H [k [H0 [H1 H2]]].
unfold orient in *.
rewrite H1.
rewrite aire_colineaire_l.
rewrite aire_anti_symetrique.
rewrite  Ropp_mult_distr_r_reverse.
rewrite <- Ropp_mult_distr_l_reverse.
apply Rmult_gt_0_compat;auto with real.
Qed.

Lemma positifColineaire_orient_inv_l:
forall (A B C M :PO), orient A B C -> orient A M C ->
          alignes A B M -> positifColineaire A B M.
intros A B C M H H0 H1 .
destruct H1 as [H2|H3].
deroule_orient H.
elim H4;auto.
assert (H2: col_vec A B A M) by (apply alignes1_colineaire;auto).
destruct H2 as [k H4].
destruct (@total_order_T k 0) as [[H1 | H1] |H1].
assert(orient A C M).
apply negatifColineaire_orient_l with (B:=B);auto.
exists k; deroule_orient H;auto.
destruct (orient_compensation C M A);elim H5;apply orient_cycle;auto.
assert ( A = M) by (apply (@produit_zero_conf k A M A B);auto).
deroule_orient H0.
elim H7;auto.
unfold positifColineaire.
exists k;repeat split;auto.
deroule_orient H;auto.
Qed.

Lemma positifColineaire_orient_inv_r:
forall (A B C M :PO), orient A B C -> orient A B M  ->
           alignes A C M ->  positifColineaire A C M.
intros A B C M H H0 H1 .
destruct H1 as [H2|H3].
deroule_orient H.
elim H6;auto.
assert (H2: col_vec A C A M) by (apply alignes1_colineaire;auto).
destruct H2 as [k H4].
destruct (@total_order_T k 0) as [[H1 | H1] |H1].
assert(orient A M B).
apply negatifColineaire_orient_r with (C:=C) ;auto.
exists k;deroule_orient H;auto.
destruct (orient_compensation B M A);elim H5;apply orient_cycle;auto.
assert ( A = M) by (apply (@produit_zero_conf k A M A C);auto).
deroule_orient H0.
elim H9;auto.
unfold positifColineaire.
exists k;repeat split;auto.
deroule_orient H;auto.
Qed.

Lemma negatifColineaire_orient_inv_l:
forall (A B C M :PO), orient A B C -> orient A C M->alignes A B M->
          negatifColineaire A B M.
intros A B C M H H0 H1.
destruct H1 as [H2|H2].
deroule_orient H.
elim H4;auto.
destruct (@alignes1_colineaire A B M) as [k H3];auto.
destruct (@Rtotal_order k 0) as [H4 |[H4|H4]].
exists k;deroule_orient H;auto.
rewrite H4 in H3.
assert ( A =M) by (apply (@produit_zero_conf 0 A M A B);auto).
deroule_orient H0.
elim H9;auto.
assert (H5 : orient A M C).
apply (@positifColineaire_orient_l A B C M ); auto.
exists k;deroule_orient H;auto.
elim (@orient_compensation A M C);intros H6;elim H6;
   [auto |apply orient_cycle;apply orient_cycle;auto].
Qed.

Lemma negatifColineaire_orient_inv_r:
forall (A B C M :PO), orient A B C -> orient A M B->alignes A C M->
          negatifColineaire A C M.
intros A B C M H H0 H1.
destruct H1 as [H2|H2].
deroule_orient H.
elim H6;auto.
destruct (@alignes1_colineaire A C M) as [k H3];auto.
destruct (@Rtotal_order k 0) as [H4 |[H4|H4]].
exists k;deroule_orient H;auto.
rewrite H4 in H3.
assert ( A =M) by (apply (@produit_zero_conf 0 A M A C);auto).
deroule_orient H0.
elim H7;auto.
assert (H5 : orient A B M ).
apply (@positifColineaire_orient_r A B C M ); auto.
exists k;deroule_orient H; auto.
elim (@orient_compensation A B M );intros H6;elim H6;
   [auto |apply orient_cycle;apply orient_cycle;auto].
Qed.

(* Lemma for angle and orientation *)
Lemma orient_SinusPositif :
forall A B C  :PO,
           orient A B C-> Sin (cons_AV (vec A B )(vec A C ))>0.
intros A B C H.
generalize H;intros H0.
unfold orient in H0.
rewrite def_aire in *;deroule_orient H;auto.
elim (@distance_pos A B );intros H10 ;
      [idtac|elim (@distincts_dist_non_nulle A B H3);auto].
elim (@distance_pos A C );intros H11 ;
      [idtac|elim (@distincts_dist_non_nulle A C H5);auto].
assert (H9 :0< distance A C * Sin(cons_AV (vec A B )(vec A C)) ).
apply Rmult_lt_reg_l with (r:= distance A B);auto with real.
replace (distance A B *0)  with 0  ;auto with real.
red.
apply Rmult_lt_reg_l with (r:= distance A C);auto with real.
replace (distance A C *0)  with 0  ;auto with real.
Qed.

Lemma anglesEgaux_orient :
forall (A B C M N P : PO), orient A B C -> M<>N -> M <>P->
         cons_AV (vec M N) (vec M P) = cons_AV (vec A B ) ( vec A C)->
         orient M N P.
intros A B C M N P H H0 H1 H2.
generalize H;intros H3.
unfold orient in H3.
unfold orient .
rewrite def_aire in *;deroule_orient H;auto.
elim (@distance_pos A B );intros H11 ;
      [idtac|elim (@distincts_dist_non_nulle A B H6);auto].
elim (@distance_pos A C );intros H12 ;
      [idtac|elim (@distincts_dist_non_nulle A C H8);auto].
elim (@distance_pos M N );intros H13 ;
      [idtac|elim (@distincts_dist_non_nulle M N H0);auto].
elim (@distance_pos M P );intros H14 ;
      [idtac|elim (@distincts_dist_non_nulle M P H1);auto].
rewrite H2.
apply Rmult_gt_0_compat;auto.
apply Rmult_gt_0_compat;auto.
replace 0 with (distance A B *0) in H3;auto with real.
apply orient_SinusPositif;auto.
Qed.

Lemma  consAD_orient_consAV:
forall A B C M N P :PO,
double_AV (cons_AV (vec A B)(vec A C))= double_AV (cons_AV (vec M N) (vec M P))->
orient A B C -> orient M N P ->
cons_AV (vec A B) (vec A C) = cons_AV (vec M N) (vec M P).
intros A B C M N P H H0 H1.
unfold double_AV in H.
deroule_orient H0.
deroule_orient H1.
destruct  (tout_angle_a_une_mesure (A:=A) (B:=B) (C:=A) (D:=C)) as [x H15]; auto with geo.
destruct  (tout_angle_a_une_mesure (A:=M) (B:=N) (C:=M) (D:=P)) as [y H16]; auto with geo.
rewrite <-H15 in *.
rewrite <-H16 in *.
rewrite <-add_mes_compatible in H.
rewrite <-add_mes_compatible in H.
replace (x+x) with (2*x) in H.
replace (y+y) with (2*y) in H.
cut (sin x = sin y).
intros H17.
cut (cos x = cos y).
intros H18.
apply egalite_angle_trigo;auto.
assert (H19:sin (2*x) = sin (2*y)) by (apply sin_deux_mes;auto).
repeat rewrite duplication_sin in H19.
rewrite H17 in H19.
apply Rmult_eq_reg_l with (r:=sin y).
apply Rmult_eq_reg_l with (r:=2);auto with real.
apply Rgt_not_eq.
rewrite (@egalite_sin_Sin M N P y);auto.
apply orient_SinusPositif;auto.
assert (H19:cos (2*x) = cos (2*y)) by (apply cos_deux_mes;auto).
repeat rewrite duplication_cos2 in H19.
apply Rsqr_inj.
assert (sin x >0) by
(rewrite (@egalite_sin_Sin A B C x);auto; apply orient_SinusPositif;auto).
lra.
assert (sin y >0) by
(rewrite (@egalite_sin_Sin M N P y);auto; apply orient_SinusPositif;auto).
lra.
apply Rmult_eq_reg_l with (r:=2);auto with real.
assert (-(2*Rsqr (sin x)) = -((2*Rsqr (sin y)))) by (apply Rplus_eq_reg_l with (r:=1);auto with real).
replace (2 * Rsqr(sin x)) with (-(-(2 * Rsqr(sin x))));auto with real.
replace (2 * Rsqr(sin y)) with (-(-(2 * Rsqr(sin y))));auto with real.
ring.
ring.
Qed.

Lemma  consAD_orient_consAVplusPi:
forall A B C M N P :PO,
double_AV (cons_AV (vec A B)(vec A C))= double_AV (cons_AV (vec M N) (vec M P))->
orient A B C -> orient M P N ->
cons_AV (vec A B) (vec A C) = plus (cons_AV (vec M N) (vec M P)) (image_angle pi).
intros A B C M N P H H0 H1.
unfold double_AV in H.
deroule_orient H0.
deroule_orient H1.
destruct  (tout_angle_a_une_mesure (A:=A) (B:=B) (C:=A) (D:=C)) as [x H15]; auto with geo.
destruct  (tout_angle_a_une_mesure (A:=M) (B:=N) (C:=M) (D:=P)) as [y H16]; auto with geo.
rewrite <-H15 in *.
rewrite <-H16 in *.
rewrite <-add_mes_compatible in H.
rewrite <-add_mes_compatible in H.
replace (x+x) with (2*x) in H; [idtac|ring].
replace (y+y) with (2*y) in H; [idtac|ring].
cut (sin x = -sin y).
intros H17.
cut (cos x = -cos y).
intros H18.
rewrite <-add_mes_compatible.
apply egalite_angle_PiPres_trigo;auto.
assert (H19:sin (2*x) = sin (2*y)) by (apply sin_deux_mes;auto).
repeat rewrite duplication_sin in H19.
rewrite H17 in H19.
replace (cos x) with ( - -cos x);auto with real.
apply Ropp_eq_compat.
apply Rmult_eq_reg_l with (r:=sin y).
apply Rmult_eq_reg_l with (r:=2);auto with real.
rewrite <-H19.
rewrite Ropp_mult_distr_l_reverse.
rewrite Ropp_mult_distr_r_reverse;auto.

assert (Sin (cons_AV(vec M P)(vec M N)) >0) by (apply orient_SinusPositif;auto).
assert (cons_AV (vec M P) (vec M N) = opp (cons_AV (vec M N) (vec M P))).
apply opp_angle.
rewrite Chasles;auto.
rewrite <-angle_nul;auto.
rewrite <-H16 in H18.
rewrite <-mes_opp in H18.
rewrite <-(@egalite_sin_Sin M P N (-y)) in H13;auto.
rewrite  sin_impaire in H13.
assert (sin y <0).
lra.
apply Rlt_not_eq;auto.

assert (H19:cos (2*x) = cos (2*y)) by (apply cos_deux_mes;auto).
repeat rewrite duplication_cos2 in H19.
rewrite (@Rsqr_neg (sin y)) in H19.
apply Rsqr_inj.
assert (sin x >0) by
(rewrite (@egalite_sin_Sin A B C x);auto; apply orient_SinusPositif;auto).
lra.

assert (Sin (cons_AV(vec M P)(vec M N)) >0) by (apply orient_SinusPositif;auto).
assert (cons_AV (vec M P) (vec M N) = opp (cons_AV (vec M N) (vec M P))).
apply opp_angle.
rewrite Chasles;auto.
rewrite <-angle_nul;auto.
rewrite <-H16 in H17.
rewrite <-mes_opp in H17.
rewrite <-(@egalite_sin_Sin M P N (-y)) in H13;auto.
rewrite  sin_impaire in H13.
lra.
apply Rmult_eq_reg_l with (r:=2);auto with real.
assert (-(2*Rsqr (sin x)) = -((2*Rsqr (-sin y)))) by (apply Rplus_eq_reg_l with (r:=1);auto with real).
replace (2 * Rsqr(sin x)) with (-(-(2 * Rsqr(sin x))));auto with real.
replace (2 * Rsqr(-sin y)) with (-(-(2 * Rsqr(-sin y))));auto with real.
Qed.

(*  Des consequences concernant l'intersection*)
Definition vecEntreDeuxVec ( A B C M :PO) : Prop :=
           (orient A B C /\ orient A B M /\ orient A M C)\/
           (orient A C B /\ orient A C M /\ orient A M B).

Lemma (*lemme*) vecEntreDeuxVec_permute :
forall ( A B C M :PO), vecEntreDeuxVec A B C M ->
          vecEntreDeuxVec A C B M.
intros A B C M [[H0 [H1 H2]]|[H0 [H1 H2]]].
right;auto.
left;auto.
Qed.

Lemma vecEntreDeuxVec_intersection_middle1:
           forall ( A B C D :PO),orient A B C -> vecEntreDeuxVec A B C D ->
           forall M:PO, alignes A D M /\ alignes B C M ->
           positifColineaire A D M.
intros A B C D H H0 M [H2 H1] .
elim H0;intros [H3 [H4 H5]].
destruct H2 as [H2|H2].
deroule_orient H5;elim H8;auto.
destruct (@alignes1_colineaire A D M) as [k H6];auto.
destruct (@Rtotal_order k 0) as [H7|[H7|H7]].
assert (orient A C M)
  by (apply (@negatifColineaire_orient_l A D C M H5 );auto;
  exists k; deroule_orient H5;auto).
assert (orient A M B)
  by (apply (@negatifColineaire_orient_r A B D M H4 );auto;
  exists k; deroule_orient H4;auto).
assert (orient M B C).
apply orient_4point with (D:=A);auto.
apply orient_cycle; auto.
apply orient_cycle;auto.
apply orient_cycle;auto.
deroule_orient H10.
elim H14;apply alignes_ordre_cycle2;auto.
assert (A=M) by (apply produit_zero_conf with (k:=k) (C:=A)(D:=D);auto).
rewrite <-H8 in H1.
deroule_orient H3.
elim H12;auto with geo.
exists k;repeat split;auto.
deroule_orient H5;auto.
destruct  (@orient_compensation A B C) as [H6|H6].
elim H6;auto.
elim H6;apply orient_cycle;apply orient_cycle;auto.
Qed.

Lemma vecEntreDeuxVec_intersection_middle2:
           forall ( A B C D  :PO),orient A B C -> vecEntreDeuxVec A B C D ->
           forall M:PO, alignes A D M /\ alignes B C M ->
           positifColineaire B C M /\ positifColineaire C B M.
intros A B C D  H H0 M [H2 H1].
elim H0;intros [H3 [H4 H5]].
assert (positifColineaire A D M) by  (apply(@vecEntreDeuxVec_intersection_middle1 A B C D );auto).
assert (orient A B M) by (apply positifColineaire_orient_r with (C:=D);auto).
assert (orient A M C) by (apply  positifColineaire_orient_l with (B:=D);auto).
split.
apply (@positifColineaire_orient_inv_l B C A M);auto.
apply orient_cycle;assumption.
apply orient_cycle;assumption.
apply (@positifColineaire_orient_inv_r C A B M);auto.
apply orient_cycle;apply orient_cycle;assumption.
apply orient_cycle;apply orient_cycle;assumption.
apply permute_alignes;assumption.
destruct  (@orient_compensation A B C) as [H6|H6].
elim H6;auto.
elim H6;apply orient_cycle;apply orient_cycle;auto.
Qed.

Lemma vecEntreDeuxVec_intersection_middle:
           forall ( A B C D :PO), vecEntreDeuxVec A B C D ->
           forall M:PO, alignes A D M /\ alignes B C M ->
           positifColineaire B C M /\ positifColineaire C B M /\ positifColineaire A D M.
intros A B C D H M [H1 H0].
elim H;intros [H2 [H3 H4]].
assert (positifColineaire B C M /\ positifColineaire C B M).
apply (@vecEntreDeuxVec_intersection_middle2 A B C D );auto.
assert (positifColineaire A D M).
apply (@vecEntreDeuxVec_intersection_middle1 A B C D );auto.
destruct H5 as [H7 H8].
split;auto.
assert (vecEntreDeuxVec A C B D) by
        (unfold vecEntreDeuxVec;left;split;auto).
assert (positifColineaire C B M /\ positifColineaire B C M).
apply (@vecEntreDeuxVec_intersection_middle2 A C B D );auto with geo.
assert (positifColineaire A D M).
apply (@vecEntreDeuxVec_intersection_middle1 A C B D );auto with geo.
destruct H6 as [H8 H9].
split;auto.
Qed.

Lemma vecEntreDeuxVec_intersection_left1:
           forall ( A B C D :PO), vecEntreDeuxVec A B C D ->
           forall M :PO, alignes A B M /\ alignes C D M ->
           (positifColineaire C D M -> positifColineaire A B M) /\
           (positifColineaire A B M -> positifColineaire C D M /\ positifColineaire M D C ) .
intros A B C D H M [H3 H2].
repeat split.
intro H1.
destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient A M C).
apply orient_cycle.
apply positifColineaire_orient_r with (C:=D);auto.
apply orient_cycle;apply orient_cycle;auto.
apply positifColineaire_orient_inv_l with (C:=C);auto.
assert (H4 : orient A C M).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_l with (B:=D);auto.
apply orient_cycle;auto.
apply positifColineaire_orient_inv_r with (B:=C);auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient C A M ).
apply orient_cycle;apply orient_cycle;auto.
apply positifColineaire_orient_l with (B:=B);auto.
apply positifColineaire_orient_inv_r with (B:=A);auto.
apply orient_cycle;apply orient_cycle;auto.
assert (H4 : orient C M A ).
apply orient_cycle;auto.
apply positifColineaire_orient_r with (C:=B);auto.
apply positifColineaire_orient_inv_l with (C:=A);auto.
apply orient_cycle;auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient M C A ).
apply orient_cycle.
apply positifColineaire_orient_l with (B:=B);auto.
assert (H5 : orient M D A ).
apply orient_cycle.
apply positifColineaire_orient_l with (B:=B);auto.
apply positifColineaire_orient_inv_l with (C:=A);auto with geo.
assert (H4 : orient M A C ).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_r with (C:=B);auto.
assert (H5 : orient M A D ).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_r with (C:=B);auto.
apply positifColineaire_orient_inv_r with (B:=A);auto with geo.
Qed.

Lemma vecEntreDeuxVec_intersection_left2:
           forall ( A B C D :PO), vecEntreDeuxVec A B C D ->
           forall M :PO, alignes A B M /\ alignes C D M ->
           (negatifColineaire C D M -> negatifColineaire A B M) /\
           (negatifColineaire A B M -> negatifColineaire C D M  ) .
intros A B C D H M [H3 H2].
repeat split;intro H1.
destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient A C M).
apply orient_cycle;apply orient_cycle.
apply negatifColineaire_orient_r with (C:=D);auto.
apply orient_cycle;apply orient_cycle;auto.
apply negatifColineaire_orient_inv_l with (C:=C);auto.
assert (H4 : orient A M C ).
apply orient_cycle.
apply negatifColineaire_orient_l with (B:=D);auto.
apply orient_cycle;auto.
apply negatifColineaire_orient_inv_r with (B:=C);auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient C M A ).
apply orient_cycle.
apply negatifColineaire_orient_l with (B:=B);auto.
apply negatifColineaire_orient_inv_r with (B:=A);auto.
apply orient_cycle;apply orient_cycle;auto.
assert (H4 : orient C A M  ).
apply orient_cycle;apply orient_cycle.
apply negatifColineaire_orient_r with (C:=B);auto.
apply negatifColineaire_orient_inv_l with (C:=A);auto.
apply orient_cycle;auto.
Qed.

Lemma vecEntreDeuxVec_intersection_right1:
           forall ( A B C D :PO), vecEntreDeuxVec A B C D ->
           forall M :PO, alignes A C M /\ alignes B D M ->
           (positifColineaire B D M -> positifColineaire A C M) /\
           (positifColineaire A C M -> positifColineaire B D M /\ positifColineaire M D B ) .
intros A B C  D H M [H3 H2].
repeat split.
intro H1.
destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient A B M).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_l with (B:=D);auto.
apply orient_cycle;auto.
apply positifColineaire_orient_inv_r with (B:=B);auto.
assert (H4 : orient A M B).
apply orient_cycle.
apply positifColineaire_orient_r with (C:=D);auto.
apply orient_cycle;apply orient_cycle;auto.
apply positifColineaire_orient_inv_l with (C:=B);auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient B M A ).
apply orient_cycle;auto.
apply positifColineaire_orient_r with (C:=C);auto.
apply positifColineaire_orient_inv_l with (C:=A);auto.
apply orient_cycle;auto.
assert (H4 : orient B A M ).
apply orient_cycle;apply orient_cycle;auto.
apply positifColineaire_orient_l with (B:=C);auto.
apply positifColineaire_orient_inv_r with (B:=A);auto.
apply orient_cycle;apply orient_cycle;auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient M A B ).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_r with (C:=C);auto.
assert (H5 : orient M A D ).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_r with (C:=C);auto.
apply positifColineaire_orient_inv_r with (B:=A);auto with geo.
assert (H4 : orient M B A ).
apply orient_cycle.
apply positifColineaire_orient_l with (B:=C);auto.
assert (H5 : orient M D A ).
apply orient_cycle.
apply positifColineaire_orient_l with (B:=C);auto.
apply positifColineaire_orient_inv_l with (C:=A);auto with geo.
Qed.

Lemma vecEntreDeuxVec_intersection_right2:
           forall ( A B C D :PO), vecEntreDeuxVec A B C D ->
           forall M :PO, alignes A C M /\ alignes B D M ->
           (negatifColineaire B D M -> negatifColineaire A C M) /\
           (negatifColineaire A C M -> negatifColineaire B D M  ) .
intros A B C D H M [H3 H2].
repeat split;intro H1.
destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient A M B ).
apply orient_cycle.
apply negatifColineaire_orient_l with (B:=D);auto.
apply orient_cycle;auto.
apply negatifColineaire_orient_inv_r with (B:=B);auto.
assert (H4 : orient A B M ).
apply orient_cycle;apply orient_cycle.
apply negatifColineaire_orient_r with (C:=D);auto.
apply orient_cycle;apply orient_cycle;auto.
apply negatifColineaire_orient_inv_l with (C:=B);auto.

destruct H as [[H19 [H20 H21]] |[H19 [H20 H21]]].
assert (H4 : orient B A M  ).
apply orient_cycle;apply orient_cycle.
apply negatifColineaire_orient_r with (C:=C);auto.
apply negatifColineaire_orient_inv_l with (C:=A);auto.
apply orient_cycle;auto.
assert (H4 : orient B M A ).
apply orient_cycle.
apply negatifColineaire_orient_l with (B:=C);auto.
apply negatifColineaire_orient_inv_r with (B:=A);auto.
apply orient_cycle;apply orient_cycle;auto.
Qed.

Lemma Exists_Intersection1 : (* on peut prouver grace au lemme
droites_non_paralleles *)
forall (A B C D :PO),
          vecEntreDeuxVec A B C D ->
          exists E :PO, alignes A D E /\ alignes B C E.
intros A B C D H.
assert (H0 : ~alignes A D B /\ A <>D)
 by(destruct H as [[_ [H2 _]]|[_ [_ H2]]];deroule_orient H2;auto with geo).
destruct H0 as [H0 H1].
assert (H2 : ~alignes A D C)
 by(destruct H as [[_ [_ H3 ]]|[_ [H3 _]]];deroule_orient H3;auto with geo).
assert (H3 : B<>C)
 by(destruct H as [[H4 [_ _]]|[H4 [_ _]]];deroule_orient H4;auto with geo).
destruct (@existence_pt_intersection A D B C ) as [E H4];auto.
assert (H4: ~ paralleles (droite A D) (droite B C)).
red;intros H4.
destruct (@existence_representant_vecteur A B C) as [D' H5].
destruct (@paralleles_vecteur A D B C ) as [k H6];auto.
destruct H as [[H7 [H8 H9]]|[H7 [H8 H9]]].
assert (aire(vec B C)(vec A D) = 0) by (apply aire_colinearite with (k:=k) ;auto).
rewrite <-(@Chasles_vec B A C) in H.
rewrite aire_distrib_r in H.
assert (aire (vec B A)(vec A D) <0).
VReplace (vec B A) (mult_PP (-1) (vec A B)).
rewrite aire_colineaire_l.
unfold orient in H8;lra.
assert (aire (vec A C)(vec A D) <0).
rewrite aire_anti_symetrique.
unfold orient in H9;lra.
lra.
assert (aire(vec B C)(vec A D) = 0) by (apply aire_colinearite with (k:=k) ;auto).
rewrite <-(@Chasles_vec B A C) in H.
rewrite aire_distrib_r in H.
assert (aire (vec B A)(vec A D) >0).
VReplace (vec B A) (mult_PP (-1) (vec A B)).
rewrite aire_colineaire_l.
rewrite aire_anti_symetrique.
unfold orient in H9.
replace (-1) with (-(1)) by ring.
rewrite Ropp_mult_distr_l_reverse.
rewrite Ropp_mult_distr_r_reverse.
lra.
assert (aire (vec A C)(vec A D) >0).
unfold orient in H8;auto.
lra.
elim (@droites_non_paralleles  B C A D H3 H1 H4);auto.
intros H5.
(*here we use an axiom of plane geometry,
which one to say that every 4 points are COPLANAR   *)
assert (H6: coplanaires B C A D) by apply geometrie_plane.
elim H5;auto.
exists E;auto.
apply def_pt_intersection2;auto.
Qed.

Lemma Exists_Intersection: (* on peut prouver grace au lemme
droites_non_paralleles *)
forall (A B C D :PO),
          vecEntreDeuxVec A B C D ->
          exists M :PO,positifColineaire B C M /\ positifColineaire C B M /\ positifColineaire A D M.
intros A B C D H.
destruct (@Exists_Intersection1 A B C D) as [M [H0 H1]];auto.
exists M.
apply vecEntreDeuxVec_intersection_middle;auto.
Qed.

(*Consequence concernant angles inscrits oriente*)
Axiom differencePiNull : image_angle 0 <>image_angle pi.

Require Export cocyclicite.

Ltac deroule_sont_cocycliques :=
  match goal with H : sont_cocycliques ?A ?B ?C ?D|- _ =>
  generalize H ; let name := fresh in intros name  ;
  unfold sont_cocycliques in name;
  destruct name ;decompose [and] name; clear name;
 repeat match goal with H' : circonscrit ?O ?A ?B ?C  |- _ =>
  unfold circonscrit  in H';
  decompose [and] H' ; clear H' end ;
 repeat match goal with H' : isocele ?O ?A ?B  |- _ =>
  unfold isocele  in H'
  end
end.

Lemma sont_cocycliques_avec_ordre_cycle:
forall (A B C D :PO),
         sont_cocycliques A B C D ->sont_cocycliques B C D A.
intros A B C D H.
deroule_sont_cocycliques .
unfold sont_cocycliques .
exists x.
unfold circonscrit in *.
unfold isocele in *.
repeat split ;auto.
rewrite H4 in H2;auto.
rewrite H3 in H0;auto.
rewrite H4 in H2;auto.
Qed.

Lemma sont_cocycliques_avec_ordre_permute:
forall (A B C D :PO),
         sont_cocycliques A B C D ->sont_cocycliques A B D C.
intros A B C D H.
deroule_sont_cocycliques .
unfold sont_cocycliques .
exists x.
unfold circonscrit in *.
unfold isocele in *.
repeat split ;auto.
Qed.

Theorem SommeAnglesInscritsOriente:
forall (A B C D : PO),
         sont_cocycliques A B C D ->orient A B C ->
                    orient A C D -> orient A B D.
intros A B C D H H0 H1.
destruct (@position_3points_2 A B D) as [H2|[H2|H2]];auto.
assert (H3:orient B C D).
apply orient_4point with (D:=A);auto.
apply orient_cycle;auto.
apply orient_cycle;auto.
apply orient_cycle;apply orient_cycle;auto.

assert (H4:cons_AV(vec A D )(vec A B) = cons_AV (vec C D)(vec C B)).
apply consAD_orient_consAV.
apply cocyclicite;auto with geo.
deroule_orient H2 ;auto with geo.
deroule_orient H3 ;auto with geo.
apply sont_cocycliques_avec_ordre_cycle.
apply sont_cocycliques_avec_ordre_permute.
apply sont_cocycliques_avec_ordre_cycle;apply sont_cocycliques_avec_ordre_cycle;auto.
apply orient_cycle;auto.
apply orient_cycle;auto.
assert (H5:cons_AV(vec A B )(vec A C) = cons_AV (vec D B)(vec D C)).
apply consAD_orient_consAV;auto.
apply cocyclicite;auto with geo.
deroule_orient H0 ;auto with geo.
deroule_orient H3 ;auto with geo.
apply sont_cocycliques_avec_ordre_permute.
apply sont_cocycliques_avec_ordre_cycle;auto.
apply orient_cycle;apply orient_cycle;auto.
assert (H6:cons_AV(vec A C )(vec A D) = cons_AV (vec B C)(vec B D)).
apply consAD_orient_consAV;auto.
apply cocyclicite;auto with geo.
deroule_orient H1 ;auto with geo.
deroule_orient H3 ;auto with geo.
apply sont_cocycliques_avec_ordre_cycle.
apply sont_cocycliques_avec_ordre_cycle;auto.
assert (plus (cons_AV (vec C D) (vec C B))
   (plus (cons_AV (vec D B) (vec D C)) (cons_AV (vec B C) (vec B D))) = image_angle pi).
apply somme_triangle;deroule_orient H3;auto.
rewrite <-H4 in H7.
rewrite <-H5 in H7.
rewrite <-H6 in H7.
rewrite Chasles in H7;(deroule_orient H0;deroule_orient H1;auto).
rewrite Chasles in H7;(deroule_orient H0;deroule_orient H1;auto).
rewrite <-angle_nul in H7;auto.

elim differencePiNull;auto.

assert (H3: col_vec A B A D) .
apply alignes1_colineaire;auto with geo.
unfold alignes in H2.
elim H2;intros;auto.
deroule_orient H0.
elim H6;auto.
destruct H3 as [k H4].
destruct (@total_order_T k 0) as [[H5| H5] |H5].
assert (H6: vec B D = mult_PP (1-k) (vec B A)).
rewrite <-(@Chasles_vec B A D) .
rewrite H4.
VReplace (vec A B) (mult_PP (-1) (vec B A)).
rewrite mult_mult_vec.
replace (k*-1) with (-k);[idtac|ring].
replace (1-k) with (1+(-k));auto with real.
VReplace (vec B A) (mult_PP (1) (vec B A)).
RingPP.
assert (H7: 1-k >0).
lra.
assert(H8 : orient D B C).
apply orient_cycle;apply orient_cycle.
apply positifColineaire_orient_r with (C:=A).
apply orient_cycle;auto.
exists (1-k);deroule_orient H0;auto.
assert (H9:cons_AV(vec D B )(vec D C) = cons_AV (vec A B)(vec A C)).
apply consAD_orient_consAV;auto.
apply cocyclicite;auto with geo.
deroule_orient H8 ;auto with geo.
deroule_orient H0 ;auto with geo.
apply sont_cocycliques_avec_ordre_cycle;auto.

assert (trianglesSD C A B C D B ).
repeat split.
deroule_orient H0;auto with geo.
deroule_orient H8;auto with geo.
auto.
rewrite (@angle_produit_positif_r (1-k) B A D  B C ) ;auto.
deroule_orient H0;auto with geo.
deroule_orient H0;auto with geo.
assert (cons_AV (vec C A)(vec C B) =cons_AV (vec C D)(vec C B)).
apply (@trianglesSD_angles_egaux  C A B C D B);auto.
assert (cons_AV (vec C A) (vec C D) = image_angle 0).
rewrite <-(@Chasles C A C B C D);(deroule_orient H0;deroule_orient H1;auto with geo).
rewrite H10.
rewrite Chasles;auto with geo.
rewrite (@ angle_nul C D) ;auto.
destruct (@angle_nul_positif_colineaire C A D) as [k' [H12 H13]];(deroule_orient H0;deroule_orient H1;auto).
assert (alignes C A D) .
apply colineaire_alignes with (k:=k');auto.
elim H23.
apply   alignes_ordre_permute .
apply alignes_ordre_cycle;auto.

assert (A=D).
apply (@produit_zero_conf k A D A B);auto.
deroule_orient H1.
elim H10;auto.

assert (orient A D C).
apply (@positifColineaire_orient_l A B C D H0);auto.
exists k;deroule_orient H0;auto.
elim (@orient_compensation D C A);intro.
elim H6.
apply orient_cycle;auto.

elim H6.
apply orient_cycle;auto.
Qed.


(** * 6.822 Formal Reasoning About Programs, Spring 2020 - Pset 1 *)

Require Import Frap.
(* If this import command doesn't work, something may be wrong with the copy
 * of the FRAP book source that has been included as a Git submodule.
 * Running `git submodule init' or `git submodule update' in the repository
 * base directory might help.  However, it's also necessary to build the
 * book library, like so (starting from the base of this repository):
 * <<
     make -C frap lib
   >>
 * See below for installing Coq, which is a prerequisite for the above to work.
 *)

(* Authors:
 * Peng Wang (wangpeng@csail.mit.edu),
 * Adam Chlipala (adamc@csail.mit.edu),
 * Joonwon Choi (joonwonc@csail.mit.edu),
 * Benjamin Sherman (sherman@csail.mit.edu)
 * Andres Erbsen (andreser@csail.mit.edu)
 *)

(* This pset dives straight in to building a program-analysis pass and
 * proving it sound in Coq. But before that, you will need to get set up
 * with Coq. *)

(*
 * All the psets we provide should be compatible with several Coq versions,
 * including 8.9, 8.10, and 8.11.  If you haven't installed Coq before, we
 * encourage you to install the latest version, which is 8.11, though you
 * may also find it more convenient to install a package from your
 * operating system.  For instance:
 * - Coq has been included with Ubuntu <https://www.ubuntu.com/> for a while,
 *   and the last releases includes a new enough Coq version.
 *   Just run `apt-get install coq'.
 *   If your Ubuntu version is older than 19.10, don't install Coq from the
 *   Ubuntu repos, because otherwise you'll get a too old Coq version.
 * - Mac Homebrew <http://brew.sh/> also includes a new enough version.
 *   Just run `brew install coq'.
 *
 * To install from source, see the official download page:
 *   https://coq.inria.fr/download
 *
 * It will also be *essential* to install a UI for editing Coq proofs!
 * The course staff use and recommend Proof General <https://proofgeneral.github.io/>,
 * which is a mode for the Emacs IDE; or Coqtail, which is a similar vim plugin.
 * Both projects' GitHub pages include installation instructions. Some older versions,
 * say from OS packages, may work fine for this class, too.
 *
 * However, there is a standalone Coq IDE called, fittingly, CoqIDE, which
 * ships with Coq itself.  It has a less steep learning curve, though many of us
 * believe that Proof General supports more productive coding, after spending some
 * practice time.
 *
 * We will have special office hours the first week of class,
 * to help everyone get these packages set up.
 *
 * Now, on to the actual assignment, once you have Coq and a UI installed!
 *)

(* The first part of this assignment involves the [bool] datatype,
 * which has the following definition.
 * <<
     Inductive bool :=
     | true
     | false.
   >>
 * We will define logical negation and conjunction of Boolean values,
 * and we will prove some properties of these definitions.

 * In the second part of this assignment, we will work with a simple language
 * of imperative arithmetic programs that sequentially apply operations
 * to a natural-number-valued state.

 * The [Prog] datatype defines abstract syntax trees for this language.
 *)

Inductive Prog :=
  | Done                             (* Don't modify the state. *)
  | AddThen (n : nat) (p : Prog)     (* Add [n] to the state, then run [p]. *)
  | MulThen (n : nat) (p : Prog)     (* Multiply the state by [n], then run [p]. *)
  | DivThen (n : nat) (p : Prog)     (* Divide the state by [n], then run [p]. *)
  | VidThen (n : nat) (p : Prog)     (* Divide [n] by the state, then run [p]. *)
  | SetToThen (n : nat) (p : Prog)   (* Set the state to [n], then run [p]. *)
  .

(* Your job is to define a module implementing the following
 * signature.  We ask you to implement a file Pset1.v, where the skeleton is
 * already given, such that it can be checked against this signature by
 * successfully processing a third file (Pset1Check.v) with a command like so:
 * <<
    Require Pset1Sig Pset1.

    Module M : Pset1Sig.S := Pset1.
   >>
 * You'll need to build your module first, which the default target of our
 * handy Makefile does for you automatically.  Note that the _CoqProject
 * file included here is also important for making compilation and
 * interactive editing work.  Your Pset1.v file is what you upload to the course
 * web site to get credit for doing the assignment.
 *)

(* Finally, here's the actual signature to implement. *)
Module Type S.

  (* Define [Neg] so that it implements Boolean negation, which flips
   * the truth value of a Boolean value.
   *)
  Parameter Neg : bool -> bool.

  (* For instance, the negation of [true] should be [false].
   * This proof should follow from reducing both sides of the equation
   * and observing that they are identical.
   *)
  Axiom Neg_true : Neg true = false.

  (* Negation should be involutive, meaning that if we negate
   * any Boolean value twice, we should get the original value back.

   * To prove a fact like this that holds for all Booleans, it suffices
   * to prove the fact for both [true] and [false] by using the
   * [cases] tactic.
   *)
  Axiom Neg_involutive : forall b : bool, Neg (Neg b) = b.

  (* Define [And] so that it implements Boolean conjunction. That is,
   * the result value should be [true] exactly when both inputs
   * are [true].
   *)
  Parameter And : bool -> bool -> bool.

  (* Here are a couple of examples of how [And] should act on
   * concrete inputs.
   *)
  Axiom And_true_true : And true true = true.
  Axiom And_false_true : And false true = false.

  (* Prove that [And] is commutative, meaning that switching the order
   * of its arguments doesn't affect the result.
   *)
  Axiom And_comm : forall x y : bool, And x y = And y x.

  (* Prove that the conjunction of a Boolean value with [true]
   * doesn't change that value.
   *)
  Axiom And_true_r : forall x : bool, And x true = x.

  (* Define [run] such that [run p n] gives the final state
   * that running the program [p] should result in, when the
   * initial state is [n].
   * Use the +, *, and / operators for natural numbers provided
   * by the Coq standard library, and for this part of the
   * exercise, don't worry about division by 0, doing the same
   * thing as division from the standard library does is fine.
   *)
  Parameter run : Prog -> nat -> nat.

  Axiom run_Example1 : run Done 0 = 0.
  Axiom run_Example2 : run (MulThen 5 (AddThen 2 Done)) 1 = 7.
  Axiom run_Example3 : run (SetToThen 3 (MulThen 2 Done)) 10 = 6.

  (* Define [numInstructions] to compute the number of instructions
   * in a program, not counting [Done] as an instruction.
   *)
  Parameter numInstructions : Prog -> nat.

  Axiom numInstructions_Example :
    numInstructions (MulThen 5 (AddThen 2 Done)) = 2.

  (* Define [concatProg] such that [concatProg p1 p2] is the program
   * that first runs [p1] and then runs [p2].
   *)
  Parameter concatProg : Prog -> Prog -> Prog.

  Axiom concatProg_Example :
     concatProg (AddThen 1 Done) (MulThen 2 Done)
   = AddThen 1 (MulThen 2 Done).

  (* Prove that the number of instructions in the concatenation of
   * two programs is the sum of the number of instructions in each
   * program.
   *)
  Axiom concatProg_numInstructions : forall p1 p2,
      numInstructions (concatProg p1 p2)
      = numInstructions p1 + numInstructions p2.

  (* Prove that running the concatenation of [p1] with [p2] is
     equivalent to running [p1] and then running [p2] on the
     result. *)
  Axiom concatProg_run : forall p1 p2 initState,
      run (concatProg p1 p2) initState =
      run p2 (run p1 initState).

  (* As there is no intuitive or broadly useful definition for x/0,
     common processors handle it differently. We would like to model the
     portable behavior of a program, that is, its behavior to the extent
     it is known without relying on arbitrary choices about division by
     zero. The following interpreter returns (b, s), where the Boolean [b]
     indicates whether the execution completed without division by
     zero, and if it did, then [s] is the final state. First, you will be
     asked to prove that [s] matches [run] in those cases. *)
  Fixpoint runPortable (p : Prog) (state : nat) : bool * nat :=
    match p with
    | Done => (true, state)
    | AddThen n p => runPortable p (n+state)
    | MulThen n p => runPortable p (n*state)
    | DivThen n p =>
        if n ==n 0 then (false, state) else
        runPortable p (state/n)
    | VidThen n p =>
        if state ==n 0 then (false, 0) else
        runPortable p (n/state)
    | SetToThen n p =>
        runPortable p n
    end.

  Axiom runPortable_run : forall p s0 s1,
    runPortable p s0 = (true, s1) -> run p s0 = s1.

  (* Static analysis to validate that a program never divides by 0 *)

  (* The final goal of this pset is to implement [validate : Prog -> bool] *)
  Parameter validate : Prog -> bool.
  (* such that if this function returns [true], the program would not trigger
     division by zero regardless of what state it starts out in.  [validate] is
     allowed to return [false] for some perfectly good programs that never cause
     a division by zero, but it must recognize as good the examples given below.
     In jargon, [validate] is required to be sound but not complete, but
     "complete enough" for the use cases defined by the examples given here: *)
  Definition goodProgram1 := AddThen 1 (VidThen 10 Done).
  Definition goodProgram2 := AddThen 0 (MulThen 10 (AddThen 0 (DivThen 1 Done))).
  Definition goodProgram3 := AddThen 1 (MulThen 10 (AddThen 0 (VidThen 1 Done))).
  Definition goodProgram4 := Done.
  Definition goodProgram5 := SetToThen 0 (DivThen 1 Done).
  Definition goodProgram6 := SetToThen 1 (VidThen 1 Done).
  Definition goodProgram7 := AddThen 1 (DivThen 1 (DivThen 1 (VidThen 1 Done))).
  Axiom validate1 : validate goodProgram1 = true.
  Axiom validate2 : validate goodProgram2 = true.
  Axiom validate3 : validate goodProgram3 = true.
  Axiom validate4 : validate goodProgram4 = true.
  Axiom validate5 : validate goodProgram5 = true.
  Axiom validate6 : validate goodProgram6 = true.
  Axiom validate7 : validate goodProgram7 = true.

  Axiom validate_sound : forall p, validate p = true ->
    forall s, runPortable p s = (true, run p s).
End S.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. lfind.   reflexivity.  }
Admitted.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.


Require Import basic.

(** In this file we show that Coq universes allows to build
   Grothendieck universes.
   We take two copies of the set type, and we embed the
   "big set" of all the "small sets" (that we call U),
   and we show that U is a Grothendieck universe.
 *)

Require Ens0.
Require Ens.

(** Level 1: small sets *)
Module S := Ens0.IZF_R.
(** Level 2 : big sets *)
Module B := Ens.IZF_R.

(** Notations for big sets *)
Notation "x ∈ y" := (B.in_set x y) (at level 60).
Notation "x == y" := (B.eq_set x y) (at level 70).

(** This definition implies that the universe of indexes of small
   sets is lower than (or equal to) the universes of indexes of
   large sets (Ens0.Tlo <= Ens.Tlo)
 *)
Fixpoint injU (a:S.set) : B.set :=
  match a with
    S.sup X f => B.sup X (fun i => injU (f i))
  end.

(** Soundness of lifting *)

Lemma lift_eq : forall x y, S.eq_set x y -> injU x == injU y.
intros.
revert x y H.
induction x; destruct y; simpl; intros.
destruct H0.
split; intros.
 elim H0 with i; intros.
 exists x.
 apply H; trivial.

 elim H1 with j; intros.
 exists x.
 apply H; trivial.
Qed.

Lemma down_eq : forall x y, injU x == injU y -> S.eq_set x y.
intros.
revert x y H.
induction x; destruct y; simpl; intros.
destruct H0.
split; intros.
 elim (H0 i); intros.
 exists x; auto.

 elim (H1 j); intros.
 exists x; auto.
Qed.

Lemma lift_in : forall x y, S.in_set x y -> injU x ∈ injU y.
destruct y; simpl; intros.
destruct H; simpl in *.
apply lift_eq in H.
exists x0.
assumption.
Qed.

Lemma down_in : forall x y, injU x ∈ injU y -> S.in_set x y.
destruct y; simpl; intros.
destruct H.
simpl injU in H.
exists x0.
apply down_eq; trivial.
Qed.

Lemma down_in_ex  x y y' :
  y == injU y' ->
  x ∈ y ->
  exists2 x', x == injU x' & S.in_set x' y'.
intros.
specialize B.eq_elim with (1:=H0) (2:=H); intro.
destruct H1.
destruct y' as (Y,f).
simpl in x0, H1.
exists (f x0); trivial.
apply down_in.
apply B.eq_elim with y; trivial.
apply B.in_reg with x; trivial.
Qed.

(** With the following, the universe of small sets is lower than (or equal to)
   the universe of indexes of big sets (Ens0.Thi <= Ens.Tlo).
 *)
Definition U : B.set := B.sup S.set injU.

Lemma U_intro : forall x, injU x ∈ U.
red; intros.
exists x.
apply B.eq_set_refl.
Qed.

Lemma U_elim : forall x, x ∈ U -> exists x', x == injU x'.
destruct 1.
exists x0; trivial.
Qed.

Lemma injU_elim : forall x y, x ∈ injU y -> x ∈ U.
destruct y; destruct 1; simpl; intros.
exists (f x0).
assumption.
Qed.

(** Equivalence of all set-theoretical constructions *)

Lemma pair_equiv : forall x y,
  B.pair (injU x) (injU y) == injU (S.pair x y).
intros.
unfold B.pair, S.pair; simpl.
split; intros.
 exists i; destruct i; apply B.eq_set_refl.
 exists j; destruct j; apply B.eq_set_refl.
Qed.

Lemma union_equiv : forall x, B.union (injU x) == injU (S.union x).
intros.
apply B.eq_intro; intros.
 apply B.union_ax in H.
 destruct H.
 apply down_in_ex with (1:=B.eq_set_refl _) in H0.
 destruct H0.
 apply down_in_ex with (1:=H0) in H; destruct H.
 apply B.in_reg with (injU x2).
  apply B.eq_set_sym; trivial.
 apply lift_in.
 rewrite S.union_ax.
 exists x1; trivial.

 rewrite B.union_ax.
 apply down_in_ex with (1:=B.eq_set_refl _) in H; destruct H.
 rewrite S.union_ax in H0; destruct H0.
 apply lift_in in H0.
 apply lift_in in H1.
 exists (injU x1); trivial.
 apply B.in_reg with (injU x0); trivial.
 apply B.eq_set_sym; trivial.
Qed.

Lemma subset_equiv : forall x P Q,
  (forall x y, y == injU x -> (P x <-> Q y)) ->
  injU (S.subset x P) == B.subset (injU x) Q.
intros.
unfold S.subset, B.subset.
destruct x; simpl.
split; intros.
 destruct i; simpl.
 assert (exists2 x', injU (f x) == x' & Q x').
  destruct e.
  exists (injU x0).
   apply lift_eq; trivial.
   rewrite <- (H x0); trivial.
   apply B.eq_set_refl.
 exists (exist (fun a => exists2 x', injU (f a) == x' & Q x') x H0); simpl.
 apply B.eq_set_refl.

 destruct j; simpl.
 assert (exists2 x', S.eq_set (f x) x' & P x').
  destruct e.
  exists (f x).
   apply S.eq_set_refl.
   rewrite (H (f x) x0); trivial.
   apply B.eq_set_sym; trivial.
 exists (exist (fun a => exists2 x', S.eq_set (f a) x' & P x') x H0); simpl.
 apply B.eq_set_refl.
Qed.

Lemma power_equiv : forall x, B.power (injU x) == injU (S.power x).
intros.
apply B.eq_intro; intros.
 rewrite B.power_ax in H.
 apply B.in_reg with (injU (S.subset x (fun x' => injU x' ∈ z))).
  apply B.eq_set_trans with (B.subset (injU x) (fun x' => x' ∈ z)).
   apply subset_equiv; intros.
   split; intros.
    apply B.in_reg with (injU x0); trivial.
    apply B.eq_set_sym; trivial.

    apply B.in_reg with y; trivial.

   apply B.eq_intro; intros.
    rewrite B.subset_ax in H0.
    destruct H0.
    destruct H1.
    apply B.in_reg with x0; trivial.
    apply B.eq_set_sym; trivial.

    rewrite B.subset_ax.
    split; auto.
    exists z0; trivial.
    apply B.eq_set_refl.

  apply lift_in.
  rewrite S.power_ax; intros.
  rewrite S.subset_ax in H0.
  destruct H0; trivial.

 rewrite B.power_ax; intros.
 specialize injU_elim with (1:=H); intro.
 apply U_elim in H1.
 destruct H1.
 assert (y ∈ injU x0).
  apply B.eq_elim with z; trivial.
 specialize injU_elim with (1:=H2); intro.
 apply U_elim in H3.
 destruct H3.
 apply B.in_reg with (injU x1).
  apply B.eq_set_sym; trivial.

  apply lift_in.
  assert (S.in_set x0 (S.power x)).
   apply down_in.
   apply B.in_reg with z; trivial.
  rewrite S.power_ax in H4.
  apply H4.
  apply down_in.
  apply B.in_reg with y; trivial.

Qed.

Lemma repl1_equiv : forall x f a F,
  a == injU x ->
  (forall x x', proj1_sig x' == injU (proj1_sig x) -> F x' == injU (f x)) ->
  B.repl1 a F == injU (S.repl1 x f).
destruct x; intros.
destruct a as (A,g); simpl in H.
destruct H.
split; simpl; intros.
 elim (H i); intros.
 exists x; simpl.
 apply H0; simpl; trivial.

 elim (H1 j); intros.
 exists x; simpl.
 apply H0; simpl; trivial.
Qed.

(* Closure properties of U *)

Lemma U_trans : forall x y, y ∈ x -> x ∈ U -> y ∈ U.
intros.
apply U_elim in H0; destruct H0.
assert (y ∈ injU x0).
 apply B.eq_elim with x; trivial.
apply injU_elim in H1; trivial.
Qed.

Lemma U_pair : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U.
intros.
apply U_elim in H; destruct H.
apply U_elim in H0; destruct H0.
apply B.in_reg with (injU (S.pair x0 x1)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.pair (injU x0) (injU x1)).
  apply B.pair_morph; trivial.

  apply pair_equiv.

 apply U_intro.
Qed.

Lemma U_power : forall x, x ∈ U -> B.power x ∈ U.
intros.
apply U_elim in H; destruct H.
apply B.in_reg with (injU (S.power x0)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.power (injU x0)).
  apply B.power_morph; trivial.

  apply power_equiv.

 apply U_intro.
Qed.

Lemma U_union : forall x, x ∈ U -> B.union x ∈ U.
intros.
apply U_elim in H; destruct H.
apply B.in_reg with (injU (S.union x0)).
 apply B.eq_set_sym.
 apply B.eq_set_trans with (B.union (injU x0)).
  apply B.union_morph; trivial.

  apply union_equiv.

 apply U_intro.
Qed.

Lemma U_repl : forall a R,
  Proper (B.eq_set==>B.eq_set==>iff) R ->
  a ∈ U ->
  (forall x y y', x ∈ a -> y ∈ U -> y' ∈ U ->
   R x y -> R x y' -> y == y') ->
  exists2 b, b ∈ U & forall y, y ∈ U ->
                         (y ∈ b <-> exists2 x, x ∈ a & R x y).
intros.
apply U_elim in H0; destruct H0.
(* replacement on small sets *)
destruct S.repl_ax with x (fun x y => R (injU x) (injU y)) as (b,Hb).
 intros.
 revert H5; apply iff_impl; apply H; apply lift_eq; trivial.

 intros.
 apply down_eq.
 apply H1 with (injU x0); trivial.
  apply B.eq_set_sym in H0.
  apply B.eq_elim with (injU x); trivial.
  apply lift_in; trivial.

  apply U_intro.

  apply U_intro.

 exists (injU b).
  apply U_intro.

  split; intros.
   apply U_elim in H2; destruct H2.
   generalize (B.in_reg _ _ _ H2 H3); intro.
   apply down_in in H4.
   rewrite Hb in H4.
   destruct H4.
   exists (injU x1); trivial.
    apply lift_in in H4.
    apply B.eq_set_sym in H0.
    apply B.eq_elim with (injU x); trivial.

    revert H5; apply iff_impl; apply H; trivial.
    apply B.eq_set_refl.
    apply B.eq_set_sym; trivial.

  destruct H3.
  specialize B.eq_elim with (1:=H3) (2:=H0); intro.
  specialize injU_elim with (1:=H5); intro.
  apply U_elim in H6; destruct H6.
  generalize (B.in_reg _ _ _ H6 H5); intro.
  apply down_in in H7.
  apply U_elim in H2; destruct H2.
  apply B.eq_set_sym in H2.
  apply B.in_reg with (injU x2); trivial.
  apply lift_in.
  rewrite Hb.
  exists x1; trivial.
  revert H4; apply iff_impl; apply H; trivial.
  apply B.eq_set_sym; trivial.
Qed.

(** If the small sets are closed under collection, then so
   is U. *)
Lemma U_coll : forall a R,
  Proper (B.eq_set==>B.eq_set==>iff) R ->
  a ∈ U ->
  (forall x, x ∈ a -> exists2 y, y ∈ U & R x y) ->
  exists2 b, b ∈ U & forall x, x ∈ a -> exists2 y, y ∈ b & R x y.
intros.
apply U_elim in H0; destruct H0 as (a',?).
(* We use collection on small sets *)
destruct S.coll_ax_ttcoll with a' (fun x y => R (injU x) (injU y)).
 intros.
 revert H5; apply iff_impl; apply H; apply lift_eq; trivial.

 intros.
 apply lift_in in H2.
 apply B.eq_set_sym in H0.
 specialize B.eq_elim with (1:=H2) (2:=H0); intro.
 apply H1 in H3.
 destruct H3.
 apply U_elim in H3; destruct H3.
 exists x1.
 revert H4; apply iff_impl; apply H; trivial.
 apply B.eq_set_refl.

 exists (injU x).
  apply U_intro.

  intros.
  apply down_in_ex with (1:=H0) in H3.
  destruct H3.
  apply H2 in H4.
  destruct H4.
  exists (injU x2).
   apply lift_in; trivial.

   revert H5; apply iff_impl; apply H; trivial.
    apply B.eq_set_sym; trivial.
    apply B.eq_set_refl.
Qed.

(** Grothendieck universe *)
Record grot_univ (U:B.set) : Prop := {
  G_trans : forall x y, y ∈ x -> x ∈ U -> y ∈ U;
  G_pair : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U;
  G_power : forall x, x ∈ U -> B.power x ∈ U;
  G_union : forall x, x ∈ U -> B.union x ∈ U;
  G_repl : forall a R, Proper (B.eq_set==>B.eq_set==>iff) R ->
           a ∈ U ->
           (forall x y y', x ∈ a -> y ∈ U -> y' ∈ U -> R x y -> R x y' -> y == y') ->
           exists2 b, b ∈ U & forall y, y ∈ U -> (y ∈ b <-> exists2 x, x ∈ a & R x y) }.

Lemma U_univ : grot_univ U.
constructor.
 apply U_trans.
 apply U_pair.
 apply U_power.
 apply U_union.
 apply U_repl.
Qed.

(* begin hide *)
(* Weak Grothendieck universe: closure only under
   *functional* replacement. Uses *relational* replacement
   on small sets.
 *)
Record grot_univ1 (U:B.set) : Prop := {
  G_trans1 : forall x y, y ∈ x -> x ∈ U -> y ∈ U;
  G_pair1 : forall x y, x ∈ U -> y ∈ U -> B.pair x y ∈ U;
  G_power1 : forall x, x ∈ U -> B.power x ∈ U;
  G_union_repl1 : forall I F,
                 (forall x x', proj1_sig x == proj1_sig x' -> F x == F x') ->
                 I ∈ U ->
                 (forall x, F x ∈ U) ->
                 B.union (B.repl1 I F) ∈ U }.

Lemma U_univ1 : grot_univ1 U.
constructor.
 apply U_trans.
 apply U_pair.
 apply U_power.

 intros.
 apply U_elim in H0; destruct H0.
 assert (forall z, S.in_set z x -> injU z ∈ I).
  intros.
  apply B.eq_set_sym in H0.
  apply B.eq_elim with (injU x); trivial.
  apply lift_in; trivial.
 (* We have F producing big sets in U, and we need a function producing
    small sets to use functional replacement on small sets. We're stuck
    again. Relational replacement does it, of course!
  *)
 destruct S.repl_ax with x
         (fun x' y => exists h:injU x' ∈ I, F (exist (fun z=>z ∈ I) _ h) == injU y)
   as (B,HB).
  intros.
  destruct H6.
  assert (injU x' ∈ I).
   apply B.eq_elim with (injU x).
   2:apply B.eq_set_sym; trivial.
   apply lift_in.
   apply S.in_reg with x0; trivial.
  exists H7.
  apply lift_eq in H5.
  apply B.eq_set_trans with (2:=H5).
  apply B.eq_set_trans with (2:=H6).
  apply H; simpl.
  apply lift_eq; apply S.eq_set_sym; trivial.

  intros.
  destruct H4; destruct H5.
  apply down_eq.
  apply B.eq_set_trans with (1:=B.eq_set_sym _ _ H4).
  apply B.eq_set_trans with (2:=H5).
  apply H; simpl; apply B.eq_set_refl.

  apply B.in_reg with (injU (S.union B)).
  2:apply U_intro.
  apply B.eq_set_sym.
  apply B.eq_set_trans with (2:=union_equiv B).
  apply B.union_morph.
  apply B.eq_set_ax; split; intros.
   apply B.repl1_ax in H3; trivial.
   destruct H3.
   destruct (U_elim _ (H1 x0)).
   apply B.in_reg with (injU x1).
    apply B.eq_set_sym; apply B.eq_set_trans with (F x0); trivial.

    apply lift_in.
    rewrite HB.
    destruct (down_in_ex _ _ _ H0 (proj2_sig x0)).
    exists x2; trivial.
    exists (H2 _ H6).
    apply B.eq_set_trans with (2:=H4).
    apply H; simpl.
    apply B.eq_set_sym; trivial.

   apply down_in_ex with (1:=B.eq_set_refl _) in H3.
   destruct H3.
   rewrite HB in H4; clear HB.
   destruct H4.
   destruct H5.
   rewrite B.repl1_ax; trivial.
   exists (exist (fun z => z ∈ I) (injU x1) x2).
   apply B.eq_set_trans with (1:=H3).
   apply B.eq_set_sym; trivial.
Qed.
(* end hide *)


(** * 6.512 Formal Reasoning About Programs, Spring 2023 - Pset 6 *)

Require Coq816.
Require Import Frap.Frap.

(* The `swap` function defined here switches the elements in a list at positions `n1` and `n2`.
     Since it is not the focus of this assignment, we have provided all of the theorems necessary
     to work with it. You should not unfold `swap` and should only use existing theorems
     to reason about it.

   You can look at these proofs if you would like, but most of them will not be similar to
   the proofs you have to complete.
 *)
Module Swap.

  Local Definition swap' {A} (n1 n2 : nat) (l : list A) default :=
    firstn n1 l ++ (nth n2 l default)::(firstn (n2 - S n1) (skipn (S n1) l))
      ++ (nth n1 l default)::(skipn (S n2) l).

  (* Assumption: n1 < n2 < length l *)
  (* uses some tricks to avoid a default element and to make lemmas easier to use *)
  Definition swap {A} (n1 n2 : nat) (l : list A) :=
    if (Nat.leb n2 n1) || (Nat.leb (length l) n2) then l
    else match l with
         | [] => []
         | a::_ => swap' n1 n2 l a
         end.

  Lemma Forall2_nth A B R l1 l2 (a:A) (b:B)
    : Forall2 R l1 l2 ->
      forall n,
        n < length l2 ->
        R (nth n l1 a) (nth n l2 b).
  Proof.
    induct 1;
      simplify;
      try linear_arithmetic;
      auto.
    cases n;
      simplify; eauto.
    apply IHForall2;
      try linear_arithmetic;
      auto.
  Qed.

  Local Hint Constructors Forall2 : core.

  Lemma Forall2_ext A B (R : A -> B -> Prop)
    : forall l1 l2,
      (forall n a b, n < length l2 -> R (nth n l1 a) (nth n l2 b)) ->
      length l1 = length l2 ->
      Forall2 R l1 l2.
  Proof.
    induct l1;
      simplify;
      cases l2;
      simplify;
      auto;
      try linear_arithmetic.
    invert H0.
    pose proof (fun n => H (S n)).
    pose proof (H 0).
    clear H.
    simplify.
    first_order.
    constructor; eauto.
    {
      apply H1; auto; linear_arithmetic.
    }
    {
      apply IHl1; auto.
      simplify; apply H0; linear_arithmetic.
    }
  Qed.

  Local Lemma length_swap' A (l : list A) n1 n2 a
    : n1 < n2 ->
      n2 < length l ->
      length (swap' n1 n2 l a) = length l.
  Proof.
    unfold swap'.
    intros.
    repeat (rewrite ?app_length, ?firstn_length, ?skipn_length; cbn [length]).
    rewrite Nat.min_l by linear_arithmetic.
    rewrite Nat.min_l by linear_arithmetic.
    linear_arithmetic.
  Qed.

  Lemma length_swap A (l : list A) n1 n2
    : length (swap n1 n2 l) = length l.
  Proof.
    unfold swap.
    destruct (Nat.leb_spec n2 n1);
      simplify; auto.
    destruct (Nat.leb_spec (length l) n2);
      simplify; auto.
    cases l; auto.
    apply length_swap'; auto.
  Qed.
  Global Hint Rewrite length_swap : core.

  Lemma Forall2_length A B (R: A -> B -> Prop) l1 l2
    : Forall2 R l1 l2 ->
      length l1 = length l2.
  Proof.
    induct 1; simplify; eauto.
  Qed.
  Global Hint Resolve Forall2_length : core.

  Lemma Forall2_app A B (R : A -> B -> Prop) l11 l12 l21 l22
    : Forall2 R l11 l12 ->
      Forall2 R l21 l22 ->
      Forall2 R (l11++l21) (l12++l22).
  Proof.
    induct 1; simplify; eauto.
  Qed.

  Lemma Forall2_firstn A B (R : A -> B -> Prop) l1 l2
    : Forall2 R l1 l2 ->
      forall n,
        Forall2 R (firstn n l1) (firstn n l2).
  Proof.
    induct 1; simplify; cases n; simplify; eauto.
  Qed.

  Lemma Forall2_skipn A B (R : A -> B -> Prop) l1 l2
    : Forall2 R l1 l2 ->
      forall n,
        Forall2 R (skipn n l1) (skipn n l2).
  Proof.
    induct 1; simplify; cases n; simplify; eauto.
  Qed.

  Local Lemma Forall2_swap' A B (R : A -> B -> Prop) l1 l2 a b
    : Forall2 R l1 l2 ->
      forall n1 n2,
        n1 < n2 ->
        n2 < length l2 ->
        Forall2 R (swap' n1 n2 l1 a) (swap' n1 n2 l2 b).
  Proof.
    unfold swap'.
    intros.
    repeat first
      [ assumption
      | apply Forall2_app
      | apply Forall2_firstn
      | apply Forall2_skipn
      | apply List.Forall2_cons
      | apply Forall2_nth].
    linear_arithmetic.
  Qed.

  Lemma Forall2_swap A B (R : A -> B -> Prop) l1 l2
    : Forall2 R l1 l2 ->
      forall n1 n2,
        Forall2 R (swap n1 n2 l1) (swap n1 n2 l2).
  Proof.
    intros.
    unfold swap.
    destruct (Nat.leb_spec n2 n1);
      simplify; auto.
    pose proof (Forall2_length _ _ _ _ _ H) as Hlen;
      rewrite Hlen.
    destruct (Nat.leb_spec (length l2) n2);
      simplify; auto.
    cases l1; cases l2; simplify; try linear_arithmetic.
    apply Forall2_swap'; simplify; propositional.
  Qed.
  Global Hint Resolve Forall2_swap : core.

  Local Lemma app_swap'1
    : forall (A : Type) (l l' : list A) (n1 n2 : nat) a,
      n1 < n2 -> n2 < Datatypes.length l -> swap' n1 n2 (l ++ l') a = (swap' n1 n2 l a)++l'.
  Proof.
    intros.
    unfold swap'.
    rewrite !firstn_app, !skipn_app, !app_nth1 by linear_arithmetic.
    repeat (replace (_ - length l) with 0 by linear_arithmetic).
    repeat change (firstn 0 _) with (@nil A).
    repeat change (skipn 0 ?l) with l.
    rewrite !app_nil_r.
    rewrite <- !app_assoc.
    rewrite !firstn_app.
    rewrite skipn_length.
    replace (n2 - S n1 - (Datatypes.length l - S n1)) with 0 by linear_arithmetic.
    repeat change (firstn 0 _) with (@nil A).
    rewrite !app_nil_r.

    cbn [app].
    rewrite <- !app_assoc.
    reflexivity.
  Qed.

  Lemma app_swap1
    : forall (A : Type) (l l' : list A) (n1 n2 : nat),
      n1 < n2 -> n2 < Datatypes.length l ->
      swap n1 n2 (l ++ l') = (swap n1 n2 l)++l'.
  Proof.
    simplify.
    unfold swap.
    destruct (Nat.leb_spec n2 n1);
      simplify; auto.
    destruct (Nat.leb_spec (length l) n2);
      simplify; try linear_arithmetic.
    destruct (Nat.leb_spec (length (l ++ l')) n2);
      simplify; rewrite app_length in *; try linear_arithmetic.
    cases l; simplify; try linear_arithmetic.
    change (a :: l ++ l') with ((a::l)++l').
    apply app_swap'1; auto.
  Qed.

End Swap.

Arguments Swap.swap : simpl never.
Import Swap.

Module Type S.

(*
  We'll be working with a small stack-based language in this lab, where we
  interpret a program as a transformation from an input stack to an output stack,
  primarily done by pushing and popping values on and off the stack.
 *)

Inductive stack_val :=
| val_lit (n : nat)
| val_nil
| val_cons (v1 v2 : stack_val).

Inductive ty : Set :=
| ty_nat
| ty_list (t : ty).

Inductive val_well_typed : stack_val -> ty -> Prop :=
| val_lit_wt n : val_well_typed (val_lit n) ty_nat
| val_nil_wt t : val_well_typed val_nil (ty_list t)
| val_cons_wt t v1 v2
  : val_well_typed v1 t ->
      val_well_typed v2 (ty_list t) ->
      val_well_typed (val_cons v1 v2) (ty_list t).

Local Notation stack_well_typed := (Forall2 val_well_typed).

Definition stack_unop f (s : list stack_val) :=
  match s with
  | a::s' => (f a)::s'
  | _ => (*this case never happens on well-typed programs*) s
  end.

Definition stack_binop f (s : list stack_val) :=
  match s with
  | a::b::s' => (f a b)::s'
  | _ => (*this case never happens on well-typed programs*) s
  end.

Definition stack_pop (s : list stack_val) :=
  match s with
  | a::s => (a,s)
  | _ => (*this case never happens on well-typed programs*) (val_lit 0, [])
  end.

Definition stack_peek (s : list stack_val) :=
  match s with
  | a::_ => a
  | _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Fixpoint val_app v1 v2 :=
  match v1 with
  | val_nil => v2
  | val_cons v11 v12 => val_cons v11 (val_app v12 v2)
  | val_lit _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Fixpoint val_flatmap (f : stack_val -> stack_val) v :=
  match v with
  | val_nil => val_nil
  | val_cons v1 v2 =>
      val_app (f v1) (val_flatmap f v2)
  | val_lit _ => val_lit 0
  end.

Fixpoint val_reduce (f : stack_val -> stack_val -> stack_val) vl vacc :=
  match vl with
  | val_nil => vacc
  | val_cons v1 v2 =>
      val_reduce f v2 (f vacc v1)
  | val_lit _ => val_lit 0
  end.

(*[4%]*)
Parameter val_flatmap_sound
  : forall t1 t2 f l,
    (forall x, val_well_typed x t1 -> val_well_typed (f x) (ty_list t2)) ->
    val_well_typed l (ty_list t1) ->
    val_well_typed (val_flatmap f l) (ty_list t2).

Inductive stack_cmd :=
| cmd_atom (v : stack_val) (c : stack_cmd)
| cmd_unop (f : stack_val -> stack_val) (c : stack_cmd)
| cmd_binop (f : stack_val -> stack_val -> stack_val) (c : stack_cmd)
| cmd_swap (n1 n2 : nat) (c : stack_cmd)
| cmd_flatmap (cf : stack_cmd) (c : stack_cmd)
| cmd_reduce (cf : stack_cmd) (c : stack_cmd)
| cmd_skip.

Inductive cmd_well_typed : list ty -> stack_cmd -> list ty -> Prop :=
| cmd_atom_wt v t S c S'
  : val_well_typed v t ->
    cmd_well_typed (t::S) c S' ->
    cmd_well_typed S (cmd_atom v c) S'
| cmd_unop_wt f t1 t2 S c S'
  : (forall v, val_well_typed v t1 -> val_well_typed (f v) t2) ->
    cmd_well_typed (t2::S) c S' ->
    cmd_well_typed (t1::S) (cmd_unop f c) S'
| cmd_binop_wt f t1 t2 t3 S c S'
  : (forall v1 v2, val_well_typed v1 t1 ->
                   val_well_typed v2 t2 ->
                   val_well_typed (f v1 v2) t3) ->
    cmd_well_typed (t3::S) c S' ->
    cmd_well_typed (t1::t2::S) (cmd_binop f c) S'
| cmd_swap_wt S n1 n2 c S'
  : n1 < n2 ->
    n2 < length S ->
    cmd_well_typed (swap n1 n2 S) c S' ->
    cmd_well_typed S (cmd_swap n1 n2 c) S'
| cmd_flatmap_wt S (cf : stack_cmd) t1 t2 c S'
  : cmd_well_typed ((ty_list t2)::S) c S' ->
    cmd_well_typed [t1] cf [ty_list t2] ->
    cmd_well_typed ((ty_list t1)::S) (cmd_flatmap cf c) S'
| cmd_reduce_wt S (cf : stack_cmd) t t_acc c S'
  : cmd_well_typed (t_acc::S) c S' ->
    cmd_well_typed [t; t_acc] cf [t_acc] ->
    cmd_well_typed ((ty_list t)::t_acc::S) (cmd_reduce cf c) S'
| cmd_skip_wt S
  : cmd_well_typed S (cmd_skip) S.

Fixpoint interp_cmd (c : stack_cmd) (s : list stack_val) : list stack_val :=
  match c with
  | cmd_atom v c' => interp_cmd c' (v::s)
  | cmd_unop f c' => interp_cmd c' (stack_unop f s)
  | cmd_binop f c' => interp_cmd c' (stack_binop f s)
  | cmd_swap n1 n2 c' => interp_cmd c' (swap n1 n2 s)
  | cmd_flatmap cf c' =>
      let (l,s1) := stack_pop s in
      let out := val_flatmap (fun x => stack_peek (interp_cmd cf [x])) l in
      interp_cmd c' (out::s1)
  | cmd_reduce cf c' =>
      let (l,s) := stack_pop s in
      let (acc,s) := stack_pop s in
      let out := val_reduce (fun acc x => stack_peek (interp_cmd cf [x;acc])) l acc in
      interp_cmd c' (out::s)
  | cmd_skip => s
  end.

(*[4%]*)
Parameter interp_sound
  : forall S c S',
    cmd_well_typed S c S' ->
    forall s, stack_well_typed s S ->
              stack_well_typed (interp_cmd c s) S'.

(*[2%]*)
Parameter cmd_seq : stack_cmd -> stack_cmd -> stack_cmd.

(*[2%]*)
Parameter cmd_seq_wt
  : forall S1 S2 S3 c1 c2,
    cmd_well_typed S1 c1 S2 ->
    cmd_well_typed S2 c2 S3 ->
    cmd_well_typed S1 (cmd_seq c1 c2) S3.

(*[3%]*)
Parameter interp_seq
  : forall c1 c2 s, interp_cmd (cmd_seq c1 c2) s
                    = interp_cmd c2 (interp_cmd c1 s).

(*[8%]*)
Parameter flatmap_fuse : forall cf1 cf2 c s,
    interp_cmd (cmd_flatmap cf1 (cmd_flatmap cf2 c)) s
    = interp_cmd (cmd_flatmap (cmd_seq cf1 (cmd_flatmap cf2 cmd_skip)) c) s.

Parameter partial_eval : stack_cmd -> stack_cmd.

Parameter partial_eval_sound
  : forall S c S', cmd_well_typed S c S' ->
    cmd_well_typed S (partial_eval c) S'.

(*[30%]*)
Parameter partial_eval_correct
  : forall S c S', cmd_well_typed S c S' ->
    forall s, stack_well_typed s S -> interp_cmd (partial_eval c) s = interp_cmd c s.

(*[6%]*)
Parameter loop_fuse : stack_cmd -> stack_cmd.

(* Some common comands for use in our test cases *)
Definition val_add x y :=
  match x,y with
  | val_lit xl, val_lit yl => val_lit (xl + yl)
  | _,_ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Definition val_square x :=
  match x with
  | val_lit xl => val_lit (Nat.square xl)
  | _ => (*this case never happens on well-typed programs*) val_lit 0
  end.

Definition cmd_singleton := cmd_unop (fun x => val_cons x val_nil).
Definition cmd_lit n := cmd_atom (val_lit n).
Definition cmd_cons := cmd_binop val_cons.
Definition cmd_add := cmd_binop val_add.

(*[1%]*)
Parameter loop_fuse_test1
  : loop_fuse (cmd_flatmap (cmd_singleton (cmd_lit 0 (cmd_cons cmd_skip)))
                 (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip))) cmd_skip))
    = (cmd_flatmap (cmd_singleton
                      (cmd_lit 0
                         (cmd_cons
                            (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip)))
                               cmd_skip))))
         cmd_skip).

(*[1%]*)
Parameter loop_fuse_test2
  : loop_fuse (cmd_flatmap (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                              (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                                 (cmd_singleton cmd_skip)))
                 cmd_skip)
    = cmd_flatmap
         (cmd_flatmap
            (cmd_unop val_square
               (cmd_singleton
                  (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                     cmd_skip)))
            (cmd_singleton cmd_skip))
         cmd_skip.

(*[1%]*)
Parameter loop_fuse_test3
  : loop_fuse (cmd_flatmap (cmd_unop val_square (cmd_singleton cmd_skip))
                 (cmd_flatmap (cmd_singleton (cmd_lit 0 (cmd_cons cmd_skip)))
                 (cmd_flatmap (cmd_lit 1 (cmd_add (cmd_singleton cmd_skip))) cmd_skip)))
    = cmd_flatmap
        (cmd_unop val_square
           (cmd_singleton
              (cmd_flatmap
                 (cmd_singleton
                    (cmd_atom (val_lit 0)
                       (cmd_binop val_cons
                          (cmd_flatmap
                             (cmd_atom (val_lit 1)
                                (cmd_binop val_add (cmd_singleton cmd_skip)))
                             cmd_skip))))
                 cmd_skip)))
        cmd_skip.

(*[8%]*)
Parameter loop_fuse_sound
  : forall S c S', cmd_well_typed S c S' ->
    cmd_well_typed S (loop_fuse c) S'.

(*[30%]*)
Parameter loop_fuse_correct
  : forall S c S',
    cmd_well_typed S c S' ->
    forall s, stack_well_typed s S -> interp_cmd (loop_fuse c) s = interp_cmd c s.

End S.

(*|
HINTS: A few hints to help you if you get stuck on certain
       problems in Pset 6.
       Beware! Don't read further if you don't want spoilers!
=============================================================
|*)

(*|
HINT 1:
=======
This lemma is useful:
Lemma val_reduce_sound t1 t2 f l
  : (forall x acc', val_well_typed x t1 ->
                    val_well_typed acc' t2 ->
                    val_well_typed (f acc' x) t2) ->
    val_well_typed l (ty_list t1) ->
    forall acc,
    val_well_typed acc t2 ->
    val_well_typed (val_reduce f l acc) t2.
|*)

(*|
HINT 2:
=======
You can define a specialzed version of functional extensionality for flatmap.
This will be useful when you want to rewrite inside `f` or `g` while reasoning
about `val_flatmap`.

Lemma flatmap_funext f g l
  : (forall v, f v = g v) ->
    val_flatmap f l = val_flatmap g l.
|*)

(*|
HINT 3:
=======
If you are failing `loop_fuse_test2`, remember to handle `cf`.
If you are failing `loop_fuse_test3`, think about the order that
`loop_fuse` enounters the three consecutive `cmd_flatmap`s
and what recursive calls you should be making.
|*)

(*|
HINT 4:
=======
When we are working in a context where we assume everything is well-typed,
the default functional extensionality isn't sufficient since it forgets about
the type information.
You'll need a specialized lemma that keeps it around. This is the one for `flatmap`,
and the one for `reduce` is analogous.

Lemma flatmap_funext_typed f g l t1
  : (forall v, val_well_typed v t1 -> f v = g v) ->
    val_well_typed l (ty_list t1) ->
    val_flatmap f l = val_flatmap g l.
|*)


From stdpp Require Import numbers list.

Fixpoint existsInRange (n : nat) (f : nat -> bool) :=
  match n with
  | 0 => false
  | S n => orb (f n) (existsInRange n f)
  end.

Lemma existsInRangeZero (f : nat -> bool) : existsInRange 0 f = false.
Proof. easy. Qed.

Lemma existsInRangeSucc (n : nat) (f : nat -> bool) : existsInRange (S n) f = orb (f n) (existsInRange n f).
Proof. easy. Qed.

Definition existsInRangeLogic (n : nat) (f : nat -> bool) := exists i, i < n /\ f i = true.

Lemma existsInRangeLogicZero (f : nat -> bool) : ~existsInRangeLogic 0 f.
Proof. unfold existsInRangeLogic. intro h. destruct h as [w h]. lia. Qed.

Lemma existsInRangeLogicSucc (n : nat) (f : nat -> bool) : existsInRangeLogic (S n) f <-> f n = true \/ existsInRangeLogic n f.
Proof.
  split.
  - intro h. unfold existsInRangeLogic in *. destruct h as [w h].
    assert (H : w = n \/ w < n). { lia. }
    destruct H.
    + rewrite <- H. intuition.
    + right. exists w. intuition.
  - intro h. unfold existsInRangeLogic in *. destruct h.
    + exists n. intuition.
    + destruct H as [w h]. exists w. intuition.
Qed.

Definition notExistsInRangeLogic (n : nat) (f : nat -> bool) := forall i, i < n -> ~f i.

Lemma notExistsInRangeLogicZero (f : nat -> bool) : notExistsInRangeLogic 0 f.
Proof. unfold notExistsInRangeLogic. intros i h. lia. Qed.

Lemma notExistsInRangeLogicSucc (n : nat) (f : nat -> bool) : notExistsInRangeLogic (S n) f <-> ~f n /\ notExistsInRangeLogic n f.
Proof.
  split.
  - intro h. unfold notExistsInRangeLogic in *. split.
    + apply (h n). lia.
    + intros i h1. apply (h i). lia.
  - intro h. unfold notExistsInRangeLogic in *. intros i h1.
    destruct h as [h2 h3].
    assert (H : i = n \/ i < n). { lia. }
    destruct H.
    + rewrite H. auto.
    + apply (h3 i). auto.
Qed.

Lemma existsInRangeMeaning (n : nat) (f : nat -> bool) : existsInRange n f <-> existsInRangeLogic n f.
Proof.
  induction n.
  - rewrite existsInRangeZero. split.
    + easy.
    + apply existsInRangeLogicZero.
  - rewrite existsInRangeLogicSucc, existsInRangeSucc. intuition.
    remember (f n) as h2.
    destruct h2.
    + left. easy.
    + right. tauto.
Qed.

Lemma notExistsInRangeMeaning (n : nat) (f : nat -> bool) : ~existsInRange n f <-> notExistsInRangeLogic n f.
Proof.
  induction n.
  - rewrite existsInRangeZero. split.
    + intro h. apply notExistsInRangeLogicZero.
    + intuition.
  - rewrite existsInRangeSucc, notExistsInRangeLogicSucc. intuition.
    remember (f n) as h.
    destruct h.
    + easy.
    + intuition.
Qed.