(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export determinant.
Set Implicit Arguments.
Unset Strict Implicit.
Hint Resolve cart_def not_and_or or_not_and: geo.
Parameter vec_directeur : PP -> DR -> Prop.

Axiom
  vec_directeur_def :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    vec_directeur (vec A B) (droite C D) -> det (vec A B) (vec C D) = 0.

Axiom
  vec_directeur_def2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    det (vec A B) (vec C D) = 0 -> vec_directeur (vec A B) (droite C D).

Lemma vec_directeur_trivial :
 forall A B : PO, A <> B -> vec_directeur (vec A B) (droite A B).
intros.
apply vec_directeur_def2; auto.
apply determinant_colinearite with 1; auto.
Ringvec.
Qed.

Lemma existence_vec_directeur :
 forall A B : PO,
 A <> B ->
 exists C : PO, (exists D : PO, vec_directeur (vec C D) (droite A B)).
intros.
exists A; exists B.
apply vec_directeur_trivial; auto.
Qed.

Lemma vec_directeur_permute :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_directeur (vec A B) (droite C D) -> vec_directeur (vec C D) (droite A B).
intros.
apply vec_directeur_def2; auto.
rewrite determinant_antisymetrique.
rewrite vec_directeur_def; auto.
ring.
Qed.

Lemma paralleles_vec_directeur :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 paralleles (droite A B) (droite C D) -> vec_directeur (vec A B) (droite C D).
intros.
apply vec_directeur_def2; auto.
elim paralleles_vecteur with (A := C) (B := D) (C := A) (D := B);
 [ intros k H3; try clear paralleles_vecteur; try exact H3
 | auto
 | auto
 | auto with geo ].
apply determinant_colinearite with k; auto.
Qed.
Hint Resolve vec_directeur_def vec_directeur_def2 cartvec_def: geo.
Hint Immediate vec_directeur_permute: geo.

Lemma vec_directeur_paralleles :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_directeur (vec A B) (droite C D) -> paralleles (droite A B) (droite C D).
intros.
elim determinant_nul_colinearite with (A := C) (B := D) (C := A) (D := B);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.
Hint Resolve vec_directeur_paralleles paralleles_vec_directeur: geo.

Lemma vec_directeur_calcul :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 vec_directeur (vec A B) (droite C D) ->
 b * (x + - x0) + - (a * (y + - y0)) = 0.
intros A B C D x y x0 y0 a b H H0 H1 H2 H3 H4 H5 H6 H7; try assumption.
cut
 (vec C D =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)));
 [ intros | auto with geo ].
RReplace 0 (-0).
rewrite <- (vec_directeur_def (A:=A) (B:=B) (C:=C) (D:=D)); auto.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=C) (D:=D) (x:=a) (y:=b) (x':=
    x + - x0) (y':=y + - y0)); auto.
ring.
Qed.

Lemma equation_droite_parallele :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 paralleles (droite A B) (droite C D) ->
 b * (x + - x0) + - (a * (y + - y0)) = 0.
intros.
apply vec_directeur_calcul with (1 := H) (2 := H0); auto with geo.
Qed.

Lemma alignes_equation_cartesienne :
 forall (A B M : PO) (x y : R),
 x = abscisse M ->
 y = ordonnee M ->
 A <> B ->
 alignes A B M ->
 exists a : R,
   (exists b : R,
      (exists c : R, a * x + (b * y + c) = 0 /\ ~ (a = 0 /\ b = 0))).
intros A B M x y H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := A) (N := B);
 [ intros a H2; elim H2; [ intros b H3; try clear H2; try exact H3 ]
 | auto with geo ].
elim existence_coordonnees with (O := O) (I := I) (J := J) (M := A);
 [ intros x0 H2; elim H2; [ intros y0 H4; try clear H2; try exact H4 ]
 | auto with geo ].
cut
 (vec A M =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
exists (- b); exists a; exists (b * x0 + - (a * y0)).
split; [ try assumption | idtac ].
rewrite <- (alignement_determinant (A:=A) (B:=B) (M:=M)); auto.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=a) (y:=b) (x':=
    x + - x0) (y':=y + - y0)); auto.
ring.
contrapose H0.
applatit_and.
apply vecteur_nul_conf.
rewrite H3.
RReplace b (- - b).
rewrite H6; rewrite H7; Ringvec.
Qed.

Lemma equation_cartesienne_alignes :
 forall (M : PO) (x y a b c : R),
 x = abscisse M ->
 y = ordonnee M ->
 ~ (a = 0 /\ b = 0) ->
 a * x + (b * y + c) = 0 ->
 exists A : _, (exists B : _, A <> B /\ alignes A B M).
intros M x y a b c H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
cut (a <> 0 \/ b <> 0); intros.
elim H2; intros.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - c / a) (b := 0);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - b + - c / a) (b := a);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP (- b) (vec O I)) (mult_PP a (vec O J)));
 intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
apply determinant_nul_alignement; auto.
cut (vec A M = add_PP (mult_PP (x + c / a) (vec O I)) (mult_PP y (vec O J)));
 intros.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=- b) (y:=a) (x':=
    x + c / a) (y':=y)); auto.
RReplace 0 (-0).
rewrite <- H1; auto.
RReplace (- b * y + - (a * (x + c / a))) (- (b * y + a * (x + c / a))).
unfold Rdiv in |- *.
RReplace (a * (x + c * / a)) (a * x + c * (a * / a)).
RReplace (a * / a) 1.
ring.
RReplace (x + c / a) (x + - (- c / a)).
RReplace y (y + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := - b + - c / a)
    (y := a)
    (x' := - c / a)
    (y' := 0);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace (- b) (- b + - c / a + - (- c / a)).
pattern a at 3 in |- *.
RReplace a (a + -0).
apply composantes_vecAB; eauto with geo.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := 0) (b := - c / b);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - b) (b := a + - c / b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP (- b) (vec O I)) (mult_PP a (vec O J)));
 intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
apply determinant_nul_alignement; auto.
cut (vec A M = add_PP (mult_PP x (vec O I)) (mult_PP (y + c / b) (vec O J)));
 intros.
rewrite
 (determinant_def (A:=A) (B:=B) (C:=A) (D:=M) (x:=- b) (y:=a) (x':=x)
    (y':=y + c / b)); auto.
RReplace 0 (-0).
rewrite <- H1; auto.
RReplace (- b * (y + c / b) + - (a * x)) (- (b * (y + c / b) + a * x)).
unfold Rdiv in |- *.
RReplace (b * (y + c * / b)) (b * y + c * (b * / b)).
RReplace (b * / b) 1.
ring.
RReplace (y + c / b) (y + - (- c / b)).
RReplace x (x + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := - b)
    (y := a + - c / b)
    (x' := 0)
    (y' := - c / b);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace 0 (-0).
rewrite <- H9; ring.
RReplace (- b) (- b + -0).
RReplace a (a + - c / b + - (- c / b)).
apply composantes_vecAB; eauto with geo.
apply not_and_or; auto.
Qed.
Parameter vec_normal : PP -> DR -> Prop.

Axiom
  vec_normal_def :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    vec_normal (vec A B) (droite C D) -> orthogonal (vec A B) (vec C D).

Axiom
  vec_normal_def2 :
    forall A B C D : PO,
    A <> B ->
    C <> D ->
    orthogonal (vec A B) (vec C D) -> vec_normal (vec A B) (droite C D).
Require Export angles_droites.
Hint Resolve vec_normal_def vec_normal_def2: geo.

Lemma existence_vec_normal :
 forall A B : PO,
 A <> B -> exists C : PO, (exists D : PO, vec_normal (vec C D) (droite A B)).
intros.
soit_orthogonal A B ipattern:(D).
exists A; exists D; auto with geo.
Qed.

Lemma vec_normal_permute :
 forall A B C D : PO,
 A <> B ->
 C <> D ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec C D) (droite A B).
intros.
eauto with geo.
Qed.
Hint Immediate vec_normal_permute: geo.

Lemma vec_normal_directeur_orthogonaux :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec C D) (droite A B) ->
 vec_directeur (vec E F) (droite A B) -> orthogonal (vec C D) (vec E F).
intros.
apply vec_normal_def; auto.
elim determinant_nul_colinearite with (A := A) (B := B) (C := E) (D := F);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
apply vec_normal_def2; auto.
apply ortho_sym.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_orthogonal_directeur :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec C D) (droite A B) ->
 orthogonal (vec C D) (vec E F) -> vec_directeur (vec E F) (droite A B).
intros.
apply paralleles_vec_directeur; auto.
elim
 orthogonal_colineaires
  with (A := C) (B := D) (C := A) (D := B) (E := E) (F := F);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma vec_directeur_orthogonal_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_directeur (vec E F) (droite A B) ->
 orthogonal (vec C D) (vec E F) -> vec_normal (vec C D) (droite A B).
intros.
apply vec_normal_def2; auto.
apply ortho_sym.
elim determinant_nul_colinearite with (A := E) (B := F) (C := A) (D := B);
 [ intros k H4; try clear determinant_nul_colinearite; try exact H4
 | auto
 | auto with geo ].
rewrite H4; auto with geo.
Qed.

Lemma paralleles_l_vec_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 paralleles (droite A B) (droite E F) ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec E F) (droite C D).
intros.
elim paralleles_vecteur with (A := E) (B := F) (C := A) (D := B);
 [ intros k H4; try clear paralleles_vecteur | auto | auto | auto with geo ].
apply vec_normal_def2; auto.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_paralleles_l :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec A B) (droite C D) ->
 vec_normal (vec E F) (droite C D) -> paralleles (droite A B) (droite E F).
intros.
elim
 orthogonal_colineaires
  with (A := C) (B := D) (C := E) (D := F) (E := A) (F := B);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma vec_normal_paralleles_r :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 vec_normal (vec A B) (droite C D) ->
 vec_normal (vec A B) (droite E F) -> paralleles (droite C D) (droite E F).
intros.
elim
 orthogonal_colineaires
  with (A := A) (B := B) (C := E) (D := F) (E := C) (F := D);
 [ intros k H4; try clear orthogonal_colineaires; try exact H4
 | auto
 | auto
 | auto with geo
 | auto with geo ].
apply colineaires_paralleles with k; auto.
Qed.

Lemma paralleles_r_vec_normal :
 forall A B C D E F : PO,
 A <> B ->
 C <> D ->
 E <> F ->
 paralleles (droite C D) (droite E F) ->
 vec_normal (vec A B) (droite C D) -> vec_normal (vec A B) (droite E F).
intros.
elim paralleles_vecteur with (A := E) (B := F) (C := C) (D := D);
 [ intros k H4; try clear paralleles_vecteur | auto | auto | auto with geo ].
apply vec_normal_def2; auto.
apply ortho_sym.
rewrite H4; eauto with geo.
Qed.

Lemma vec_normal_calcul :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 vec_normal (vec A B) (droite C D) -> a * (x + - x0) + b * (y + - y0) = 0.
intros A B C D x y x0 y0 a b H H0 H1 H2 H3 H4 H5 H6 H7; try assumption.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros M H10 ].
elim existence_representant_vecteur with (A := O) (B := C) (C := D);
 [ intros N H20 ].
cut
 (vec C D =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J)));
 [ intros | auto with geo ].
replace 0 with (scalaire (vec A B) (vec C D)); auto with geo.
rewrite <- H10; rewrite <- H20.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=M) (N:=N) (x:=a) (y:=b)
    (x':=x + - x0) (y':=y + - y0)); auto with geo.
rewrite H10; auto.
rewrite H20; auto.
Qed.

Lemma equation_droite_orthogonal :
 forall (A B C D : PO) (x y x0 y0 a b : R),
 A <> B ->
 C <> D ->
 x = abscisse D ->
 y = ordonnee D ->
 x0 = abscisse C ->
 y0 = ordonnee C ->
 a = absvec (vec A B) ->
 b = ordvec (vec A B) ->
 orthogonal (vec A B) (vec C D) -> a * (x + - x0) + b * (y + - y0) = 0.
intros.
apply vec_normal_calcul with (1 := H) (2 := H0); auto with geo.
Qed.

Lemma orthogonal_equation_cartesienne :
 forall (A B M : PO) (x y : R),
 x = abscisse M ->
 y = ordonnee M ->
 A <> B ->
 orthogonal (vec A B) (vec A M) ->
 exists a : R,
   (exists b : R,
      (exists c : R, a * x + (b * y + c) = 0 /\ ~ (a = 0 /\ b = 0))).
intros A B M x y H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
elim composantes_vecteur with (O := O) (I := I) (J := J) (M := A) (N := B);
 [ intros a H2; elim H2; [ intros b H3; try clear H2; try exact H3 ]
 | auto with geo ].
elim existence_coordonnees with (O := O) (I := I) (J := J) (M := A);
 [ intros x0 H2; elim H2; [ intros y0 H4; try clear H2; try exact H4 ]
 | auto with geo ].
cut
 (vec A M =
  add_PP (mult_PP (x + - x0) (vec O I)) (mult_PP (y + - y0) (vec O J)));
 intros.
2: apply composantes_vecAB; eauto with geo.
exists a; exists b; exists (- (a * x0) + - (b * y0)).
split; [ try assumption | idtac ].
discrimine A M.
cut (x = x0 /\ y = y0); intros.
applatit_and.
rewrite H7; rewrite H8; ring.
rewrite H5 in H4.
apply unicite_composantes_vecteur with (2 := H) (3 := H4); auto with geo.
RReplace (a * x + (b * y + (- (a * x0) + - (b * y0))))
 (a * (x + - x0) + b * (y + - y0)).
apply vec_normal_calcul with (1 := H0) (2 := H5); eauto with geo.
contrapose H0.
applatit_and.
apply vecteur_nul_conf.
rewrite H3.
RReplace b (- - b).
rewrite H6; rewrite H7; Ringvec.
Qed.

Lemma equation_cartesienne_orthogonal :
 forall (M : PO) (x y a b c : R),
 x = abscisse M ->
 y = ordonnee M ->
 ~ (a = 0 /\ b = 0) ->
 a * x + (b * y + c) = 0 ->
 exists A : _, (exists B : _, A <> B /\ orthogonal (vec A B) (vec A M)).
intros M x y a b c H20 H30 H0 H1; try assumption.
cut (vec O M = add_PP (mult_PP x (vec O I)) (mult_PP y (vec O J)));
 [ intros H | auto with geo ].
cut (a <> 0 \/ b <> 0); intros.
elim H2; intros.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := - c / a) (b := 0);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := a + - c / a) (b := b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J))); intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
cut (scalaire (vec A B) (vec A M) = 0); auto with geo.
cut (vec A M = add_PP (mult_PP (x + c / a) (vec O I)) (mult_PP y (vec O J)));
 intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros N H21 ].
elim existence_representant_vecteur with (A := O) (B := A) (C := M);
 [ intros P H22 ].
rewrite <- H21; rewrite <- H22.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=N) (N:=P) (x:=a) (y:=b)
    (x':=x + c / a) (y':=y)); auto with geo.
rewrite <- H1; auto.
unfold Rdiv in |- *.
RReplace (a * (x + c * / a)) (a * x + c * (a * / a)).
RReplace (a * / a) 1.
ring.
rewrite H21; auto.
rewrite H22; auto.
RReplace (x + c / a) (x + - (- c / a)).
RReplace y (y + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
RReplace a (a + - c / a + - (- c / a)).
cut (a + - c / a = - c / a); intros.
rewrite H8.
unfold Rdiv in |- *.
ring.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := a + - c / a)
    (y := b)
    (x' := - c / a)
    (y' := 0);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H9
 | auto with geo
 | auto
 | auto ].
RReplace b (b + -0).
RReplace a (a + - c / a + - (- c / a)).
apply composantes_vecAB; eauto with geo.
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := 0) (b := - c / b);
 [ intros A H4; try clear existence_representant_comb_lin_vecteur;
    try exact H4 ].
elim
 existence_representant_comb_lin_vecteur
  with (A := O) (B := I) (C := O) (D := J) (a := a) (b := b + - c / b);
 [ intros B H6; try clear existence_representant_comb_lin_vecteur;
    try exact H6 ].
exists A; exists B.
cut (vec A B = add_PP (mult_PP a (vec O I)) (mult_PP b (vec O J))); intros.
cut (A <> B); intros.
split; [ try assumption | idtac ].
cut (scalaire (vec A B) (vec A M) = 0); auto with geo.
cut (vec A M = add_PP (mult_PP x (vec O I)) (mult_PP (y + c / b) (vec O J)));
 intros.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 [ intros N H21 ].
elim existence_representant_vecteur with (A := O) (B := A) (C := M);
 [ intros P H22 ].
rewrite <- H21; rewrite <- H22.
rewrite
 (scalaire_coordonnees (O:=O) (I:=I) (J:=J) (M:=N) (N:=P) (x:=a) (y:=b)
    (x':=x) (y':=y + c / b)); auto with geo.
rewrite <- H1; auto.
unfold Rdiv in |- *.
RReplace (b * (y + c * / b)) (b * y + c * (b * / b)).
RReplace (b * / b) 1.
ring.
rewrite H21; auto.
rewrite H22; auto.
RReplace (y + c / b) (y + - (- c / b)).
RReplace x (x + -0).
apply composantes_vecAB; eauto with geo.
unfold Rdiv in |- *.
ring.
contrapose H3.
rewrite H7 in H4.
RReplace b (b + - c / b + - (- c / b)).
cut (b + - c / b = - c / b); intros.
rewrite H8.
unfold Rdiv in |- *.
ring.
elim
 unicite_coordonnees
  with
    (O := O)
    (I := I)
    (J := J)
    (M := B)
    (x := a)
    (y := b + - c / b)
    (x' := 0)
    (y' := - c / b);
 [ intros H9 H10; try clear unicite_coordonnees; try exact H10
 | auto with geo
 | auto
 | auto ].
RReplace a (a + -0).
RReplace b (b + - c / b + - (- c / b)).
apply composantes_vecAB; eauto with geo.
apply not_and_or; auto.
Qed.


Require Import
        target_inf
        Infrastructure
        LibTactics
        Target_Adequacy
        Target_Safety.

(**

Adapted from

https://softwarefoundations.cis.upenn.edu/draft/plf-current/Norm.html

 *)

Close Scope nat_scope.

Definition halts t  :=
  exists t',  value t' /\ t ->* t'.

Lemma value_halts : forall v, value v -> halts v.
Proof.
  introv H.
  unfolds.
  exists~ v.
Qed.

Fixpoint R T t : Prop :=
  nil |= t ~: T /\ halts t /\
  (match T with
   | a_nat => True
   | a_unit => True
   | a_arrow T1 T2 => forall s, R T1 s -> R T2 (trm_app t s)
   | a_prod T1 T2 => R T1 (trm_capp co_proj1 t) /\ R T2 (trm_capp co_proj2 t)
   | a_rcd l T' => R T' (trm_proj t l)
   end).

Lemma R_lc : forall T t,
    R T t -> lc_exp t.
Proof.
  introv H.
  destruct* T;
    unfold R in H; inverts* H.
Qed.

Lemma R_halts : forall T t, R T t -> halts t.
Proof.
  introv H.
  destruct T; unfold R in H; inverts H; inverts H1; assumption.
Qed.

Lemma R_typable_empty : forall T t, R T t -> nil |= t ~: T.
Proof.
  intros. destruct T; unfold R in H; inversion H; inversion H1; assumption.
Qed.

Lemma step_preserves_halting : forall t t', (step t t') -> (halts t <-> halts t').
Proof.
  introv ST.
  unfolds.
  split.

  - Case "->".
    intros [t'' [V STM]].
    inverts STM.
    false.
    apply value_irred in V.
    unfold irred in V.
    specialize (V t').
    apply~ V.

    lets~ : step_unique ST H.
    substs.
    exists~ t''.

  - Case "<-".
    intros [t'0 [STM V]].
    exists~ t'0; splits; eauto.
Qed.

Lemma step_preserves_R : forall T t t', (step t t') -> R T t -> R T t'.
Proof with try apply R_lc; eauto.
  induction T; intros t t' E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt;
    destruct Rt as [typable_empty_t [halts_t RRt]].

  - Case "a_nat".
    splits~.
    sapply preservation...
    forwards * : step_preserves_halting E.

  - Case "a_unit".
    splits~.
    sapply preservation...
    forwards * : step_preserves_halting E.

  - Case "a_arrow".
    splits~.
    sapply preservation...
    forwards * : step_preserves_halting E.
    intros.
    eapply IHT2.
    apply step_app1...
    sapply R_lc...
    apply RRt...

  - Case "a_prod".
    destruct RRt.
    splits~.
    sapply preservation...
    forwards * : step_preserves_halting E.
    eapply IHT1...
    eapply IHT2...

  - Case "a_rcd".
    splits~.
    sapply preservation...
    forwards * : step_preserves_halting E.
    eapply IHT...
Qed.

Lemma multistep_preserves_R : forall T t t',
  (t ->* t') -> R T t -> R T t'.
Proof.
  intros T t t' STM; induction STM; intros.
  assumption.
  apply IHSTM. eapply step_preserves_R. apply H. assumption.
Qed.

Lemma step_preserves_R' : forall T t t',
  nil |= t ~: T -> (step t t') -> R T t' -> R T t.
Proof with try apply R_lc; eauto.
  induction T; intros t t' Typ E Rt; unfold R; fold R; unfold R in Rt; fold R in Rt; destruct Rt as [typable_empty_t [halts_t RRt]].

  - Case "a_nat".
    splits~.
    forwards * : step_preserves_halting E.

  - Case "a_unit".
    splits~.
    forwards * : step_preserves_halting E.

  - Case "a_arrow".
    splits~.
    forwards * : step_preserves_halting E.
    intros.
    lets : R_typable_empty H.
    eapply IHT2...

  - Case "a_prod".
    destruct RRt.
    splits~.
    forwards * : step_preserves_halting E.
    eapply IHT1...
    eapply IHT2...

  - Case "a_rcd".
    splits~.
    forwards * : step_preserves_halting E.
    eapply IHT...
Qed.

Lemma multistep_preserves_R' : forall T t t',
  nil |= t ~: T -> (t ->* t') -> R T t' -> R T t.
Proof.
  intros T t t' HT STM.
  induction STM; intros.
  assumption.
  eapply step_preserves_R'. assumption. apply H. apply IHSTM.
  eapply preservation; eauto. auto.
Qed.

Fixpoint msubst (ss:env) (t:exp) {struct ss} : exp :=
  match ss with
  | nil => t
  | ((x,s)::ss') => msubst ss' ([x ~> s]t)
  end.

Inductive instantiation : ctx -> env -> Prop :=
| V_nil :
    instantiation nil nil
| V_cons : forall x T v Γ γ,
    x # Γ -> x # γ ->
    value v -> R T v ->
    instantiation Γ γ ->
    instantiation ((x,T)::Γ) ((x,v)::γ).

Definition vacuous_substitution := subst_exp_fresh_eq.

Definition closed (t:exp) :=
  forall x,  x `notin` fv_exp t.

Lemma subst_closed: forall t,
    closed t ->
    forall x t', [x ~> t']t = t.
Proof.
  intros.
  apply vacuous_substitution.
  apply H.
Qed.

Lemma msubst_closed: forall t, closed t -> forall ss, msubst ss t = t.
Proof.
  induction ss.
    reflexivity.
    destruct a. simpl. rewrite subst_closed; assumption.
Qed.

Fixpoint closed_env (env:env) {struct env} :=
  match env with
  | nil => True
  | (x,t)::env' => lc_exp t /\ closed t /\ closed_env env'
  end.

Lemma msubst_var: forall ss x, closed_env ss ->
   msubst ss (trm_var_f x) =
   match get x ss with
   | Some t => t
   | None => trm_var_f x
  end.
Proof.
  induction ss; intros.
    reflexivity.
    destruct a.
     simpl. repeat case_if.
      apply msubst_closed. inverts H as (? & ?); auto.
      apply IHss. inverts H as (? & ?); auto.
Qed.

Lemma msubst_abs: forall ss t,
    msubst ss (trm_abs t) =
    trm_abs (msubst ss t).
Proof.
  induction ss; intros.
  simpl.
  reflexivity.
  destruct a.
  simpl.
  rewrite~ IHss.
Qed.

Lemma msubst_app : forall ss t1 t2,
    msubst ss (trm_app t1 t2) = trm_app (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

Lemma msubst_pair : forall ss t1 t2,
    msubst ss (trm_pair t1 t2) = trm_pair (msubst ss t1) (msubst ss t2).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

Lemma msubst_rcd : forall ss l t,
    msubst ss (trm_rcd l t) = trm_rcd l (msubst ss t).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

Lemma msubst_proj : forall ss l t,
    msubst ss (trm_proj t l) = trm_proj (msubst ss t) l.
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

Lemma msubst_capp : forall ss c t,
    msubst ss (trm_capp c t) = trm_capp c (msubst ss t).
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite <- IHss. auto.
Qed.

Lemma msubst_unit : forall ss,
    msubst ss trm_unit = trm_unit.
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite IHss. auto.
Qed.

Lemma msubst_lit : forall ss i,
    msubst ss (trm_lit i) = trm_lit i.
Proof.
 induction ss; intros.
   reflexivity.
   destruct a.
    simpl. rewrite IHss. auto.
Qed.

Lemma instantiation_domains_match: forall {Γ} {γ},
    instantiation Γ γ ->
    forall {x} {T},
      binds x T Γ -> exists t, binds x t γ.
Proof.
  intros Γ γ V. induction V; intros x0 T0 C.
  inverts C.
  analyze_binds C.
  exists~ v.
  lets (v' & ?): IHV BindsTac.
  exists~ v'.
Qed.

Corollary typable_empty_closed : forall t T,
    nil |= t ~: T ->
    closed t.
Proof.
  intros. unfold closed. intros x H1.
  lets : value_no_fv H.
  solve_uniq.
Qed.

Lemma instantiation_env_closed : forall Γ γ,
  instantiation Γ γ -> closed_env γ.
Proof.
  intros Γ γ V; induction V; intros.
    econstructor.
    unfold closed_env. fold closed_env.
    splits~. eapply typable_empty_closed. eapply R_typable_empty. eauto.
Qed.

Lemma instantiation_R : forall Γ γ,
    instantiation Γ γ ->
    forall x t T,
      binds x T Γ ->
      binds x t γ ->
      R T t.
Proof.
  intros Γ γ V. induction V; intros x' t' T' G E.
  inverts G.
  analyze_binds G.
  analyze_binds E.
  lets* : binds_dom_contradiction BindsTac H0.
  analyze_binds  E.
  lets* : binds_dom_contradiction BindsTac H.

  forwards * : IHV BindsTac BindsTac0.

Qed.

Lemma msubst_preserves_typing : forall Γ γ,
    instantiation Γ γ ->
    forall t S, Γ |= t ~: S ->
           nil |= (msubst γ t) ~: S.
Proof.
  introv Ins.
  induction~ Ins; intros.
  simpls.
  apply IHIns.
  rewrite_env (nil ++ Γ).
  eapply typing_subst; simpl_env in *; eauto.
  lets : R_typable_empty H2.
  rewrite_env (Γ ++ nil).
  apply typing_weakening; eauto.
  lets (? & ?) : typing_regular H3.
  solve_uniq.
Qed.

Lemma uniq_gamma : forall Γ γ,
    instantiation Γ γ ->
    uniq Γ ->
    uniq γ.
Proof.
  introv H.
  induction~ H; introv Uniq.
  solve_uniq.
Qed.

Lemma binds_get : forall (A : Type) x (t : A) (T : list (atom * A)),
    uniq T -> binds x t T -> get x T = Some t.
Proof.
  intros A x t T.
  gen x t.
  induction T; introv H Bind.
  invert Bind.
  destruct a as (x0, t0).
  simpls.
  apply binds_cons_uniq_1 in Bind; auto.
  destruct Bind.
  destructs H0; substs.
  case_if~.
  destruct H0.
  case_if.
  apply~ IHT.
  solve_uniq.
Qed.

Lemma msubst_subst_open : forall g t a,
    closed_env g ->
    closed a ->
    msubst g (t ^^ a) = (msubst g t) ^^ a.
Proof.
  intro g.
  induction g; intros; autos.
  destruct a as [x T].
  simpls.
  inverts H as (? & ?).
  rewrite~ <- IHg.
  rewrite~ subst_exp_open_exp_wrt_exp.
  rewrite subst_exp_fresh_eq with (e2 := a0); auto.
Qed.

Lemma msubst_open : forall x v γ t,
    closed_env ((x ~ v) ++ γ) ->
    x \notin fv_exp t ->
    msubst ((x ~ v) ++ γ) (t ^ x) = (msubst γ t) ^^ v.
Proof.
  intros.
  inverts H as (? & ?).
  simpl.
  rewrite* <- msubst_subst_open.
  rewrite* <- subst_exp_intro.

Qed.

Lemma R_capp : forall c t T1 T2,
    c |= T1 ~> T2 ->
    R T1 t ->
    R T2 (trm_capp c t).
Proof with auto.
  introv H.
  gen t.
  induction H; intros.

  - Case "co_id".
    lets WT : R_typable_empty H.
    lets VA : R_halts H.
    destruct VA as (v & ? & Red).
    apply multistep_preserves_R with (t' := v) in H...
    apply multistep_preserves_R' with v; auto_star.
    apply star_trans with (trm_capp co_id v)...
    apply~ multi_red_capp.

  - Case "co_trans".
    lets : IHcotyp2 H1.
    lets : IHcotyp1 H2.
    lets WT : R_typable_empty H1.
    lets VA : R_halts H1.
    destruct VA as (v & ? & Red).
    apply multistep_preserves_R' with (trm_capp c1 (trm_capp c2 v)); auto_star.
    apply star_trans with (trm_capp (co_trans c1 c2) v)...
    apply~ multi_red_capp.
    apply multistep_preserves_R with (t' := trm_capp c1 (trm_capp c2 v)) in H3...
    apply~ multi_red_capp.
    apply~ multi_red_capp.

  - Case "co_top".
    lets WT : R_typable_empty H.
    lets VA : R_halts H.
    destruct VA as (v & ? & Red).
    apply multistep_preserves_R' with (trm_unit); auto_star.
    apply star_trans with (trm_capp co_top v)...
    apply~ multi_red_capp.
    splits~.
    apply~ value_halts.

  - Case "co_topArr".
    lets WT : R_typable_empty H.
    lets (v & ? & Red) : R_halts H.
    lets : preservation_multi_step WT Red.
    lets~ : unit_canonical H1.
    substs.

    unfold R.
    splits*.
    unfolds.
    exists (trm_capp co_topArr trm_unit).
    splits~.
    apply~ multi_red_capp.

    intros.
    splits*.
    destructs H2.
    destruct H3 as (v' & ? & ?).
    lets : preservation_multi_step H2 H5.
    lets~ : unit_canonical H6.
    substs.
    unfolds.
    exists trm_unit.
    splits~.
    apply star_trans with (trm_app (trm_capp co_topArr trm_unit) trm_unit); auto.
    apply star_trans with (trm_app (trm_capp co_topArr trm_unit) s); auto.
    apply~ multi_red_app2.
    apply~ multi_red_capp.
    apply~ multi_red_app.

  - Case "co_arr".
    lets : R_typable_empty H1.
    destructs H1.
    destruct H3 as (v & ? & ?).

    unfold R.
    fold R.
    splits*.
    unfolds.
    exists (trm_capp (co_arr c1 c2) v).
    splits~.
    apply~ multi_red_capp.
    introv W.
    lets : R_typable_empty W.
    lets (v' & ? & ?): R_halts W.
    apply IHcotyp1 in W.
    apply H4 in W.
    apply IHcotyp2 in W.

    apply multistep_preserves_R with (t' := trm_capp c2 (trm_app v (trm_capp c1 s))) in W.
    apply multistep_preserves_R with (t' := trm_capp c2 (trm_app v (trm_capp c1 v'))) in W.

    apply multistep_preserves_R' with (t' := trm_capp c2 (trm_app v (trm_capp c1 v'))); auto_star.

    apply star_trans with (trm_app (trm_capp (co_arr c1 c2) v) s).
    apply~ multi_red_app2.
    apply~ multi_red_capp.
    apply star_trans with (trm_app (trm_capp (co_arr c1 c2) v) v').
    apply~ multi_red_app.
    apply~ star_one.

    apply~ multi_red_capp.
    apply~ multi_red_app.
    apply~ multi_red_capp.

    apply~ multi_red_capp.
    apply~ multi_red_app2.

  - Case "co_pair".
    lets : R_typable_empty H1.
    lets : R_halts H1.
    destruct H3 as (v & ? & ?).
    apply multistep_preserves_R with (t' := v) in H1; auto.
    lets WT1 : IHcotyp1 H1.
    lets WT2 : IHcotyp2 H1.
    lets VA : R_halts WT1.
    lets VB : R_halts WT2.
    destruct VA as (v1 & ? & ?).
    destruct VB as (v2 & ? & ?).
    apply multistep_preserves_R with (t' := v1) in WT1; auto.
    apply multistep_preserves_R with (t' := v2) in WT2; auto.
    lets : R_typable_empty WT1.
    lets : R_typable_empty WT2.

    unfold R.
    fold R.
    splits*.
    unfolds.
    exists (trm_pair v1 v2).
    splits~.
    apply star_trans with (trm_capp (co_pair c1 c2) v).
    apply~ multi_red_capp.
    apply star_trans with (trm_pair (trm_capp c1 v) (trm_capp c2 v)).
    apply~ star_one.
    apply~ multi_red_pair.

    apply multistep_preserves_R' with (t' := trm_capp co_proj1 (trm_pair v1 v2)); auto_star.
    apply~ multi_red_capp.
    apply star_trans with (trm_capp (co_pair c1 c2) v).
    apply~ multi_red_capp.
    apply star_trans with (trm_pair (trm_capp c1 v) (trm_capp c2 v)).
    apply~ star_one.
    apply~ multi_red_pair.
    apply multistep_preserves_R' with (v1); auto_star.

    apply multistep_preserves_R' with (t' := trm_capp co_proj2 (trm_pair v1 v2)); auto_star.
    apply~ multi_red_capp.
    apply star_trans with (trm_capp (co_pair c1 c2) v).
    apply~ multi_red_capp.
    apply star_trans with (trm_pair (trm_capp c1 v) (trm_capp c2 v)).
    apply~ star_one.
    apply~ multi_red_pair.
    apply multistep_preserves_R' with (v2); auto_star.

  - Case "co_distArr".

    lets : R_typable_empty H.
    lets (v & ? & ?) : R_halts H.
    lets : preservation_multi_step H0 H2.
    lets~ (v1 & v2 & ? & ? & ?): prod_canonical H3.
    substs.
    inverts H3.
    inverts H1.

    unfold R in *.
    fold R in *.
    destructs H.
    destructs H3.

    splits*.
    unfolds.
    exists (trm_capp co_distArr (trm_pair v1 v2)).
    splits*.
    apply~ multi_red_capp.
    introv W.
    lets : R_typable_empty W.
    lets (v' & ? & ?): R_halts W.
    apply multistep_preserves_R with (t' := v') in W; auto.
    lets WT1 : H14 W.
    lets WT2 : H11 W.
    apply multistep_preserves_R with (t' := trm_app v1 v') in WT1; auto.
    apply multistep_preserves_R with (t' := trm_app v2 v') in WT2; auto.
    lets (vv1 & ? & ?) : R_halts WT1.
    lets (vv2 & ? & ?) : R_halts WT2.
    apply multistep_preserves_R with (t' := vv1) in WT1; auto.
    apply multistep_preserves_R with (t' := vv2) in WT2; auto.

    assert ( trm_app (trm_capp co_distArr t) s ->* trm_pair vv1 vv2).
    {

    apply star_trans with (trm_app (trm_capp co_distArr (trm_pair v1 v2)) s).
    apply~ multi_red_app2.
    apply~ multi_red_capp.
    apply star_trans with (trm_app (trm_capp co_distArr (trm_pair v1 v2)) v').
    apply~ multi_red_app.
    apply star_trans with (trm_pair (trm_app v1 v') (trm_app v2 v')); auto.
    apply~ multi_red_pair.

    }

    splits*.
    unfolds.

    exists (trm_pair vv1 vv2).
    splits~.

    apply multistep_preserves_R' with (t' := vv1); auto_star.
    apply star_trans with (trm_capp co_proj1 (trm_pair vv1 vv2)); auto.
    apply~ multi_red_capp.

    apply multistep_preserves_R' with (t' := vv2); auto_star.
    apply star_trans with (trm_capp co_proj2 (trm_pair vv1 vv2)); auto.
    apply~ multi_red_capp.

    apply star_trans with (trm_app (trm_capp co_proj2 (trm_pair v1 v2)) v'); auto.
    apply~ multi_red_app2.
    apply~ multi_red_capp.

    apply star_trans with (trm_app (trm_capp co_proj1 (trm_pair v1 v2)) v'); auto.
    apply~ multi_red_app2.
    apply~ multi_red_capp.

  - Case "co_proj1".
    unfold R in H.
    fold R in H.
    destructs~ H.

  - Case "co_proj2".
    unfold R in H.
    fold R in H.
    destructs~ H.

  - Case "co_rcd".
    unfold R in H0.
    fold R in H0.
    destructs H0.
    unfolds in H1.
    destruct H1 as (v & ? & ?).
    lets : preservation_multi_step H0 H3.
    lets* : rcd_canonical H4.
    destruct H5 as (v' & ?).
    substs.
    inverts H4.
    inverts H1.
    apply multistep_preserves_R with (t' := trm_proj (trm_rcd l v') l)in H2.
    apply multistep_preserves_R with (t' := v')in H2; auto_star.
    lets : IHcotyp H2.
    lets : R_halts H1.
    unfolds in H4.
    destruct H4 as (v'' & ? & ?).
    apply multistep_preserves_R with (t' := v'')in H1; auto_star.

    unfold R.
    fold R.
    splits*.
    unfolds.
    exists (trm_rcd l v'').
    splits*.
    apply star_trans with (b := trm_capp (co_rcd l c) (trm_rcd l v')).
    apply~ multi_red_capp.
    apply star_trans with (b := (trm_rcd l (trm_capp c v'))); auto_star.
    apply~ multi_red_rcd.

    apply multistep_preserves_R' with (t' := v''); auto_star.
    apply star_trans with (b := trm_proj (trm_rcd l v'') l); auto_star.
    apply~ multi_red_proj.
    apply star_trans with (b := trm_capp (co_rcd l c) (trm_rcd l v')).
    apply~ multi_red_capp.
    apply star_trans with (b := (trm_rcd l (trm_capp c v'))); auto_star.
    apply~ multi_red_rcd.

    apply~ multi_red_proj.

  - Case "co_topRcd".
    lets : R_typable_empty H.
    lets : R_halts H.
    unfold halts in *.
    destruct H1 as (v & ? & ?).
    lets : preservation_multi_step H0 H2.
    lets~ : unit_canonical H3.
    substs.
    splits*.
    exists (trm_rcd l trm_unit).
    splits~.
    apply star_trans with (b := trm_capp (co_topRcd l) trm_unit); auto_star.
    apply~ multi_red_capp.

    unfold halts in *.
    exists trm_unit.
    splits~.
    apply star_trans with (b := trm_proj (trm_capp (co_topRcd l) trm_unit) l); auto_star.
    apply~ multi_red_proj.
    apply~ multi_red_capp.

  - Case "co_distRcd".
    lets : R_typable_empty H.
    lets : R_halts H.
    unfold halts in *.
    destruct H1 as (v & ? & ?).
    lets : preservation_multi_step  H0 H2.
    lets* (v1 & v2 & ? & ? & ?) : prod_canonical H3.
    substs.
    inverts H3.
    lets~ (v1' & ?): rcd_canonical H10.
    lets~ (v2' & ?): rcd_canonical H12.
    substs.
    inverts H10.
    inverts H12.
    inverts H5.
    inverts H4.

    unfold R in *.
    fold R in *.
    destructs H.
    destructs H4.

    apply multistep_preserves_R with (t' := v1') in H13; auto_star.
    apply multistep_preserves_R with (t' := v2') in H11; auto_star.

    splits*.

    unfolds.
    exists (trm_rcd l (trm_pair v1' v2')).
    splits~.
    apply star_trans with (b := trm_capp (co_distRcd l) (trm_pair (trm_rcd l v1') (trm_rcd l v2'))); auto.
    apply~ multi_red_capp.
    unfolds.
    exists (trm_pair v1' v2').
    splits~.
    apply star_trans with (b := trm_proj (trm_capp (co_distRcd l) (trm_pair (trm_rcd l v1') (trm_rcd l v2'))) l); auto.
    apply~ multi_red_proj.
    apply~ multi_red_capp.
    apply star_trans with (b := trm_proj (trm_rcd l (trm_pair v1' v2')) l); auto.

    apply multistep_preserves_R' with (t' := v1'); auto_star.
    apply star_trans with (b := trm_capp co_proj1 (trm_pair v1' v2')); auto_star.
    apply~ multi_red_capp.
    apply star_trans with (b := trm_proj (trm_rcd l (trm_pair v1' v2')) l); auto.
    apply~ multi_red_proj.
    apply star_trans with (b := trm_capp (co_distRcd l) (trm_pair (trm_rcd l v1') (trm_rcd l v2'))); auto.
    apply~ multi_red_capp.

    apply multistep_preserves_R' with (t' := v2'); auto_star.
    apply star_trans with (b := trm_capp co_proj2 (trm_pair v1' v2')); auto_star.
    apply~ multi_red_capp.
    apply star_trans with (b := trm_proj (trm_rcd l (trm_pair v1' v2')) l); auto.
    apply~ multi_red_proj.
    apply star_trans with (b := trm_capp (co_distRcd l) (trm_pair (trm_rcd l v1') (trm_rcd l v2'))); auto.
    apply~ multi_red_capp.

    apply star_trans with (b := trm_proj (trm_capp co_proj2 (trm_pair (trm_rcd l v1') (trm_rcd l v2'))) l); auto.
    apply~ multi_red_proj.
    apply~ multi_red_capp.
    apply star_trans with (b := trm_proj (trm_rcd l v2') l); auto.

    apply star_trans with (b := trm_proj (trm_capp co_proj1 (trm_pair (trm_rcd l v1') (trm_rcd l v2'))) l); auto.
    apply~ multi_red_proj.
    apply~ multi_red_capp.
    apply star_trans with (b := trm_proj (trm_rcd l v1') l); auto.

Qed.

Lemma msubst_R : forall Γ γ t T,
    Γ |= t ~: T ->
    instantiation Γ γ ->
    R T (msubst γ t).
Proof.
  introv Typ.
  gen γ.
  induction Typ; intros.

  - Case "trm_unit".
    rewrite msubst_unit.
    splits~.
    apply~ value_halts.

  - Case "trm_lit".
    rewrite msubst_lit.
    splits~.
    apply~ value_halts.

  - Case "trm_var".
    destruct (instantiation_domains_match H1 H0) as [t P].
    eapply instantiation_R; eauto.
    rewrite msubst_var.
    lets : binds_get P.
    sapply uniq_gamma; eauto.
    rewrite H2. auto. eapply instantiation_env_closed; eauto.

  - Case "trm_arrow".
    rewrite msubst_abs.
    assert (WT : nil |= trm_abs (msubst γ e) ~: a_arrow T1 T2).
    {
      assert (G |= trm_abs e ~: a_arrow T1 T2).
      auto_star.
      lets : msubst_preserves_typing H1 H2.
      rewrite~ msubst_abs in H3.
    }

    unfold R. fold R. splits~.
    apply~ value_halts.

    intros.
    destruct (R_halts _ _ H2) as [v [Q P]].
    pose proof (multistep_preserves_R _ _ _ P H2).
    pick fresh x.
    assert (Ins : instantiation ((x ~ T1) ++ G) ((x ~ v) ++ γ)).
    sapply~ V_cons.
    lets* : H0 x ((x ~ v) ++ γ) Ins.
    rewrite~ msubst_open in H4.

    apply multistep_preserves_R' with (msubst γ e ^^ v).
    lets* : R_typable_empty H2.
    apply star_trans with (b := trm_app (trm_abs (msubst γ e)) v).
    apply~ multi_red_app.
    apply~ star_step.
    auto.
    simpls.
    splits~.
    unfold closed.
    lets : R_typable_empty H3.
    lets : value_no_fv H5.
    intros.
    rewrite H6.
    solve_notin.
    sapply instantiation_env_closed; eauto.

  - Case "trm_app".
    rewrite msubst_app.
    forwards* P1 : IHTyp1.
    forwards* P2 : IHTyp2.
    apply P1 in P2; auto.

  - Case "trm_prod".
    rewrite msubst_pair.
    forwards* P1 : IHTyp1.
    forwards* P2 : IHTyp2.
    unfold R.
    fold R.
    lets : R_typable_empty P1.
    lets : R_typable_empty P2.
    lets : R_halts P1.
    lets : R_halts P2.
    unfold halts in *.
    destruct H2 as (v1 & ? & ?).
    destruct H3 as (v2 & ? & ?).
    lets : preservation_multi_step  H0 H4.
    lets : preservation_multi_step  H1 H5.

    splits~.
    exists~ (trm_pair v1 v2).
    splits~.
    apply~ multi_red_pair.

    apply multistep_preserves_R' with (trm_capp co_proj1 (trm_pair v1 v2)).
    auto_star.
    apply~ multi_red_capp.
    apply~ multi_red_pair.
    apply multistep_preserves_R' with v1.
    auto_star.
    apply~ star_one.
    apply multistep_preserves_R with (msubst γ e1); auto.

    apply multistep_preserves_R' with (trm_capp co_proj2 (trm_pair v1 v2)).
    auto_star.
    apply~ multi_red_capp.
    apply~ multi_red_pair.
    apply multistep_preserves_R' with v2.
    auto_star.
    apply~ star_one.
    apply multistep_preserves_R with (msubst γ e2); auto.

  - Case "trm_capp".
    rewrite msubst_capp.
    lets : IHTyp H0.
    eapply R_capp; eauto.

  - Case "trm_rcd".
    lets : IHTyp H.
    lets : R_typable_empty H0.
    lets : R_halts H0.
    unfold halts in *.
    destruct H2 as (v & ? & ?).
    lets : preservation_multi_step  H1 H3.

    rewrite msubst_rcd.
    unfold R.
    fold R.
    splits~.

    exists (trm_rcd l v).
    splits~.
    apply~ multi_red_rcd.

    apply multistep_preserves_R' with (trm_proj (trm_rcd l v) l).
    auto_star.
    apply~ multi_red_proj.
    apply~ multi_red_rcd.
    apply multistep_preserves_R' with v.
    auto_star.
    apply~ star_one.
    apply multistep_preserves_R with (msubst γ e); auto.

  - Case "trm_proj".
    rewrite msubst_proj.
    lets Imp : IHTyp H.
    lets : R_typable_empty Imp.
    lets : R_halts Imp.
    unfold halts in *.
    destruct H1 as (v & ? & ?).
    lets : preservation_multi_step  H0 H2.
    lets* : rcd_canonical H3.
    destruct H4 as (v' & ?).
    substs.
    inverts H3.
    inverts H1.
    destruct Imp as (? & ? & Imp).

    apply multistep_preserves_R with (t' := trm_proj (trm_rcd l v') l) in Imp.
    apply multistep_preserves_R with (t' := v') in Imp; auto_star.

    apply multistep_preserves_R' with (trm_proj (trm_rcd l v') l); auto_star.
    apply~ multi_red_proj.
    apply multistep_preserves_R' with v'; auto_star.
    apply~ multi_red_proj.

Qed.

Theorem normalization : forall t T,
    nil |= t ~: T ->
    halts t.
Proof.
  intros.
  replace t with (msubst nil t) by reflexivity.
  apply (@R_halts T).
  apply (msubst_R nil); eauto.
  eapply V_nil.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e444m17_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e389m21_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m481_24limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Initial.
Require Import Category.Instance.Coq.
Require Import Coq.Sets.Ensembles.

Generalizable All Variables.

(* The category of heterogenous relations on Coq objects. *)

Program Definition Rel : Category := {|
  (* i.e. each object is an element of [Type] *)
  obj     := @obj Coq;
  (* each morphism (from [A : Type] to [B : Type]) is of type
     [A → B → Prop]. So a heterogenous relation. *)
  hom     := fun A B => A ~> Ensemble B;
  (* morphisms are equal, if they are (provably) equivalent *)
  homset  := fun P Q =>
               {| equiv := fun f g => ∀ x y, f x y ↔ g x y |};
  (* the identity morphism is (equivalent to) the relation
     [fun x y => x = y] *)
  id      := Singleton;
  compose := fun x y z f g a b =>
               (exists e : y, In y (g a) e ∧ In z (f e) b)%type
|}.
Next Obligation.
  equivalence.
  - apply X; assumption.
  - apply X; assumption.
  - apply X0, X; assumption.
  - apply X, X0; assumption.
Qed.
Next Obligation.
  proper;
  destruct H as [w [H1 H2]];
  exists w; firstorder.
Qed.
Next Obligation.
  split; intros.
  - destruct H as [? [? H2]].
    destruct H2; assumption.
  - exists y0.
    intuition.
Qed.
Next Obligation.
  split; intros.
  - destruct H as [? [H1 ?]].
    destruct H1; assumption.
  - exists x0.
    intuition.
Qed.
Next Obligation. firstorder. Qed.
Next Obligation. firstorder. Qed.

#[export]
Program Instance Rel_Initial : @Initial Rel := {
  terminal_obj := False;
  one := fun _ _ => False_rect _ _
}.
Next Obligation. contradiction. Qed.

(*
Program Instance Rel_Cartesian : @Cartesian Rel := {
  product_obj := @Prod Coq _;
  fork := fun _ _ _ f g x y => f x (fst y) ∧ g x (snd y);
  exl  := fun _ _ p x => In _ (Singleton _ (fst p)) x;
  exr  := fun _ _ p x => In _ (Singleton _ (snd p)) x
}.
Next Obligation.
  proper.
  split; intros.
    destruct H.
    split; intros.
      apply X0; assumption.
    apply X1; assumption.
  destruct H.
  split; intros.
    apply X0; assumption.
  apply X1; assumption.
Qed.
Next Obligation.
  firstorder.
  - destruct H1.
    apply H, H0.
  - eexists (y, _).
    split.
      apply H; simpl.
      split.
        assumption.
      apply H.
Qed.

Program Instance Rel_Cocartesian : @Cocartesian Rel := {
  product_obj := or;
  fork := fun _ _ _ f g x =>
            match x with
            | or_introl v => f v
            | or_intror v => g v
            end;
  exl  := fun _ _ p => or_introl p;
  exr  := fun _ _ p => or_intror p
}.
Obligation 1. proper; autounfold in *; apply proof_irrelevance. Qed.
Obligation 2.
  autounfold in *.
  split; intros.
    split; intros;
    apply proof_irrelevance.
  apply proof_irrelevance.
Qed.

Program Instance Rel_Closed : @Closed Rel _ := {
  exponent_obj := Basics.impl;
  exp_iso := fun _ _ _ =>
    {| to   := {| morphism := fun f a b => f (conj a b) |}
     ; from := {| morphism := fun f p => f (proj1 p) (proj2 p) |} |}
}.
Next Obligation. proper; autounfold in *; apply proof_irrelevance. Qed.
Next Obligation. proper; autounfold in *; apply proof_irrelevance. Qed.
Next Obligation. autounfold in *; apply proof_irrelevance. Qed.
Next Obligation. autounfold in *; apply proof_irrelevance. Qed.
Next Obligation. autounfold in *; apply proof_irrelevance. Qed.
*)

Definition some_number : nat ~{Rel}~> nat := fun x y => (x < y)%nat.

#[export]
Program Instance Relation_Functor : Coq ⟶ Rel := {
  fobj := fun x => x;
  fmap := fun x y (f : x ~{Coq}~> y) x y => In _ (Singleton _ (f x)) y
}.
Next Obligation. proper; congruence. Qed.
Next Obligation.
  simplify; firstorder.
  destruct a, b; constructor.
Qed.


(**PIP STATE *)
Require Import List Bool Arith Omega Lib.
Import List.ListNotations.

Axiom tableSize nbLevel nbPage: nat.
Axiom nbLevelNotZero: nbLevel > 0.
Axiom nbPageNotZero: nbPage > 0.
Axiom tableSizeIsEven : Nat.Even tableSize.
Definition tableSizeLowerBound := 14.
Axiom tableSizeBigEnough : tableSize > tableSizeLowerBound.

Record index := {
  i :> nat ;
  Hi : i < tableSize }.

Record page := {
  p :> nat;
  Hp : p < nbPage }.

Definition paddr := (page * index)%type.

Record vaddr := {
  va :> list index ;
  Hva : length va = nbLevel + 1}.

Record level := {
  l :> nat ;
  Hl : l < nbLevel }.

Record count := {
  c :> nat ;
  Hnb : c <= (3*nbLevel) + 1  ;
 }.

Parameter index_d : index.
Parameter page_d : page.
Parameter level_d : level.

Require Import Coq.Program.Tactics.

Program Definition CIndex  (p : nat) : index :=
if (lt_dec p tableSize) then
Build_index p _ else index_d.

Program Definition CPage (p : nat) : page :=
if (lt_dec p nbPage) then Build_page p _ else  page_d.

Program Definition CVaddr (l: list index) : vaddr :=
if ( Nat.eq_dec (length l)  (nbLevel+1))
  then Build_vaddr l _
  else Build_vaddr (repeat (CIndex 0) (nbLevel+1)) _.

Program Definition CLevel ( a :nat) : level :=
if lt_dec a nbLevel then  Build_level a _
else level_d .

(* BEGIN NOT SIMULATION *)

Next Obligation.
apply repeat_length.
Qed.

(* END NOT SIMULATION *)

Record Pentry : Type:=
{read :bool;
 write : bool ;
 exec : bool;
 present : bool;
 user    : bool;
 pa      : page
}.

Record Ventry : Type:=
{
 pd : bool;
 vad : vaddr
}.

Inductive value : Type:=
|PE : Pentry -> value
|VE : Ventry -> value
|PP : page -> value
|VA : vaddr -> value
|I  : index -> value.

Record state : Type := {
 currentPartition : page;
 memory : list (paddr * value)
}.

Definition multiplexer := CPage 1.

(** Fix virtual addresses positions into the partition descriptor
    of the partition (+1 to get the physical page position) *)
Definition PRidx := CIndex 0.   (* descriptor *)
Definition PDidx := CIndex 2.   (* page directory *)
Definition sh1idx := CIndex 4.  (* shadow1 *)
Definition sh2idx := CIndex 6.  (* shadow2 *)
Definition sh3idx := CIndex 8.  (* configuration pages list*)
Definition PPRidx := CIndex 10. (* parent (virtual address is null) *)

Definition beqIndex (a b : index) : bool := a =? b.
Definition beqPage (a b : page) : bool := a =? b.
Definition beqVAddr (a b : vaddr) : bool := eqList a b beqIndex.

(** default values *)
Definition defaultIndex := CIndex 0.
Definition defaultVAddr := CVaddr (repeat (CIndex 0) nbLevel).
Definition defaultPage := CPage 0.

(** Define first level number *)
Definition fstLevel :=  CLevel 0.

(** Define the entry position of the kernel mapping into the first indirection
    of partitions *)
Definition Kidx := CIndex 1.