Require Export Reals.
Require Export Fourier.
Require Export Nsatz.
Require Export ProjectiveGeometry.Dev.projective_plane_axioms.
Require Export ProjectiveGeometry.Dev.field_variable_isolation_tactics.

Section s_HomogeneousModel.

Open Scope R_scope.

Lemma R_eq_dec: forall r1 r2 : R, {r1 <> r2} + {r1 = r2}.
Proof.
intros.
elim (Req_EM_T r1 r2);intuition.
Qed.

Lemma zero_neq_minus_one : 0 <> -(1).
Proof.
auto with real.
Qed.

Hint Resolve zero_neq_minus_one : field_hints.

Lemma one_not_two : 1 <> 2.
Proof.
discrR.
Qed.

Hint Resolve one_not_two : field_hints.

(** To show that our axiom system is consistent we build a model. **)
(** Homogenous coordinates models. **)

Inductive IndPoint : Set :=
 | P2 : R -> R -> IndPoint (* (x1,x2,1) *)
 | P1 : R -> IndPoint (* (x1,1,0) *)
 | P0 : IndPoint. (* (1,0,0) *)

Inductive IndLine : Set :=
 | L2 : R -> R -> IndLine (* (x1,x2,1) *)
 | L1 : R -> IndLine (* (x1,1,0) *)
 | L0 : IndLine. (* (1,0,0) *)

Definition Point : Set := IndPoint.
Definition Line : Set := IndLine.

Definition triple_of_point  P :=
 match P with
  P2 a b => (a,b,1)
| P1 a    => (a,1,0)
| P0       => (1,0,0)
end.

Definition triple_of_line  L :=
 match L with
  L2 a b => (a,b,1)
| L1 a    => (a,1,0)
| L0       => (1,0,0)
end.

Definition point_of_triple t :=
 match t with (a,b,c) =>
  if (R_eq_dec c 0) then P2 (a/c) (b/c) else
  (if (R_eq_dec b 0) then P1 (a/b) else
  P0)
end.

Definition line_of_triple t :=
 match t with (a,b,c) =>
  if (R_eq_dec c 0) then L2 (a/c) (b/c) else
  (if (R_eq_dec b 0) then L1 (a/b) else
  L0)
end.

Lemma triple_point : forall P : Point, point_of_triple (triple_of_point P) = P.
Proof.
intros.
unfold point_of_triple, triple_of_point.
assert (1<>0).
auto with real.
elim P;intros.
elim (R_eq_dec 1 0);intros.
replace (r/ 1) with r.
replace (r0/ 1) with r0.
auto.
field.
field.
intuition.
elim (R_eq_dec 0 0);intro;intuition.
elim (R_eq_dec 1 0);intro;intuition.
replace (r/ 1) with r.
auto.
field.
elim (R_eq_dec 0 0);intro;intuition.
Qed.

Lemma point_triple : forall a b c : R, (a,b,c) <> (0,0,0) ->
exists l, l <> 0 /\ triple_of_point (point_of_triple (a,b,c)) = (a*l,b*l,c*l).
Proof.
intros.
unfold point_of_triple, triple_of_point.
elim (R_eq_dec c 0);intro.
exists (1/c).
split.
unfold not;intro.
assert (1 / c * c = 0 * c).
rewrite H0.
ring.
replace (1 / c * c) with (1) in H1.
ring_simplify in H1.
intuition.
field;assumption.

replace (a * (1 / c)) with (a/c).
replace (b * (1 / c)) with (b/c).
replace ( c * (1 / c)) with 1.
auto.
field;assumption.
field;assumption.
field;assumption.
elim (R_eq_dec b 0);intro.
exists (1/b).
split.

unfold not;intro.
assert (1 / b * b = 0 * b).
rewrite H0.
ring.
replace (1 / b * b) with (1) in H1.
ring_simplify in H1.
intuition.
field;assumption.

rewrite b0.
replace (b * (1 / b)) with 1.
replace (0 * (1 / b)) with 0.
replace (a * (1 / b)) with (a/b).
auto.
field;assumption.
field;assumption.
field;assumption.
exists (1/a).
split.
subst.
assert (a<>0).
intro;subst;intuition.

unfold not;intro.
assert (1 / a * a = 0 * a).
rewrite H1.
ring.
replace (1 / a * a) with (1) in H2.
ring_simplify in H2.
intuition.
field;assumption.

rewrite b0.
rewrite b1.
replace (a * (1 / a)) with 1.
replace (0 * (1 / a)) with 0.
auto.
assert (a<>0).
unfold not;intro.
congruence.
field;assumption.
assert (a<>0).
unfold not;intro.
congruence.
field;assumption.
Qed.

Lemma point_of_triple_functionnal: forall a b c l : R, (a,b,c) <> (0,0,0) -> l <> 0 ->
point_of_triple(a,b,c) = point_of_triple(a*l,b*l,c*l).
Proof.
intros.
unfold point_of_triple.
repeat (elim R_eq_dec;intros).
replace (a * l / (c * l)) with (a /c).
replace (b*l / (c * l)) with (b/ c).
reflexivity.
field;split;assumption.
field;split;assumption.
generalize (Rmult_integral c l b0).
intuition.
generalize (Rmult_integral c l b0).
intuition.
subst.
replace (0*l) with 0 in a1 by ring.
intuition.
replace (a * l / (b * l)) with (a/b).
reflexivity.
field;split;assumption.
generalize (Rmult_integral b l b2).
intuition.
subst.
replace (0*l) with 0 in a0 by ring.
intuition.
subst.
replace (0*l) with 0 in a0 by ring.
intuition.
reflexivity.
Qed.

Definition inner_product_triple A B :=
match (A,B) with
  ((a,b,c),(d,e,f)) => a*d+b*e+c*f
end.

Definition Incid : Point -> Line -> Prop := fun P L =>
 inner_product_triple (triple_of_point P) (triple_of_line L) = 0.

Definition Incid_triple A B := inner_product_triple A B = 0.

Lemma incid_dec :  forall (A:Point)(l:Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
generalize (R_eq_dec  (inner_product_triple (triple_of_point A) (triple_of_line l)) 0) .
intuition.
Qed.

Lemma eq_point_dec : forall A B : Point, {A[==]B} + {A<>B}.
Proof.
intros.
elim A;intros;elim B;intros; try (solve [(left; discriminate) || (right; discriminate)]).
elim (R_eq_dec r r1);intros.
right.
unfold not;intro.
inversion H.
intuition.
subst.
elim (R_eq_dec r0 r2);intros.
right.
unfold not;intro.
inversion H.
intuition.
subst.
left;auto.
elim (R_eq_dec r r0);intro.
right.
unfold not;intro.
inversion H.
intuition.
subst.
left.
intuition.
left.
trivial.
Qed.

Definition det2 a b c d := a * d - b * c.

Definition general_line_through P  Q :=
match triple_of_point P, triple_of_point Q with
 (y1,y2,y3),(z1,z2,z3) =>line_of_triple ((det2  y2 y3 z2 z3),(det2 y3 y1 z3 z1), (det2 y1 y2 z1 z2))
end.

(*
Definition line_through P Q := if (eq_point_dec P Q) then L0 else general_line_through P  Q.
*)

Definition general_point_through P Q :=
match triple_of_line P, triple_of_line Q with
 (y1,y2,y3),(z1,z2,z3) =>point_of_triple ((det2  y2 y3 z2 z3),(det2 y3 y1 z3 z1), (det2 y1 y2 z1 z2))
end.

Ltac unfold_all :=
(unfold general_point_through, general_line_through, Incid, inner_product_triple, det2,
triple_of_point, point_of_triple, triple_of_line, line_of_triple in *).

Lemma normalize_compat_incid : forall a b c l1 l2 l3, (a,b,c) <> (0,0,0) -> Incid_triple (a,b,c) (l1,l2,l3) ->
Incid_triple (triple_of_point (point_of_triple (a,b,c))) (l1,l2,l3).
Proof.
intros.
unfold Incid_triple, inner_product_triple in *.
unfold triple_of_point, point_of_triple.
elim ( R_eq_dec c 0).
intro.
field_simplify.
replace (a * l1 + c * l3 + b * l2) with (a * l1 + b * l2 + c * l3) by ring.
rewrite H0.
field.
assumption.
assumption.
intro.
subst.
elim ( R_eq_dec b 0).
intro.
ring_simplify in H0.
field_simplify.
rewrite H0.
field.
assumption.
assumption.
intro.
subst.
ring_simplify in H0.
ring_simplify.
assert (a<>0).
intro;subst;intuition.
generalize (Rmult_integral a l1 H0).
intuition.
Qed.

Ltac ring_simplify_neq := match goal with
H: ?X <> ?Y |- _ => (ring_simplify X Y in H)
end.

Lemma a1_exist : forall (A B : Point) ,{l:Line | Incid A l /\ Incid B l}.
Proof.
intros.
elim A.
(* Case A is P2 y1 y2 *)
intros y1 y2.
elim B.
intros z1 z2.
elim (R_eq_dec z2 y2); intro Hz2y2.

(* case z2<>y2*)
exists (general_line_through (P2 y1 y2) (P2 z1 z2)).
unfold_all.
elim (R_eq_dec (y1 * z2 - y2 * z1) 0);intros.

split.
field;assumption.
field;assumption.

elim (R_eq_dec (1 * z1 - y1 * 1) 0);intros.
split.
field_simplify.
replace (- y1 * z2 + y2 * z1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.

field.
replace (- y1 + z1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
field_simplify.
replace (z1 * y2 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
split.
ring_simplify.
ring_simplify in b.
ring_simplify in b0.
IsoleVar z1 b0.
rewrite b0 in *.
ring_simplify in b.
clear b0.

replace (y1 * z2 - y1 * y2) with (y1 *(z2-y2)) in b by ring.
elim (Rmult_integral y1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
subst.
ring_simplify in b.
replace (z1 * z2 - z1 * y2) with (z1 * (z2 - y2)) in b by ring.
elim (Rmult_integral z1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

(* Case z2 = y2 *)
subst.
unfold_all.

elim (R_eq_dec y2 0);intro Hy2.
exists (L2 0 (- (1)/y2)).
split.
field;assumption.
field;assumption.

exists (L1 0).
subst;split;ring.

intro z1.

exists (general_line_through (P2 y1 y2) (P1 z1)).
unfold_all.
elim (R_eq_dec);intro.
ring_simplify_neq.
split;field;auto.

elim (R_eq_dec  (1 * z1 - y1 * 0) 0);intros.
ring_simplify_neq.
split.
field_simplify.
replace (- y1 + y2 * z1) with (- (y1 * 1 - y2 * z1)) by ring.
rewrite b.
field;auto.
auto.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
field_simplify.
field.
auto.
try auto. (* bizaarrre*)
split.
ring_simplify.
ring_simplify in b0.
subst.
ring_simplify in b.
auto.
ring_simplify in b0.
subst.
ring.

exists (general_line_through (P2 y1 y2) (P0)).
unfold_all.

elim (R_eq_dec (y1 * 0 - y2 * 1) 0);intro.
split.
field.
replace (y1 * 0 - y2 * 1) with (-y2) in a by ring.
auto with real.
field.
replace (y1 * 0 - y2 * 1) with (-y2) in a by ring.
auto with real.

elim (R_eq_dec  (1 * 1 - y1 * 0) 0);intro.
split.
field_simplify.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
ring_simplify in b0.
intuition.
cut False.
intuition.
intuition.
cut False.
intuition.
intuition.

(* Case A is P1 y1 *)
intro y1.

elim B.
intros z1 z2.

exists (general_line_through (P1 y1) (P2 z1 z2)).
unfold_all.

elim R_eq_dec;intro.
split.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.

elim R_eq_dec;intro.
split.
field.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
field_simplify.
replace (z1 - z2 * y1) with (- (y1 * z2 - 1 * z1)) by ring.
rewrite b.
field.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
split.
ring_simplify in b0.
ring_simplify in b.
ring_simplify.
IsoleVar y1 b0.
rewrite b0.
ring.
ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
rewrite b0 in *.
ring_simplify in b.
IsoleVar z1 b.
rewrite b.
ring.

(* Case B = P1 z1 *)

intro z1.
unfold_all.

exists (L2 0 0).
split;ring.

(* Case B = P0 *)
unfold_all.

exists (L2 0 0).
split;ring.

(* Case A is P0 *)

elim B.

(* Case B is P2 z1 z2 *)
intros z1 z2.

exists (general_line_through (P0) (P2 z1 z2)).
unfold_all.

elim (R_eq_dec);intro.
split.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.

elim (R_eq_dec);intro.
split.
field.
intuition.
ring_simplify in b.
subst.
field.

split;
ring_simplify in b0;
cut False;intuition.

(* Case B is P2 z1 z2 *)
intros z1.
unfold_all.

exists (L2 0 0).
split;ring.

unfold_all.
exists (L2 0 0).
split;ring.
Qed.

Lemma a2_exist : forall (l1 l2:Line), {A:Point | Incid A l1 /\ Incid A l2}.
Proof.
intros A B.
elim A.
(* Case A is P2 y1 y2 *)
intros y1 y2.
elim B.
intros z1 z2.
elim (R_eq_dec z2 y2); intro Hz2y2.

(* case z2<>y2*)
exists (general_point_through (L2 y1 y2) (L2 z1 z2)).
unfold_all.

elim (R_eq_dec (y1 * z2 - y2 * z1) 0);intros.

split.
field;assumption.
field;assumption.

elim (R_eq_dec (1 * z1 - y1 * 1) 0);intros.
split.
field_simplify.
replace (y2 * z1 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
field_simplify.
replace (y2 * z1 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
split.
ring_simplify.
ring_simplify in b.
ring_simplify in b0.
IsoleVar z1 b0.
rewrite b0 in *.
ring_simplify in b.
clear b0.

replace (y1 * z2 - y1 * y2) with (y1 *(z2-y2)) in b by ring.
elim (Rmult_integral y1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
subst.
ring_simplify in b.
replace (z1 * z2 - z1 * y2) with (z1 * (z2 - y2)) in b by ring.
elim (Rmult_integral z1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

(* Case z2 = y2 *)
subst.
unfold_all.

elim (R_eq_dec y2 0);intro Hy2.
exists (P2 0 (- (1)/y2)).
split.
field;assumption.
field;assumption.

exists (P1 0).
subst;split;ring.

intro z1.

exists (general_point_through (L2 y1 y2) (L1 z1)).
unfold_all.
elim (R_eq_dec);intro.
split.
field.
replace (y1 - y2 * z1) with (y1 * 1 - y2 * z1) by ring.
auto.
field.
replace (y1 - y2 * z1) with (y1 * 1 - y2 * z1) by ring.
auto.

elim (R_eq_dec  (1 * z1 - y1 * 0) 0);intros.
split.
field_simplify.
replace (y2 * z1 - y1) with (- (y1 * 1 - y2 * z1)) by ring.
rewrite b.
field.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
field_simplify.
field.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
try (ring_simplify (1 *z1 - y1*0) in a; auto).
split.
ring_simplify.
ring_simplify in b0.
subst.
ring_simplify in b.
auto.
ring_simplify in b0.
subst.
ring.

exists (general_point_through (L2 y1 y2) (L0)).
unfold_all.

elim (R_eq_dec (y1 * 0 - y2 * 1) 0);intro.
split.
field.

replace (y1 * 0 - y2 * 1) with (- y2) in a by ring.
auto with real.

field.
replace (y1 * 0 - y2 * 1) with (- y2) in a by ring.
auto with real.

elim (R_eq_dec  (1 * 1 - y1 * 0) 0);intro.
split.
field_simplify.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
intuition.
intuition.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
ring_simplify in b0.
intuition.
cut False.
intuition.
intuition.
cut False.
intuition.
intuition.

(* Case A is P1 y1 *)
intro y1.

elim B.
intros z1 z2.

exists (general_point_through (L1 y1) (L2 z1 z2)).
unfold_all.

elim R_eq_dec;intro.
split.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.

elim R_eq_dec;intro.
split.
field.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
field_simplify.
replace (- z2 * y1 + z1) with (- (y1 * z2 - 1 * z1)) by ring.
rewrite b.
field.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
split.

ring_simplify in b0.
ring_simplify in b.
ring_simplify.
IsoleVar y1 b0.
rewrite b0.
ring.
ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
rewrite b0 in *.
ring_simplify in b.
IsoleVar z1 b.
rewrite b.
ring.

(* Case B = P1 z1 *)

intro z1.
unfold_all.

exists (P2 0 0).
split;ring.

(* Case B = P0 *)
unfold_all.

exists (P2 0 0).
split;ring.

(* Case A is P0 *)

elim B.

(* Case B is P2 z1 z2 *)
intros z1 z2.

exists (general_point_through (L0) (L2 z1 z2)).

unfold_all.

elim (R_eq_dec);intro.
split.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.

elim (R_eq_dec);intro.
split.
field.
intuition.
ring_simplify in b.
subst.
field.

split;
ring_simplify in b0;
cut False;intuition.

(* Case B is P2 z1 z2 *)
intros z1.
unfold_all.

exists (P2 0 0).
split;ring.

unfold_all.
exists (P2 0 0).
split;ring.
Qed.

Lemma a3_1 :
  (forall l:Line,{A:Point & {B:Point & {C:Point | (~A[==]B /\ ~A[==]C /\ ~B[==]C /\Incid A l /\Incid B l /\ Incid C l)}}}).
Proof.
intro.
case l.
intros x1 x2.
elim (R_eq_dec x1 0);intro.
elim (R_eq_dec x2 0);intro.

exists (P2 ((0- 1) / x1) 0).
exists (P2 0 ((0- 1) / x2)).
exists (P1 (- x2 / x1)).
repeat split.
intro H; inversion H.

assert ((0 - 1) / x1 * x1 = 0-1).
field;auto.
rewrite H1 in H0.
ring_simplify in H0.
auto with field_hints.

intro H;inversion H.
intro H;inversion H.

unfold_all;field;assumption.
unfold_all;field;assumption.
unfold_all;field;assumption.

exists (P2 (- (1) / x1) (1)).
exists (P2 (- (1) / x1) (0)).
exists (P2 (- (1) / x1) (2)).

repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

elim (R_eq_dec x2 0);intro.

exists (P2  1 (- (1) / x2)).
exists (P2  0 (- (1) / x2)).
exists (P2  2 (- (1) / x2)).
repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

exists (P1  2 ).
exists (P1  0 ).
exists (P1  1 ).

repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

intro x1.

exists (P2 0 0).
elim (R_eq_dec x1 0);intro.

exists (P1 (- (1) / x1)).
exists (P2 (- (1) / x1) 1).

repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

exists (P2 1 0).
exists (P2 2 0).

repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

exists (P2 0 1).
exists (P2 0 0).
exists (P2 0 2).

repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0<>2);auto with real.

Qed.

Lemma a3_2 : {l1:Line & {l2:Line | l1 <> l2}}.
Proof.
exists L0.
exists (L1 0).
intro H;inversion H.
Qed.

Lemma equiv_eq: forall a b, a = b <-> a - b = 0.
Proof.
split.
intros.
rewrite H.
ring.
intro.
assert (a-b + b = 0 + b).
rewrite H.
ring.
ring_simplify in H0.
assumption.
Qed.

Lemma equiv_or: forall a b, a = 0 \/ b = 0 <-> a*b = 0.
Proof.
intros.
split.
intro.
case H;intros.
rewrite H0.
ring.
rewrite H0.
ring.
intro.
apply Rmult_integral.
assumption.
Qed.

Lemma equiv_and : forall a b, a = 0 /\ b = 0 <-> a*a + b*b = 0.
Proof.
intros.
intuition.
subst.
ring.
generalize (Rplus_sqr_eq_0 a b).
intuition.
generalize (Rplus_sqr_eq_0 a b).
intuition.
Qed.

Ltac replace_cons X Y := progress (
   match Y  with
| 0 => idtac
| _ => setoid_replace (X=Y) with (X-Y=0) by (apply equiv_eq)
end).

Ltac injection_equiv := let H := fresh in
(split;
intro H;[injection H;auto | decompose [and] H;subst;auto]).

Lemma eq_2 : forall X1 X2 Y1 Y2,
P2 X1 X2 = P2 Y1 Y2 <-> (X1 = Y1 /\ X2 = Y2).
Proof.
intros X1 X2 Y1 Y2.
injection_equiv.
Qed.

Lemma eq_1 : forall X Y,
P1 X = P1 Y <-> X = Y.
intros.
injection_equiv.
Qed.

Ltac reduce_prop :=
match goal with
| H: _ |- context [?X = ?Y] => replace_cons X Y
| H: _ |- context [?X = 0 /\ ?Y=0] => setoid_replace (X = 0 /\ Y=0) with (X*X + Y*Y = 0) by apply equiv_and
| H: _ |- context [?X = 0 \/ ?Y=0] => setoid_replace (X = 0 \/ Y=0) with (X*Y = 0) by apply equiv_or
| H: _ |- context [(P1 ?X1 = P1 ?Y1)] => setoid_replace (P1 X1 = P1 Y1) with (X1 = Y1) by try injection_equiv
| H: _ |- context [(L1 ?X1 = L1 ?Y1)] => setoid_replace (L1 X1 = L1 Y1) with (X1 = Y1) by try injection_equiv

| H: _ |- context [(?P ?X1 ?X2 = ?P ?Y1 ?Y2)] =>
   setoid_replace (P X1 X2 = P Y1 Y2) with (X1 = Y1 /\ X2 = Y2)
  by let H := fresh in (split;intro H;[inversion H;auto | decompose [and] H;subst;auto])
| H: _  |- context [P2 ?X ?Y = P1 ?Z] => setoid_replace (P2 X Y = P1 Z) with False by try (intuition;discriminate)
| H: _  |- context [P2 ?X ?Y = P0] => setoid_replace (P2 X Y = P0) with False by try (intuition;discriminate)
| H: _  |- context [P1 ?X = P0] => setoid_replace (P1 X = P0) with False by try (intuition;discriminate)
| H: _  |- context [L2 ?X ?Y = L1 ?Z] => setoid_replace (L2 X Y = L1 Z) with False by try (intuition;discriminate)
| H: _  |- context [L2 ?X ?Y = L0] => setoid_replace (L2 X Y = L0) with False by try (intuition;discriminate)
| H: _  |- context [L1 ?X = L0] => setoid_replace (L1 X = L0) with False by try (intuition;discriminate)

| H: _  |- context [P1 ?Z = P2 ?X ?Y] => setoid_replace (P1 Z = P2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [P0 = P2 ?X ?Y] => setoid_replace (P0 = P2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [P0 = P1 ?X] => setoid_replace (P0 = P1 X) with False by try (intuition;discriminate)
| H: _  |- context [L1 ?Z = L2 ?X ?Y] => setoid_replace (L1 Z = L2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [L0 = L2 ?X ?Y] => setoid_replace (L0 = L2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [L0 = L1 ?X] => setoid_replace (L0 = L1 X) with False by try (intuition;discriminate)

| H: _  |- context [L0 = L0] => setoid_replace (L0 = L0) with True by try (split;auto)
| H: _  |- context [P0 = P0] => setoid_replace (P0 = P0) with True by try (split;auto)

| H: _  |- context [?P \/ False] => setoid_replace (P \/ False) with (P) by try intuition
| H: _  |- context [False \/ ?P] => setoid_replace (False \/ P) with (P) by try intuition

| H: _  |- context [?P \/ True] => setoid_replace (P \/ True) with (True) by try intuition
| H: _  |- context [True \/ ?P] => setoid_replace (True \/ P) with (True) by try intuition
end.

Ltac normalize_prop := repeat reduce_prop.

Ltac simplify_eqs eq1 eq2 eq3 eq4 :=
  ring_simplify in eq1;try subst;
  ring_simplify in eq2;try subst;
  ring_simplify in eq3;try subst;
  ring_simplify in eq4;try subst.

Lemma triple_of_point_carac : forall A,
 let '(a,b,c) := triple_of_point A in
 (c=1 \/ c=0) /\
 (c=1 \/ b=1 \/ b=0) /\
 (c=1 \/ b=1 \/ a=1).
Proof.
 destruct A; simpl; intuition.
Qed.

Lemma triple_of_point_carac' : forall A,
 let '(a,b,c) := triple_of_point A in
 (c-1)*c=0 /\
 (c-1)*(b-1)*b=0 /\
 (c-1)*(b-1)*(a-1)=0.
Proof.
 intros A.
 generalize (triple_of_point_carac A).
 destruct triple_of_point as ((a,b),c).
 rewrite <- !equiv_or, <- !equiv_eq. intuition.
Qed.

Lemma triple_of_line_carac : forall l,
 let '(a,b,c) := triple_of_line l in
 (c=1 \/ c=0) /\
 (c=1 \/ b=1 \/ b=0) /\
 (c=1 \/ b=1 \/ a=1).
Proof.
 destruct l; simpl; intuition.
Qed.

Lemma triple_of_line_carac' : forall l,
 let '(a,b,c) := triple_of_line l in
 (c-1)*c=0 /\
 (c-1)*(b-1)*b=0 /\
 (c-1)*(b-1)*(a-1)=0.
Proof.
 intros l.
 generalize (triple_of_line_carac l).
 destruct triple_of_line as ((a,b),c).
 rewrite <- !equiv_or, <- !equiv_eq. intuition.
Qed.

Lemma pair_eq : forall A B (a a':A)(b b':B),
 (a,b) = (a',b') <-> a=a' /\ b=b'.
Proof.
 intros.
 split. injection 1; split; trivial.
 destruct 1; subst; trivial.
Qed.

Lemma triple_of_point_inj : forall A B,
 triple_of_point A = triple_of_point B <-> A [==] B.
Proof.
 intros. split; intros.
 rewrite <- (triple_point A), <- (triple_point B). rewrite H.
reflexivity.
rewrite H;reflexivity.
Qed.

Lemma triple_of_line_inj : forall l m,
 triple_of_line l = triple_of_line m <-> l = m.
Proof.
 destruct l, m; unfold_all; simpl; rewrite !pair_eq;
  intuition; subst; try congruence; exfalso; auto with real.
Qed.

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A[==]B \/ l=m.
Proof.
intros A B l m. intros.
unfold Incid in *.
rewrite <- triple_of_point_inj, <- triple_of_line_inj.
generalize (triple_of_point_carac' A)(triple_of_point_carac' B)
 (triple_of_line_carac' l)(triple_of_line_carac' m).
destruct (triple_of_point A) as ((a1,a2),a3).
destruct (triple_of_point B) as ((b1,b2),b3).
destruct (triple_of_line l) as ((l1,l2),l3).
destruct (triple_of_line m) as ((m1,m2),m3).
intros (EQa3 & EQa2 & EQa1).
intros (EQb3 & EQb2 & EQb1).
intros (EQl3 & EQl2 & EQl1).
intros (EQm3 & EQm2 & EQm1).
unfold_all.
rewrite !pair_eq.
normalize_prop.
nsatz.
Qed.

End s_HomogeneousModel.


Require Export Relations.
Require Export orders.
Require Export IO.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

(** Module PCF defines the syntax of PCF according to
    "On full abstraction for PCF" (Hyland, Ong) *)

(** Notations:
    - [^f := opt_TP_map u f]    (similar to (option_map f))
    - [v //- f := rename f v]
    - [$ f := shift f ]
    - [v >>- f := shift f v ]
    - [v >>= f := subst v f ]
    - [v // N := substar v N ]   (substitution of one variable only) *)

(**

    we define at first morphisms in (TY -> Type),
    these morphisms are named with an underscore "_" at the end
    after defining beta reduction we upgrade them to morphisms in
    the category of preorders over TY
*)

Module PCF.

Notation "y <<< z" := (IRel y z) (at level 60).

(** the types of PCF *)
Inductive TY :=
 | Bool : TY
 | Nat : TY
 | arrow: TY -> TY -> TY.

Notation "a '~>' b" := (arrow a b) (at level 69, right associativity).

(** we are in the category of indexed preorders over type TY *)
Notation "'IP'" := (IO TY).

(** PCF constants *)
Inductive Consts : TY -> Type :=
 | Nats : nat -> Consts Nat
 | ttt : Consts Bool
 | fff : Consts Bool
 | succ : Consts (Nat ~> Nat)
 | zero : Consts (Nat ~> Bool)
 | condN: Consts (Bool ~> Nat ~> Nat ~> Nat)
 | condB: Consts (Bool ~> Bool ~> Bool ~> Bool).

Notation "V '*'" := (opt_TP _ V) (at level 5).
(*Notation "V '**' u":= (opt_TP u V) (at level 5).*)

(** PCF terms *)
Inductive PCF (V: IP) : TY -> Type:=
 | Bottom: forall t, PCF V t
 | Const : forall t, Consts t -> PCF V t
 | Var : forall t, V t -> PCF V t
 | App : forall t s, PCF V (s ~> t) -> PCF V s -> PCF V t
 | Lam : forall t s, PCF (opt_TP t V) s -> PCF V (t ~> s)
 | Rec : forall t, PCF V (t ~> t) -> PCF V t.

(** a nicer name for morphisms of families of preorders *)
(*Notation "'varmap'" := ipo_mor.*)

(** a morphism extended to a family + one element, whose type is implicit *)
Notation "^ f" := (lift (M := opt_TP_monad _) f) (at level 10).

Reserved Notation "x //- f" (at level 42, left associativity).

(** functoriality of PCF (without order) *)
Fixpoint rename_ (V W: IP) (f: V ---> W)
         (t:TY)(v:PCF V t): PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | Const t c => Const W c
    | Var t v => Var (f t v)
    | App t s u v => App (u //- f) (v //- f)
    | Lam t s u => Lam (u //- (^f))
    | Rec t u => Rec (u //- f)
    end
where "x //- f" := (@rename_ _ _ f _ x).

(** injection of terms into terms with one variable more, of type u *)
Definition inj_(u:TY)(V : IP)(t:TY)(v:PCF V t): PCF  V* t :=
      v //- (@Some_TP TY u V) .

(** inject term in PCF V t in PCF (V* ) t *)
Definition shift_ :=
fun (u : TY) (V W : IP) (f : forall t, V t -> PCF W t)
  (t : TY) (v : V* t) =>
match v in (opt _ _ y) return (PCF (opt_TP u W) y) with
| some t0 p => inj_ u (f t0 p)
| none => Var (V:=opt_TP u W) (t:=u) (none u W)
end.

Notation "'$' f" := (@shift_ _ _ _ f) (at level 30).

Notation "x >>- f" := (shift_ f x) (at level 44).

(**  substitution *)
Reserved Notation "x >>= f" (at level  42, left associativity).

Fixpoint subst_ (V W: IP)(f: forall t, V t -> PCF W t)
           (t:TY)(v:PCF V t) : PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | Const t c => Const W c
    | Var t v => f t v
    | App t s u v => App (u >>= f) (v >>= f)
    | Lam t s u => Lam (u >>= $ f)
    | Rec t u => Rec (u >>= f)
    end
where "x >>= f" := (@subst_ _ _ f _ x).

Definition substar_map (u:TY) (V: IP) (M: PCF V u)
       (t:TY)(v:(opt_TP u V) t) : PCF V t.
intros.
destruct v as [t v | ].
apply (Var v).
apply M.
Defined.

(** substitution of one variable *)
Definition substar (u:TY) (V:IP) (M:PCF V u)
       (*PCF V t0 := subst_  *) := subst_
  (fun t (x0: opt_TP u V t) => match x0 in (opt _ _ r )
                              return (PCF V r )with
            | none => M
            | some _ v0 => Var v0
            end)  .

Notation "x // N " := (@substar _ _ N _ x) (at level 40).

(** now a lot of lemmata about interactions between the defined functions *)
Section Fusion_Laws.

Lemma rename_eq (V: IP)(t:TY)(v: PCF V t)
  (W: IP) (f g: V ---> W)(H: forall t x, f t x = g t x):
           v //- f  = v //- g .
Proof.
  intros V t v;
  induction v;
  simpl; auto.

  intros;
  rewrite H;
  auto.

  intros.
  rewrite (IHv1 W f g); auto.
  rewrite (IHv2 W f g); auto.

  intros.
  set (H':= IHv _  (lift (M:=opt_TP_monad _ ) f)
                   (lift (M:=opt_TP_monad _ ) g)).
  simpl in *.
  rewrite H'. auto.

  set (H'':= lift_eq (opt_monad t) H). auto.

  intros; rewrite (IHv W f g H); auto.
Qed.

Lemma rename_id (V:IP)(t:TY)(v: PCF V t)
  (f: V ---> V)(H: forall t x, f t x = x):
           v //- f = v.
Proof.
  intros V t v; induction v;
  intros f H;
  simpl; auto.
  rewrite H; auto.
  rewrite IHv1; try rewrite IHv2; auto.
  rewrite IHv; auto.
  unfold lift.
  intros t0 x; destruct x; simpl; try rewrite H; auto.
  rewrite IHv; auto.
Qed.

Lemma rename_comp (V: IP) (t: TY) (v: PCF V t)
      (W X: IP) (f: V ---> W) (g: W ---> X):
      v //- (f ;; g) =
           v //- f //- g.
Proof.
  intros V t v; induction v;
  simpl in *; auto.
  intros W X f g; rewrite IHv1; rewrite IHv2; auto.
  intros W X f g.
  apply f_equal.
  rewrite <- (IHv _ (opt_TP t X)).
  apply rename_eq.
  intros r x.
  set (H':= lift_lift (opt_TP_monad t)).
  simpl in *.
  rewrite H'. auto.
  intros W X f g; rewrite IHv; auto.
Qed.

Lemma shift_eq (u:TY) (V : IP)(t:TY)(v:opt u V t)
          (W: IP)(f g: forall t, V t -> PCF W t)
          (H: forall t x, f t x = g t x):
          v >>- f  = v >>- g .
Proof.
  intros u V t v;
  induction v;
  simpl; intros;
  try rewrite H; auto.
Qed.

Lemma shift_var (u:TY)(V : IP)(t:TY)(v: opt_TP u V t):
       v >>- (fun t x => Var x)  = Var v.
Proof.
  induction v;
  intros; simpl;
  auto.
Qed.

Lemma var_lift_shift_eq (u:TY) (V:IP) (t: TY) (v: opt u V t)
     (W:IP) (f: V ---> W):
    Var (^f t v) = v >>- (fun t x => Var (f t x)).
Proof.
  induction v;
  simpl; intros;
  auto.
Qed.

Lemma shift_lift (u:TY) (V: IP) (t:TY)(v:opt u V t)
           (W X:IP)(f: V ---> W)
           (g: forall t, W t -> PCF X t):
   ^f t v >>- g =
    v >>- (fun t x0 => g t (f t x0)).
Proof.
  induction v;
  simpl; intros;
  auto.
Qed.

Lemma subst_eq (V: IP)(t:TY)(v:PCF V t) (W : IP)
       (f g: forall t, V t -> PCF W t)
       (H: forall t x, f t x = g t x) :
       v >>= f = v >>= g.
Proof.
  induction v;
  intros; simpl;  auto.

  try rewrite (IHv1 W f g);
  try rewrite (IHv2 W f g);
  try rewrite (IHv W f g); auto.

  rewrite (IHv _ (shift_ f) (shift_ g)); auto.
  intros; apply shift_eq; auto.

  rewrite (IHv W f g); auto.
Qed.

Lemma subst_var (V:IP)(t:TY)(v:PCF V t):
        v >>= (@Var V) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_var_eta (V:IP)(t:TY)(v:PCF V t):
        v >>= (fun t z => Var z) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_var_eta2 (V:IP)(t:TY)(v:PCF V t):
        v >>= (fun t => @Var V t) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_eq_rename (V:IP)(t:TY)(v:PCF V t)
      (W:IP) (f: V ---> W):
        v //- f  = v >>= fun t z => Var (f t z).
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1; rewrite IHv2; auto.
  rewrite IHv. apply f_equal. apply subst_eq.
  set (H':= var_lift_shift_eq).
  simpl in H'. intros;
  apply H'.
  rewrite IHv; auto.
Qed.

Lemma rename_term_inj (u:TY)(V:IP)(t:TY)(v:PCF V t)
    (W: IP) (g: V ---> W):
      inj_ u v //- ^g  =  inj_ u (v //- g).
Proof.
  induction v; simpl in *; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.
  unfold inj_. simpl.
  apply f_equal.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  induction x; simpl; auto.
  rewrite IHv. unfold inj_.
  simpl. auto.
Qed.

Lemma rename_subst (V:IP) (t:TY)(v: PCF V t)
     (W X: IP)(f: forall t, V t -> PCF W t)
     (g: W ---> X):
   v >>= f //- g =
           v >>= fun t x => f t x //- g .
Proof.
  induction v; intros; simpl in *; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv. apply f_equal. apply subst_eq.
  induction x; simpl; auto.
  set (H':= rename_term_inj).
  simpl in *. apply H'.

  rewrite IHv. auto.
Qed.

Lemma subst_rename (V:IP) (t:TY)(v: PCF V t)
     (W X:IP) (f: V ---> W)
     (g: forall t, W t -> PCF X t):
    v //- f >>= g =
            v >>= fun t x =>  g t (f t x).
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv. apply f_equal.
  apply subst_eq. intros.
  apply shift_lift.

  rewrite IHv. auto.
Qed.

Lemma rename_substar (V: IP)(s t:TY) (v:PCF (opt_TP s V) t)
   (W:IP) (f: V ---> W) N:
       v // N  //- f =
         (v //- ^f) // (N //- f).
Proof.
  intros. unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  intros t0 x; destruct x;
  simpl; auto.
Qed.

Lemma subst_term_inj (u:TY)(V:IP)(t:TY)(v:PCF V t)
      (W:IP)
      (g: forall t, V t -> PCF W t):
    (inj_ u v) >>= $ g = inj_  _ (v >>= g).
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  unfold inj_. simpl. apply f_equal.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  induction x; simpl; auto.
  set (H':=rename_term_inj);
  simpl in *. rewrite H'.
  apply f_equal.
  apply rename_eq. auto.
  rewrite IHv; auto.
Qed.

Lemma subst_shift_shift (u:TY) (V:IP) (t:TY)(v:opt_TP u V t)
 (W X : IP)
 (f: forall t, V t -> PCF W t)
 (g: forall t, W t -> PCF X t):
   (v >>- f)  >>= $ g =
          v >>- fun t z => f t z >>= g .
Proof.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
Qed.

Lemma subst_subst (V:IP)(t:TY)(v:PCF V t)
         (W X : IP)
         (f: forall t, V t -> PCF W t)(g : forall t, W t -> PCF X t):
  v >>= f >>= g =
      v >>= fun t z => f t z >>= g.
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv. apply f_equal.
  apply subst_eq.
  intros; simpl.
  apply subst_shift_shift.

  rewrite IHv; auto.
Qed.

End Fusion_Laws.

(** we define beta reduction in three steps
  - beta_: beta reduction at the root only,
           + compatibility with order on variables
  - propag: for given relation "rel",
      "propag rel" relates terms whose subterms are related by rel
          abbreviated by "p"
  - clos_refl_trans_1n (from std lib) speaks for itself
          abbreviated by "rt" *)

Section Relations_on_PCF.

Definition PCFrel := forall (V: IP) t, relation (PCF V t).

Reserved Notation "x :> y" (at level 70).

Variable rel : forall (V:IP) t, relation (PCF V t).

Inductive propag (V: IP)
       : forall t, relation (PCF V t) :=
| relorig : forall t (v v':PCF V t), rel v v' ->  v :> v'
| relApp1: forall (s t:TY)(M M':PCF V (s ~> t)) N,
       M :> M' -> App M N :> App M' N
| relApp2: forall (s t:TY)(M:PCF V (s ~> t)) N N',
      N :> N' -> App M N :> App M N'
| relLam: forall (s t:TY)(M M':PCF (opt_TP s V) t),
      M :> M' -> Lam M :> Lam M'
| relRec : forall (s:TY) (M M':PCF V (s ~> s)),
      M :> M' -> Rec M :> Rec M'

where "x :> y" := (@propag _ _ x y).

Notation "x :>> y" :=
  (clos_refl_trans_1n _ (@propag _ _ ) x y) (at level 50).

Variable V: IP.
Variables s t: TY.

(** these are some trivial lemmata  which will be used later *)

Lemma cp_App1 (M M': PCF V (s ~> t)) N :
    M :>> M' -> App M N :>> App M' N.
Proof.
  intros. generalize N.
  induction H. constructor.
  intros. constructor 2 with (App y N0); auto.
  constructor 2. auto.
Qed.

Lemma cp_App2 (M: PCF V (s ~> t)) N N':
    N :>> N' -> App M N :>> App M N'.
Proof.
  intros. generalize M.
  induction H. constructor.
  intros. constructor 2 with (App M0 y); auto.
  constructor 3. auto.
Qed.

Lemma cp_Lam (M M': PCF (opt_TP s V) t ):
      M :>> M' -> Lam M :>> Lam M'.
Proof.
  intros. induction H. constructor.
  constructor 2 with (Lam y); auto.
  constructor 4. auto.
Qed.

Lemma cp_Rec (M M': PCF V (t ~> t)):
      M :>> M' -> Rec M :>> Rec M'.
Proof.
  intros.
  induction H. constructor.
  constructor 2 with (Rec y); auto.
  constructor 5. auto.
Qed.

End Relations_on_PCF.

(** Beta reduction *)

Section Beta_Relation.

Inductive beta_ (V:IP): forall t, relation (PCF V t) :=
| beta_beta: forall (s t:TY) (M: PCF (opt_TP s V) t) N,
          beta_ (App (Lam M) N) (M // N)
| beta_var: forall (t:TY) (x y:V t),
         x <<< y -> beta_ (Var x) (Var y).

Definition beta := propag beta_.

Definition betaS :=
   fun (V:IP) t => clos_refl_trans_1n _ (@beta V t).

Program Instance BETA_struct (V:IP) : io_struct (PCF V) := {
 IRel t := @betaS V t
}.
Next Obligation.
Proof.
  constructor.
  constructor.
  set (H':= @clos_rt_is_preorder _ (@beta V t)).
  unfold betaS.
  unfold Transitive.
  intros.
  destruct H' as [H1 H2].
  unfold transitive in H2.
  simpl in *.
  apply trans_rt1n.
  apply H2 with y;
    apply rt1n_trans;
    auto.
Qed.

Program Definition BETA (V : IP) : IP :=
    Build_io_obj (BETA_struct V ).

(*  Next Obligation.
    Proof. unfold betaS; apply Clos_RT_1n. Qed. *)

End Beta_Relation.

(** upgrading the morphisms of (TY -> Type) to morphisms in
    the cat of preorders over TY
     - [rename_ => rename]
     - [subst_ => subst]
*)

(** we show that if (rename f) is
    compatible with a relation "rel" on PCF,
    then it is also compatible with "propag rel" and "clos_rt rel"
   (cf. Section rename_bs )

   same for shift_ and subst_
*)

(** for subst_ the upgrading is more difficult than for rename_
    we first prove a lemma that says that
      [ rt (p (rt (p rel))) <= rt (p rel) ]
   called propag_clos_propag_clos                    *)

Section Compat_with_Beta.

Notation "'rt'" := (clos_refl_trans_1n _) (at level 60).
Notation "'p'" := @propag (at level 60).

Section rename.

Section rename_bs.

Variable rel: PCFrel.

Lemma rename_propag :
    (forall (V W:IP) (f: V ---> W) (H : iMonotone f) t,
      Proper (@rel V t ==> @rel _ _) (fun v => v //- f) )
    ->
    forall (V W: IP)(f: V ---> W) (H : iMonotone f) t,
    Proper (p rel V t ==> p rel W t) (fun v => v //- f).
Proof.
  unfold Proper in *; repeat red in *.
  intros H V W f H' t x y H0.
  generalize dependent W.
  dependent induction H0.
  red in H.

  constructor 1. apply H; auto.

  simpl. constructor 2. auto.
  simpl. constructor 3. auto.
  simpl in *. constructor 4.
  set (H2:= IHpropag (opt_TP s W) (lift (M:=opt_TP_monad s) f)).
  (*  simpl in *. *)
  apply H2.
  assert (H3:= opt_TP_lift_monotone (u:=s) H').
  apply H3.
  simpl in *.
  simpl. constructor 5. auto.
Qed.

Lemma rename_rt_clos:
  (forall (V W:IP)(f: V ---> W) (H: iMonotone f) t,
   Proper (@rel V t ==> @rel W t) (fun v => v //- f))
   ->
  forall (V W:IP) (f:V ---> W) (H: iMonotone f) t,
  Proper (rt (@rel V t) ==> rt (@rel W t)) (fun v => v //- f).
Proof.
  unfold Proper; repeat red.
  intros H V W f H' t x y H0.
  (*       generalize dependent W. *)
  dependent induction H0; simpl.
  intros. constructor 1.
  intros. constructor 2 with (rename_  f y).
  red in H.
  apply (H V W f _ _ x y). auto.
  apply IHclos_refl_trans_1n; auto.
Qed.

End rename_bs.

Lemma rename_beta:
forall (V W : IP) (f : V ---> W) (H: iMonotone f) (t : TY),
Proper (@beta_ V t ==> @beta_ W t) (fun v => v //- f).
Proof.
  intros V W f H' t.
  unfold Proper; repeat red.
  intros x y H.
  induction H. simpl.
  rewrite rename_substar.
  constructor.
  simpl.
  constructor 2.
  apply H'; auto.
Qed.

Definition rename (V W : IP) (f : V ---> W) :
       BETA V ---> BETA W :=
      @rename_ V W f.

Instance rename_monotone (V W : IP) (f : V ---> W) (H : iMonotone f) :
        iMonotone (rename f).
Proof.
  unfold Monotone.
  intros V W f H' t.
  unfold Proper; repeat red.
  unfold beta.
  intros x y H.
  apply rename_rt_clos;
  auto.
  intros V0 W0 F0 t0.
  apply (@rename_propag beta_ ).
  intros V1 W1 f0 t1.
  unfold Proper; red.
  intros.
  apply rename_beta;
  auto.
  auto.
Qed.

End rename.

Section inj.

Definition inj (u : TY) (V : IP) : BETA V ---> BETA (V*) :=
      (@inj_ u V).

Instance inj_monotone (u : TY) V :
       iMonotone (@inj u V).
Proof.
  unfold inj.
  unfold inj_.
  intros u V.
  apply (rename_monotone (@Some_TP_monotone _ u V)).
Qed.

End inj.

Section shift.

Variable u:TY.

Section shift_bs.

Variable rel: forall (V:IP) t, relation (PCF V t).

Lemma shift_propag :
    (forall (u:TY)(V W:IP) (f: V ---> (BETA W)) (H : iMonotone f) (t:TY),
      Proper (IRel (A:=opt_TP u V) (t:=t) ==> @rel(opt_TP u W) t )
                    (@shift_ u _ _ f t))
    ->
    forall (V W: IP)(f: V ---> (BETA W)) (H : iMonotone f) t,
    Proper (IRel (A:=opt_TP u V) (t:=t) ==> @propag rel (opt_TP u W) t )
                                     (@shift_ u _ _ f t).
Proof.
  unfold Proper in *;
  repeat red in *.
  intros H V W f H' t x y H0.
  red in H.
  generalize dependent W.
  induction H0.

  constructor 1.
  apply H; auto.
  constructor.
  auto.

  intros W f.
  constructor 1.
  apply H.
  auto.
  constructor 2.
  auto.
Qed.

Lemma shift_rt_clos :
  (forall (u:TY)(V W:IP) (f: V ---> (BETA W)) (H : iMonotone f) t,
  Proper (IRel (A:=opt_TP u V)(t:=t) ==> @rel (opt_TP u W) t)
                        (@shift_ u _ _ f t))
    ->
  forall (V W: IP)(f: V ---> (BETA W)) (H : iMonotone f) t,
  Proper (IRel (A:=opt_TP u V) (t:=t)  ==>
            @clos_refl_trans_1n _ (@rel (opt_TP u W) t) )
                        (@shift_ u _ _ f t).
Proof.
  unfold Proper; repeat red in *.
  intros H V W f H' t x y H0.
  red in H.
  induction H0.
  constructor 1.

  constructor 2 with (shift_ f (some u z)).
  apply H.
  auto.
  constructor. auto.
  constructor 1.
Qed.

End shift_bs.

Definition shift (V W : IP) (f : V ---> BETA W) : V* ---> BETA W* :=
        (@shift_ u V _ f).

Instance shift_monotone V W (f : V ---> BETA W)
        (H : iMonotone f) : iMonotone (shift f).
Proof.
  intros V W f H.
  unfold Monotone.
  unfold Proper; red.
  intros t x y H'.
  induction H'.
  constructor 1.

  simpl.
  apply inj_monotone.
  apply H;
  auto.
Qed.

End shift.

Section subst.

Section subst_bs.

Variable rel: PCFrel.

Lemma subst_propag :
    (forall (V W:IP) (f: V ---> (BETA W)) (H : iMonotone f) t,
      Proper (@rel V t ==> @rel _ _) (fun v => v >>= f ))
    ->
    forall (V W: IP)(f: V ---> (BETA W)) (H : iMonotone f) t,
    Proper (p rel V t ==> p rel W t) (fun v => v >>= f ).
Proof.
  unfold Proper in *;
  repeat red in *.
  intros H V W f H' t x y H0.
  generalize dependent W.
  dependent induction H0.
  red in H.

  constructor 1. apply H; auto.

  simpl. constructor 2. auto.

  simpl. intros; constructor 3. apply IHpropag. auto.

  simpl. intros. constructor 4.
  apply (IHpropag _ _ (shift_monotone H')). auto.

  simpl; intros; constructor 5; auto.
Qed.

Lemma subst_rt_clos :
   (forall (V W:IP) (f: V ---> (BETA W)) (H : iMonotone f) t,
      Proper (@rel V t ==> @rel _ _) (fun v => v >>= f ))
    ->
    forall (V W: IP)(f: V ---> (BETA W)) (H : iMonotone f) t,
    Proper (rt (@rel V t) ==> rt (@rel _ _)) (fun v => v >>= f ).
Proof.
  unfold Proper in *; repeat red in *.
  intros H V W f H' t x y H0.
  generalize dependent W.
  dependent induction H0.
  red in H.

  constructor 1.

  intros. constructor 2 with (y >>= f).
  apply H; auto.
  apply IHclos_refl_trans_1n;
  auto.
Qed.

End subst_bs.

Lemma subst_substar (V W:IP)
      (s t:TY) (M: PCF V* t) (N:PCF V s)
      (f:forall t, V t -> PCF W t):
   M // N >>= f = (M >>= $ f) // (N >>= f).
Proof.
  intros V W s t M N f.
  unfold substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  intros t0 x.
  destruct x. unfold shift_.
  unfold inj_.
  rewrite subst_rename. simpl.
  rewrite  subst_var_eta. auto.
  simpl.
  apply subst_eq; auto.
Qed.

Section subst_lemmata.

Variable rel:PCFrel.

Lemma propag_clos_propag_clos (V: IP)(t:TY)(x y: PCF V t)
(H: rt (p (fun V0 t0 => fun x0 y0 => rt (p rel V0 t0) x0 y0) V t) x y):
       rt (p rel V t) x y.
Proof.
  intros V t x y H.
  induction H.
  constructor.

  clear H0.
  generalize dependent z.
  induction H.

  intros z Hz.
  transitivity v'; auto.

  intros. (*inversion IHclos_refl_trans_1n.*)
  transitivity (App M' N); auto.
  apply cp_App1. apply IHpropag. constructor.

  intros.
  transitivity (App M N'); auto.
  apply cp_App2. apply IHpropag. constructor.

  intros.
  transitivity (Lam M'); auto.
  apply cp_Lam. apply IHpropag. constructor.

  intros.
  transitivity (Rec M'); auto.
  apply cp_Rec. apply IHpropag. constructor.
Qed.

Lemma clos (V:IP) (t:TY) x y:
          rel x y -> rt (@rel V t) x y.
Proof.
  intros V t x y H.
  constructor 2 with y;
  try constructor;
  auto.
Qed.

End subst_lemmata.

Definition subst V W (f : V ---> BETA W) : BETA V ---> BETA W :=
       (@subst_ V W f).

Instance subst_monotone V W (f : V ---> BETA W)
          (H : iMonotone f) : iMonotone (subst f).
Proof.
  intros V W f H'.
  unfold Monotone.
  unfold Proper; repeat red.
  intros t x y H.
  generalize dependent W.

  induction H. constructor.

  intros.

  transitivity (y >>= f); auto.

  apply propag_clos_propag_clos.
  generalize dependent W.
  generalize dependent z.
  induction H. intros. simpl.
  Focus 2. intros. simpl.
  clear H0 IHclos_refl_trans_1n z.
  apply cp_App1.
  apply IHpropag with M'; auto. constructor.
  intros. constructor.

  Focus 2. intros. simpl.
  clear H0 IHclos_refl_trans_1n z.
  apply cp_App2.
  apply IHpropag with N';
  try auto; constructor.

  Focus 2. intros. simpl.
  clear H0 IHclos_refl_trans_1n z.
  apply cp_Lam.

  apply (IHpropag M').
    constructor.
    intros. constructor.
    apply shift_monotone.
    auto.

  Focus 2. intros. simpl.
  clear H0 IHclos_refl_trans_1n z.
  apply cp_Rec.
  apply IHpropag with M'.
    constructor.
    intros. constructor.
    auto.

  induction H.
  apply clos. constructor 1.
  simpl.
  rewrite subst_substar.
  apply clos. constructor 1. constructor 1.

  simpl.
  apply clos.
  constructor 1.
  apply H'.
  auto. apply IHclos_refl_trans_1n.
  auto.
Qed.

End subst.

End Compat_with_Beta.

(** preparations for defining the monad (haskell style) *)
(** return is given by VAR, the upgraded version of Var *)

Definition VAR V : V ---> BETA V := @Var V.

Instance var_monotone V : iMonotone (@VAR V).
Proof.
  unfold Monotone,Proper;
  red.
  intros V t x y H;
  simpl.
  constructor 2 with (Var y);
  try constructor.
  constructor.
  auto.
Qed.

(** betaS in subterms *)

Section betaS_constructors.

Variable V : IP.
Variables s t: TY.

Lemma betaS_App1 (v1 v2: BETA V (s ~> t)) w :
          betaS v1 v2 -> betaS (App v1 w) (App v2 w).
Proof.
  intros v1 v2 w H.
  generalize dependent w.
  induction H.
  constructor 1.
  intros.
  intros;
  transitivity (App y w); auto.
  apply clos.
  apply relApp1; auto.
Qed.

Lemma betaS_App2 (v : BETA V (s ~> t)) w1 w2 :
          betaS w1 w2 -> betaS (App v w1) (App v w2).
Proof.
  intros v v1 w2 H.
  generalize dependent v.
  induction H.
  constructor 1.
  intros.
  intros;
  transitivity (App v y); auto.
  apply clos.
  apply relApp2; auto.
Qed.

Lemma betaS_Rec (v w : BETA V (s ~> s)):
          betaS v w -> betaS (Rec v) (Rec w).
Proof.
  intros v w H.
  induction H.
  constructor 1.
  transitivity (Rec y); auto.
  apply clos.
  apply relRec; auto.
Qed.

Lemma betaS_Lam (v w : BETA (opt_TP s V) t ):
          betaS v w -> betaS (Lam v) (Lam w).
Proof.
  intros v w H.
  induction H.
  constructor 1.
  transitivity (Lam y); auto.
  apply clos.
  apply relLam; auto.
Qed.

End betaS_constructors.

(** upgrading the constructors to morphisms *)

(*

Program Definition AppPO (V:ipo) r s:
   PO_mor (product (IP_proj (r ~> s) (BETA V))
                   (IP_proj r (BETA V))) (IP_proj s (BETA V)) :=
 Build_PO_mor
       (PO_fun := fun t => App  (s:= r) (fst t)  (snd t) ) _ .
Next Obligation.
Proof.
  constructor.
  unfold Proper; red.
  intros x y.
  destruct x as [x1 x2];
  destruct y as [y1 y2];
  simpl.
  intro H.
  inversion H.
  subst.
  simpl in *.
  transitivity (App x1 y2);
  auto using betaS_App2, betaS_App1.
Qed.

Program Instance LamPO_struct (V:ipo) r s :
      PO_mor_struct (a:= IP_proj s (BETA (opt_TP r V)))
                    (b:=IP_proj (r ~> s) (BETA V))
   (@Lam V r s).
Next Obligation.
Proof.
  unfold Proper; red.
  intros. simpl.
  auto using betaS_Lam.
Qed.

Definition LamPO (V:ipo) r s:
      PO_mor _ _ :=
   Build_PO_mor (LamPO_struct V r s).

Program Instance RecPO_struct (V:ipo) r :
    PO_mor_struct (a:= IP_proj (r ~> r) (BETA V))
                  (b:= IP_proj r (BETA V))
    (@Rec V r).
Next Obligation.
Proof.
  unfold Proper; red.
  intros; simpl;
  auto using betaS_Rec.
Qed.

Program Definition RecPO (V:ipo) r :
        PO_mor _ _  :=
     Build_PO_mor (RecPO_struct V r).

Program Instance ConstsPO_struct (t:TY) (C:Consts t)(V:ipo) :
     PO_mor_struct (a:= Term) (b:= IP_proj t (BETA V))
           (fun g => Const V C).
Next Obligation.
Proof.
  unfold Proper; red.
  constructor.
Qed.

Definition ConstsPO (t:TY)(C:Consts t) (V:ipo) :=
            Build_PO_mor (ConstsPO_struct t C V).

Program Instance BottomPO_struct (V:ipo) t :
    PO_mor_struct (a:=Term) (b:= IP_proj t (BETA V)) (fun g => Bottom V t).
Next Obligation.
Proof.
  unfold Proper; red;
  constructor.
Qed.

Definition BottomPO (V:ipo) t := Build_PO_mor (BottomPO_struct V t).
*)

End PCF.

(** PCF.BETA, the terms of PCF with beta reduction preorder,
    form a monad with
    - [return := VAR]
    - [bind = subst]
*)

Require Import monad_haskell.

Program Instance PCFPO_monad_h: Monad_struct (IO PCF.TY)
        (*fun V => PCFBETA V*) PCF.BETA := {
      weta  := PCF.VAR ;
      kleisli  :=  PCF.subst }.

(*Next Obligation.
   apply PCF.VAR. Defined.

Next Obligation.
  apply (PCF.subst X). Defined. *)

(*:= {
(*  weta V t v:= PCFVAR v*)
(*  kleisli V W f := fun t x => subst x f *)
}.*)

Next Obligation.
Proof.
  unfold Proper; red.
  intros. simpl.
  intros; apply PCF.subst_eq.
  auto.
Qed.
Next Obligation.
Proof.
  intros.
  apply PCF.subst_var.
Qed.

Next Obligation.
Proof.
  intros.
  apply PCF.subst_subst.
Qed.

Definition PCFPO_monad := Build_Monad PCFPO_monad_h.

(*
Program Instance PCF_monad_struct :
     Monad_struct (ITYPE PCF.TY) PCF.PCF := {
  weta := PCF.Var;
  kleisli := PCF.subst_
}.
Next Obligation.
Proof.
  unfold Proper; red.
  intros.
  apply PCF.subst_eq.
  auto.
Qed.
Next Obligation.
Proof.
  apply PCF.subst_var.
Qed.
Next Obligation.
Proof.
  apply PCF.subst_subst.
Qed.

Definition PCF_monad := Build_Monad PCF_monad_struct.
*)

(*
Program Instance PCF_monad_h :
         Monad_struct (IT PCF.TY) (fun V => PCF.PCF V).

*)


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_NCorder.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_doublereverse.
Require Import ProofCheckingEuclid.lemma_extensionunique.
Require Import ProofCheckingEuclid.lemma_right_triangle_NC.
Require Import ProofCheckingEuclid.lemma_right_triangle_leg_change.
Require Import ProofCheckingEuclid.lemma_right_triangle_symmetric.
Require Import ProofCheckingEuclid.lemma_s_conga.
Require Import ProofCheckingEuclid.lemma_s_midpoint.
Require Import ProofCheckingEuclid.lemma_s_onray.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_ABB.
Require Import ProofCheckingEuclid.lemma_s_onray_assert_bets_ABE.
Require Import ProofCheckingEuclid.lemma_s_right_triangle.
Require Import ProofCheckingEuclid.proposition_04.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

(*
	lemma_altitudebisectsbase_isosceles would be a more appropriate name,
	but the change in clarity is fairly minor, so I'm leaving it as is.
*)
Lemma lemma_altitudebisectsbase :
	forall A B M P,
	BetS A M B ->
	Cong A P B P ->
	RightTriangle A M P ->
	Midpoint A M B.
Proof.
	intros A B M P.
	intros BetS_A_M_B.
	intros Cong_AP_BP.
	intros RightTriangle_AMP.

	pose proof (lemma_congruenceflip _ _ _ _ Cong_AP_BP) as (Cong_PA_PB & _ & _).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_PA_PB) as (_ & Cong_AP_PB & _ ).

	pose proof (lemma_right_triangle_NC _ _ _ RightTriangle_AMP) as nCol_A_M_P.
	pose proof (lemma_NCdistinct _ _ _ nCol_A_M_P) as (_ & _ & neq_A_P & _ & _ & neq_P_A).
	pose proof (lemma_NCorder _ _ _ nCol_A_M_P) as (_ & _ & _ & nCol_A_P_M & _).

	pose proof (lemma_s_onray_assert_ABB _ _ neq_P_A) as OnRay_PA_A.

	pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_AMP) as RightTriangle_PMA.
	destruct RightTriangle_AMP as (C & BetS_A_M_C & Cong_AM_CM & Cong_AP_CP & neq_M_P).
	destruct RightTriangle_PMA as (Q & BetS_P_M_Q & Cong_PM_QM & Cong_PA_QA & _).

	pose proof (axiom_betweennesssymmetry _ _ _ BetS_A_M_C) as BetS_C_M_A.
	pose proof (lemma_betweennotequal _ _ _ BetS_P_M_Q) as (_ & neq_P_M & _).
	pose proof (lemma_s_onray _ _ _ _ BetS_A_M_C BetS_A_M_B) as OnRay_MC_B.
	pose proof (lemma_s_onray_assert_bets_ABE _ _ _ BetS_P_M_Q neq_P_M) as OnRay_PM_Q.

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AM_CM) as Cong_CM_AM.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_PM_QM) as Cong_QM_PM.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_QM_PM) as (_ & Cong_MQ_PM & _ ).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_MQ_PM) as Cong_PM_MQ.
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AP_CP) as Cong_CP_AP.
	pose proof (lemma_doublereverse _ _ _ _ Cong_PA_QA) as (Cong_AQ_AP & _).

	pose proof (lemma_s_right_triangle _ _ _ _ BetS_C_M_A Cong_CM_AM Cong_CP_AP neq_M_P) as RightTriangle_CMP.
	pose proof (lemma_right_triangle_symmetric _ _ _ RightTriangle_CMP) as RightTriangle_PMC.
	pose proof (lemma_right_triangle_leg_change _ _ _ _ RightTriangle_PMC OnRay_MC_B) as RightTriangle_PMB.

	pose proof (lemma_right_triangle_NC _ _ _ RightTriangle_PMB) as nCol_P_M_B.
	pose proof (lemma_NCdistinct _ _ _ nCol_P_M_B) as (_ & _ & neq_P_B & _ & _ & _).
	pose proof (lemma_s_onray_assert_ABB _ _ neq_P_B) as OnRay_PB_B.

	destruct RightTriangle_PMB as (E & BetS_P_M_E & Cong_PM_EM & Cong_PB_EB & _).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_PM_EM) as Cong_EM_PM.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_EM_PM Cong_PM_MQ) as Cong_EM_MQ.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_EM_MQ) as (_ & Cong_ME_MQ & _ ).
	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_ME_MQ) as Cong_MQ_ME.

	pose proof (lemma_extensionunique _ _ _ _ BetS_P_M_Q BetS_P_M_E Cong_MQ_ME) as eq_Q_E.
	assert (Cong P B Q B) as Cong_PB_QB by (rewrite eq_Q_E; exact Cong_PB_EB).
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_AP_PB Cong_PB_QB) as Cong_AP_QB.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_AQ_AP Cong_AP_QB) as Cong_AQ_QB.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AQ_QB) as (_ & _ & Cong_AQ_BQ).

	pose proof (cn_congruencereflexive P Q) as Cong_PQ_PQ.
	pose proof (cn_congruencereflexive P M) as Cong_PM_PM.

	pose proof (
		lemma_s_conga
		_ _ _ _ _ _
		_ _ _ _
		OnRay_PA_A
		OnRay_PM_Q
		OnRay_PB_B
		OnRay_PM_Q
		Cong_PA_PB
		Cong_PQ_PQ
		Cong_AQ_BQ
		nCol_A_P_M
	) as CongA_APM_BPM.

	pose proof (
		proposition_04
		_ _ _ _ _ _
		Cong_PA_PB
		Cong_PM_PM
		CongA_APM_BPM
	) as (Cong_AM_BM & _ & _).
	pose proof (lemma_congruenceflip _ _ _ _ Cong_AM_BM) as (_ & _ & Cong_AM_MB).

	pose proof (lemma_s_midpoint _ _ _ BetS_A_M_B Cong_AM_MB) as Midpoint_A_M_B.

	exact Midpoint_A_M_B.
Qed.

End Euclid.


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

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Require Import Coq.ZArith.ZArith.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Arith.
Require Import bbv.WordScope.

Definition word32 := word 32. (* 2^5 *)
Definition word64 := word 64. (* 2^6 *)
Definition word128 := word 128. (* 2^7 *)

Definition word_case {T : nat -> Type} (logsz : nat)
           (case32 : T 5)
           (case64 : T 6)
           (case128 : T 7)
           (default : forall k, T k)
  : T logsz
  := match logsz return T logsz with
     | 5 => case32
     | 6 => case64
     | 7 => case128
     | logsz' => default _
     end.

Definition wordT logsz := word_case (T:=fun _ => Set) logsz word32 word64 word128 (fun logsz => word (2^logsz)).

Definition word_case_dep {T : nat -> Set -> Type} (logsz : nat)
           (case32 : T 5 word32)
           (case64 : T 6 word64)
           (case128 : T 7 word128)
           (default : forall k, T k (word (2^k)))
  : T logsz (wordT logsz)
  := match logsz return T logsz (wordT logsz) with
     | 5 => case32
     | 6 => case64
     | 7 => case128
     | logsz' => default _
     end.

Definition ZToWord_gen {sz} (v : Z) : word sz := NToWord _ (Z.to_N v).
Definition wordToZ_gen {sz} (v : word sz) : Z := Z.of_N (wordToN v).

Definition ZToSignedWord_gen {sz} (v : Z) : word sz := Word.ZToWord _ v.
Definition signedWordToZ_gen {sz} (v : word sz) : Z := Word.wordToZ v.

Definition ZToWord32 : Z -> word32 := @ZToWord_gen _.
Definition word32ToZ : word32 -> Z := @wordToZ_gen _.
Definition ZToSignedWord32 : Z -> word32 := @ZToSignedWord_gen _.
Definition signedWord32ToZ : word32 -> Z := @signedWordToZ_gen _.
Definition wadd32 : word32 -> word32 -> word32 := @wplus _.
Definition wsub32 : word32 -> word32 -> word32 := @wminus _.
Definition wmul32 : word32 -> word32 -> word32 := @wmult _.
Definition wshl32 : word32 -> word32 -> word32 := @wordBin N.shiftl _.
Definition wshr32 : word32 -> word32 -> word32 := @wordBin N.shiftr _.
Definition wland32 : word32 -> word32 -> word32 := @wand _.
Definition wlor32 : word32 -> word32 -> word32 := @wor _.

Definition ZToWord64 : Z -> word64 := @ZToWord_gen _.
Definition word64ToZ : word64 -> Z := @wordToZ_gen _.
Definition ZToSignedWord64 : Z -> word64 := @ZToSignedWord_gen _.
Definition signedWord64ToZ : word64 -> Z := @signedWordToZ_gen _.
Definition wadd64 : word64 -> word64 -> word64 := @wplus _.
Definition wsub64 : word64 -> word64 -> word64 := @wminus _.
Definition wmul64 : word64 -> word64 -> word64 := @wmult _.
Definition wshl64 : word64 -> word64 -> word64 := @wordBin N.shiftl _.
Definition wshr64 : word64 -> word64 -> word64 := @wordBin N.shiftr _.
Definition wland64 : word64 -> word64 -> word64 := @wand _.
Definition wlor64 : word64 -> word64 -> word64 := @wor _.

Definition ZToWord128 : Z -> word128 := @ZToWord_gen _.
Definition word128ToZ : word128 -> Z := @wordToZ_gen _.
Definition ZToSignedWord128 : Z -> word128 := @ZToSignedWord_gen _.
Definition signedWord128ToZ : word128 -> Z := @signedWordToZ_gen _.
Definition wadd128 : word128 -> word128 -> word128 := @wplus _.
Definition wsub128 : word128 -> word128 -> word128 := @wminus _.
Definition wmul128 : word128 -> word128 -> word128 := @wmult _.
Definition wshl128 : word128 -> word128 -> word128 := @wordBin N.shiftl _.
Definition wshr128 : word128 -> word128 -> word128 := @wordBin N.shiftr _.
Definition wland128 : word128 -> word128 -> word128 := @wand _.
Definition wlor128 : word128 -> word128 -> word128 := @wor _.

Definition ZToWord {logsz}
  := word_case_dep (T:=fun _ word => Z -> word)
                   logsz ZToWord32 ZToWord64 ZToWord128 (fun _ => @ZToWord_gen _).
Definition wordToZ {logsz}
  := word_case_dep (T:=fun _ word => word -> Z)
                   logsz word32ToZ word64ToZ word128ToZ (fun _ => @wordToZ_gen _).
Definition ZToSignedWord {logsz}
  := word_case_dep (T:=fun _ word => Z -> word)
                   logsz ZToSignedWord32 ZToSignedWord64 ZToSignedWord128 (fun _ => @ZToSignedWord_gen _).
Definition signedWordToZ {logsz}
  := word_case_dep (T:=fun _ word => word -> Z)
                   logsz signedWord32ToZ signedWord64ToZ signedWord128ToZ (fun _ => @signedWordToZ_gen _).
Definition wadd {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wadd32 wadd64 wadd128 (fun _ => @wplus _).
Definition wsub {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wsub32 wsub64 wsub128 (fun _ => @wminus _).
Definition wmul {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wmul32 wmul64 wmul128 (fun _ => @wmult _).
Definition wshl {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wshl32 wshl64 wshl128 (fun _ => @wordBin N.shiftl _).
Definition wshr {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wshr32 wshr64 wshr128 (fun _ => @wordBin N.shiftr _).
Definition wland {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wland32 wland64 wland128 (fun _ => @wand _).
Definition wlor {logsz}
  := word_case_dep (T:=fun _ word => word -> word -> word)
                   logsz wlor32 wlor64 wlor128 (fun _ => @wor _).

Create HintDb fixed_size_constants discriminated.
Hint Unfold word32 word64 word128
     wadd wadd32 wadd64 wadd128
     wsub wsub32 wsub64 wsub128
     wmul wmul32 wmul64 wmul128
     wshl wshl32 wshl64 wshl128
     wshr wshr32 wshr64 wshr128
     wland wland32 wland64 wland128
     wlor wlor32 wlor64 wlor128 : fixed_size_constants.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import classical unit ideal maximal local.

Open Scope ring_scope.
Open Scope classical_set_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section multiplicative_set.
Definition mul_closed (R : comRingType) (S : {pred R}) :=
  forall (x y : R), x \in S -> y \in S -> x * y \in S.
End multiplicative_set.

Section localization.
Import GRing.
Open Scope quotient_scope.

Variables (R : comRingType) (S : {pred R}) (closedS : mul_closed S).

Structure tS := MkMulType { elem : R ; _ : elem \in S }.

Definition tS_eqMixin := @gen_eqMixin tS.
Canonical tS_eqType := EqType tS tS_eqMixin.

Definition tS_choiceMixin := @gen_choiceMixin tS.
Canonical tS_choiceType := ChoiceType tS tS_choiceMixin.

Coercion elem : tS >-> GRing.ComRing.sort.

Definition loc_equiv (p p' : R * tS) :=
  match p, p' with
  | (r1, s1), (r2, s2) => `[< exists t, t * (r1 * (s2 : R) - r2 * (s1 : R)) = 0 >]
  end.

Lemma ref_loc_equiv : reflexive loc_equiv.
Proof.
  move=> [r s]. apply/asboolP.
  exists 1. by rewrite subrr mul1r.
Qed.

Lemma sym_loc_equiv : symmetric loc_equiv.
Proof.
  move=> [r1 s1] [r2 s2] => //=. apply: asbool_equiv_eq. split; move=> [t Ht];
  exists t; apply: oppr_inj; rewrite oppr0 -mulNr -mulrN;
  by rewrite opprD addrC mulNr opprK.
Qed.

Lemma trans_loc_equiv : transitive loc_equiv.
Proof.
  move=> [r2 s2] [r1 s1] [r3 s3] /asboolP [t1 H1] /asboolP [t2 H2].
  apply/asboolP.
  exists ((s2 : R) * t1 * t2).
  rewrite mulrBr -[X in X - _]subr0.
  rewrite -(subrr (t1 * t2 * (s1 : R) * (s3 : R) * r2)).
  rewrite [in RHS]subrr opprD opprK addrA.
  rewrite -addrA -[X in _ + (_ - X)]mulrA [X in _ + (_ - X * _)]mulrC.
  rewrite -[X in _ + (_ - X)]mulrA -![X in _ + (X - _)]mulrA.
  rewrite -mulrBr [X in _ * (_ - X)]mulrCA -mulrBr.
  rewrite [X in _ * (_ - X)]mulrA [X in _ * (_ - X)]mulrC -mulrBr.
  rewrite [X in _ + _ * X]mulrCA [(s3 : R) * r2]mulrC [(s2 : R) * r3]mulrC.
  rewrite H2 !mulr0 addr0 -mulrA -mulrA mulrCA.
  rewrite -![X in _ - X]mulrA -mulrBr mulrCA -mulrBr [X in _ - X]mulrCA.
  rewrite [r1 * (s3 : R)]mulrC [X in X - _]mulrCA -mulrBr.
  rewrite mulrCA [X in _ * X]mulrCA [(s2 : R) * r1]mulrC [(s1 : R) * r2]mulrC.
  by rewrite H1 !mulr0.
Qed.

Lemma loc_equiv_is_equiv : equiv_class_of loc_equiv.
Proof.
  split.
  apply: ref_loc_equiv.
  apply: sym_loc_equiv.
  apply: trans_loc_equiv.
Qed.

Canonical loc_equiv_equiv := EquivRelPack loc_equiv_is_equiv.
Canonical loc_equiv_encModRel := @defaultEncModRel (prod_choiceType R tS_choiceType) loc_equiv.

Definition localize := {eq_quot loc_equiv}.

(* + and * defined on the localized set *)
Definition loc_add (l1 l2 : (R * tS)) : (R * tS) :=
  match l1, l2 with
  | (r1, MkMulType s1 H1), (r2, MkMulType s2 H2) =>
    (r1 * s2 + s2 * r1, @MkMulType (s1 * s2) (closedS H1 H2))
  end.

Definition loc_mul (l1 l2 : (R * tS)) : (R * tS) :=
  match l1, l2 with
  | (r1, MkMulType s1 H1), (r2, MkMulType s2 H2) =>
    (r1 * r2, @MkMulType (s1 * s2) (closedS H1 H2))
  end.

Definition add_localized := lift_op2 localize loc_add.
Definition mul_localized := lift_op2 localize loc_mul.
End localization.


(* ############################################################ *)
(*                                                              *)
(*               Language definition for STLC 1/2               *)
(*                                                              *)
(* ############################################################ *)

(* Starting point: https://github.com/TiarkRompf/minidot/blob/master/dev2015/nano2.v *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

(* ############################################################ *)
(* Definitions                                                  *)
(* ############################################################ *)

(* ### Syntax ### *)

Definition id := nat.

Inductive class : Type :=
  | First  : class
  | Second : class
.

(* types *)
Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> class -> ty -> ty
.

(* variables: 1st or 2nd class, using DeBrujin levels *)
Inductive var : Type :=
  | V : class -> id -> var
.

(* terms *)
Inductive tm : Type :=
  | ttrue  : tm
  | tfalse : tm
  | tvar   : var -> tm
  | tapp   : tm -> tm -> tm     (* f(x) *)
  | tabs   : class -> tm -> tm  (* \f x.y *)
.

(* environments, split according to 1st/2nd class *)
Inductive env (X: Type) :=
  | Def : list X -> list X -> nat -> env X.

(* values *)
Inductive vl : Type :=
  | vbool : bool -> vl
  | vabs  : env vl -> class -> tm -> vl
.

Definition venv := env vl.  (* value environments *)
Definition tenv := env ty.  (* type environments  *)

Hint Unfold venv.
Hint Unfold tenv.

(* environment lookup *)
Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Definition lookup {X : Type} (n : var) (l : env X) : option X :=
  match l with
    | Def l1 l2 m =>
         match n with
           | V First idx  => index idx l1
           | V Second idx => if ble_nat m idx then index idx l2 else None
         end
   end
.

(* restrict visible bindings in environment *)
Definition sanitize_any {X : Type} (l : env X) (n:nat): env X :=
  match l with
    | Def l1 l2 _ => Def X l1 l2 n
  end.

Definition sanitize_env {X : Type} (c : class) (l : env X) : env X :=
  match c,l  with
    | First, Def _ l2 _ => sanitize_any l (length l2)
    | Second, _ => l
  end.

(* add new binding to environment *)
Definition expand_env {X : Type} (l : env X) (x : X) (c : class) : (env X) :=
match l with
| Def l1 l2 m =>
   match c with
   | First => Def X (x::l1) l2 m
   | Second => Def X l1 (x::l2) m
   end
end
.

(* ### Type Assignment ### *)

Inductive has_type : tenv -> tm -> class -> ty -> Prop :=
| t_true: forall n env,
           has_type env ttrue n TBool
| t_false: forall n env,
           has_type env tfalse n TBool
| t_var: forall n x env T1,
           lookup x (sanitize_env n env) = Some T1 ->
           has_type env (tvar x) n T1
| t_app: forall m n env f x T1 T2,
           has_type env f Second (TFun T1 m T2) ->
           has_type env x m T1 ->
           has_type env (tapp f x) n T2
| t_abs: forall m n env y T1 T2,
           has_type (expand_env (expand_env (sanitize_env n env) (TFun T1 m T2) Second) T1 m) y First T2 ->
           has_type env (tabs m y) n (TFun T1 m T2)
.

Definition get_inv_idx {X : Type} (env : env X) :=
match env with
| Def l1 l2 idx => idx
end
.

(* ### Operational Semantics ### *)

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v
*)

Fixpoint teval(k: nat)(env: venv)(t: tm)(n: class){struct k}: option (option vl) :=
  match k with
    | 0 => None
    | S k' =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (lookup x (sanitize_env n env))
        | tabs m y   => Some (Some (vabs (sanitize_env n env) m y))
        | tapp ef ex   =>
           match teval k' env ef Second with
             | None => None
             | Some None => Some None
             | Some (Some (vbool _)) => Some None
             | Some (Some (vabs env2 m ey)) =>
                match teval k' env ex m with
                  | None => None
                  | Some None => Some None
                  | Some (Some vx) =>
                       teval k' (expand_env (expand_env env2 (vabs env2 m ey) Second) vx m) ey First
                end
          end
      end
  end.

(* ############################################################ *)
(* Proofs                                                       *)
(* ############################################################ *)

(* ### Some helper lemmas ### *)

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.

Hint Constructors option.
Hint Constructors list.
Hint Constructors env.

Hint Unfold index.
Hint Unfold length.
Hint Unfold expand_env.
Hint Unfold lookup.
Hint Unfold index.
Hint Unfold sanitize_env.
Hint Unfold sanitize_any.

Hint Resolve ex_intro.

Definition length_env {X : Type} (c : class) (env : env X): nat :=
match env, c with
| Def l1 l2 n, First => length l1
| Def l1 l2 n, Second => length l2
end
.

Definition get_class (x : var): class :=
match x with
| V c _ => c
end
.

Definition get_idx (x : var): nat :=
match x with
| V _ n => n
end
.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Hint Immediate index_max.

Lemma lookup_max : forall X vs x (T: X),
                       lookup x vs = Some T ->
                       get_idx x < length_env (get_class x) vs.
Proof.
  intros X vs; destruct vs as [l1 l2 n].
  intros x T H.
  destruct x. destruct c; simpl.
  Case "VFst". inversion H; eauto.
  Case "VSnd". inversion H.
    destruct (ble_nat n i); inversion H1; eauto.
Qed.


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

Require Import Arith.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

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 eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.
Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
:= match mem_arg0, mem_arg1 with
  | x, Nil => false
  | x, Cons y z => orb (eqb x y) (mem z x)
  end.

Theorem goal36 : forall (x : natural) (y : lst) (z : lst), mem y x = true -> mem (append y z) x = true.
Proof.
   intros.
   induction y.
   - simpl. destruct H.
Admitted.
      (* + auto.
      + apply IHy in H. auto.
   - contradiction.
Qed. *)

Theorem goal37 : forall (x : natural) (y : lst) (z : lst), mem z x = true -> mem (append y z) x = true.
Proof.
   intros.
   induction y.
   - simpl. rewrite IHy. apply Bool.orb_true_r.
   - auto.
Qed.

Theorem theorem0 : forall (x : natural) (y : lst) (z : lst), mem y x = true \/ mem z x = true -> mem (append y z) x = true.
Proof.
   intros.
   destruct H.
   -
   apply goal36. assumption.
   -
   lfind. Admitted.


Inductive le (n:nat) : nat -> Prop :=
  | le_n : le n n
  | le_S : forall m:nat, le n m -> le n (S m).

Check le.
Check le_ind.

Lemma le_n_S : forall n m : nat, le n m -> le (S n) (S m).
intros n m n_le_m.
elim n_le_m.
apply le_n; trivial.
intros; apply le_S;trivial.
Restart.
Hint Resolve le_n le_S.
simple induction 1;auto.

Qed.

Print le_n_S.

Lemma tricky : forall n : nat, le n 0 -> n = 0.
intros n H; inversion_clear H.
trivial.
Qed.


Require Import BenB.

Variable X: R -> Prop.
Variable Y: R -> Prop.

Theorem getallen_005 :
  (forall t:R, (exists u:R, u<=t-5 /\ Y u) -> X t)
->
  (forall t:R, Y t -> X (t+5)).
Proof.
imp_i a1.
all_i a.
imp_i a2.
imp_e (exists u:R, u <= (a+5)-5 /\ Y u).
all_e (forall t:R, (exists u:R, u <= t- 5 /\ Y u) -> X (t)) (a+5).
hyp a1.
exi_i a.
con_i.
lin_solve.
hyp a2.
Qed.


Require Export List.
Require Export Util.

Module Type RED_LANG.

  (** The languages of terms, values, redex, and context, the empty context is also needed. *)
  Parameters term value redex elem_context : Set.
  Definition context := list elem_context.
  Definition empty : context := nil.

  (** The values and redexes are sublanguages of terms *)
  Parameter value_to_term : value -> term.
  Parameter redex_to_term : redex -> term.
  Axiom value_to_term_injective : forall v v' : value, value_to_term v = value_to_term v' -> v = v'.
  Axiom redex_to_term_injective : forall r r' : redex, redex_to_term r = redex_to_term r' -> r = r'.

  (** The main functions of reduction semantics, defining plugging terms into contexts and
      composing contexts, effectively defining reduction semantics, and some properties. *)
  Definition compose (c0 c1 : context) : context := app c0 c1.
  Parameter atom_plug : term -> elem_context -> term.
  Definition plug (t : term) (c : context) : term := fold_left atom_plug c t.

  (** The other main function of reduction semantics -- contraction of a redex into a term *)
  Parameter contract : redex -> option term.

  Definition only_empty (t : term) : Prop := forall t' c, plug t' c = t -> c = empty.
  Definition only_trivial (t : term) : Prop := forall t' c, plug t' c = t -> c = empty \/ exists v, t' = value_to_term v.

  Axiom value_trivial : forall v : value, only_trivial (value_to_term v).
  Axiom redex_trivial : forall r : redex, only_trivial (redex_to_term r).
  Axiom value_redex : forall (v : value) (r : redex), value_to_term v <> redex_to_term r.
  Axiom trivial_val_red : forall t : term, only_trivial t ->
    (exists v : value, t = value_to_term v) \/ (exists r : redex, t = redex_to_term r).

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_term: term -> elem_context -> interm_dec.

  Definition decomp_to_term (d : decomp) : term :=
  match d with
    | d_val v => value_to_term v
    | d_red r c0 => plug (redex_to_term r) c0
  end.

End RED_LANG.

Module Type LANG_PROP (R : RED_LANG).

  Axiom plug_empty : forall t, R.plug t R.empty = t.
  Axiom compose_empty : forall c : R.context, c = R.compose c R.empty.
  Axiom plug_compose : forall (c c' : R.context) (t : R.term), R.plug t (R.compose c c') = R.plug (R.plug t c) c'.

End LANG_PROP.

Module Type RED_REF_LANG.

  Declare Module R : RED_LANG.

  Parameter dec_term : R.term -> R.interm_dec.
  Parameter dec_context : R.elem_context -> R.value -> R.interm_dec.

  Inductive subterm_one_step : R.term -> R.term -> Prop :=
  | st_1 : forall t t0 ec (DECT : t = R.atom_plug t0 ec), subterm_one_step t0 t.
  Axiom wf_st1 : well_founded subterm_one_step.

  Definition subterm_order := clos_trans_n1 R.term subterm_one_step.
  Notation " a <| b " := (subterm_order a b) (at level 40).
  Definition wf_sto : well_founded subterm_order := wf_clos_trans_r _ _ wf_st1.

  Parameter ec_order : R.elem_context -> R.elem_context -> Prop.
  Notation " a <: b " := (ec_order a b) (at level 40).
  Axiom wf_eco : well_founded ec_order.

  Axiom dec_term_red_empty  : forall t r, dec_term t = R.in_red r -> R.only_empty t.
  Axiom dec_term_val_empty  : forall t v, dec_term t = R.in_val v -> R.only_empty t.
  Axiom dec_term_term_top   : forall t t' ec, dec_term t = R.in_term t' ec -> forall ec', ~ec <: ec'.
  Axiom dec_context_red_bot : forall ec v r, dec_context ec v = R.in_red r -> forall ec', ~ ec' <: ec.
  Axiom dec_context_val_bot : forall ec v v', dec_context ec v = R.in_val v' -> forall ec', ~ ec' <: ec.
  Axiom dec_context_term_next : forall ec v t ec', dec_context ec v = R.in_term t ec' -> ec' <: ec /\ forall ec'', ec'' <: ec -> ~ ec' <: ec''.

  Axiom dec_term_correct : forall t, match dec_term t with
    | R.in_red r => R.redex_to_term r = t
    | R.in_val v => R.value_to_term v = t
    | R.in_term t' ec => R.atom_plug t' ec = t
    end.
  Axiom dec_context_correct : forall ec v, match dec_context ec v with
    | R.in_red r => R.redex_to_term r = R.atom_plug (R.value_to_term v) ec
    | R.in_val v' => R.value_to_term v' = R.atom_plug (R.value_to_term v) ec
    | R.in_term t ec' => R.atom_plug t ec' = R.atom_plug (R.value_to_term v) ec
    end.

  Axiom ec_order_antisym : forall ec ec0, ec <: ec0 -> ~ ec0 <: ec.
  Axiom dec_ec_ord : forall t0 t1 ec0 ec1, R.atom_plug t0 ec0 = R.atom_plug t1 ec1 -> ec0 <: ec1 \/ ec1 <: ec0 \/ (t0 = t1 /\ ec0 = ec1).
  Axiom elem_context_det : forall t0 t1 ec0 ec1, ec0 <: ec1 -> R.atom_plug t0 ec0 = R.atom_plug t1 ec1 ->
    exists v, t1 = R.value_to_term v.

End RED_REF_LANG.

  Ltac prove_st_wf := intro a; constructor; induction a; (intros y H;
    inversion H as [t t0 ec DECT]; subst; destruct ec; inversion DECT; subst; constructor; auto).
  Ltac prove_ec_wf := intro a; destruct a; repeat (constructor; intros ec T; destruct ec; inversion T; subst; clear T).

Module Type ABSTRACT_MACHINE.

  Parameters term value configuration : Set.
  Parameter c_init : term -> configuration.
  Parameter c_final : value -> configuration.
  Parameter transition : configuration -> configuration -> Prop.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

End ABSTRACT_MACHINE.

Module Type SOS_SEM.

  Parameters term value : Set.
  Parameter step : term -> term -> Prop.
  Parameter value_to_term : value -> term.

  Inductive step_close : term -> value -> Prop :=
  | s_val  : forall v, step_close (value_to_term v) v
  | s_step : forall t t0 v, step t t0 -> step_close t0 v -> step_close t v.

End SOS_SEM.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Permutation Arith Omega.

Require Import utils.

Set Implicit Arguments.

(** * Intuionistic Linear Logic *)

Definition ill_vars := nat.

Inductive ill_conn := ll_with | ll_limp | ll_times | ll_plus.
Inductive ill_cst := ll_one | ll_bot | ll_top.

Inductive ill_form : Set :=
  | ill_var  : ill_vars -> ill_form
  | ill_zero : ill_cst  -> ill_form
  | ill_bang : ill_form -> ill_form
  | ill_bin  : ill_conn -> ill_form -> ill_form -> ill_form.

Fact ill_form_eq_dec (f g : ill_form) : { f = g } + { f <> g }.
Proof.
  decide equality.
  + apply eq_nat_dec.
  + decide equality.
  + decide equality.
Qed.

(* Symbols for cut&paste ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ *)

Notation "⟙" := (ill_zero ll_top).
Notation "⟘" := (ill_zero ll_bot).
Notation 𝝐 := (ill_zero ll_one).

Infix "&" := (ill_bin ll_with) (at level 50, only parsing).
Infix "﹠" := (ill_bin ll_with) (at level 50).

Infix "⊗" := (ill_bin ll_times) (at level 50).
Infix "⊕" := (ill_bin ll_plus) (at level 50).

Infix "-o" := (ill_bin ll_limp) (at level 51, right associativity).

(* Infix "⊸" := (ill_bin ll_limp) (at level 51, right associativity). *)

Notation "'!' x" := (ill_bang x) (at level 52).

Definition ill_lbang := map (fun x => !x).

Notation "'!l' x" := (ill_lbang x) (at level 60, only parsing).

Notation "‼ x" := (ill_lbang x) (at level 52).

Notation "£" := ill_var.

Notation "∅" := nil (only parsing).


Require Import Flocq.Core.Fcore_defs.
Require Import Gappa_common.
Require Import Gappa_pred_bnd.

Definition rewrite_ne_helper (xi : FF) (n : Z) :=
 Flt2 (upper xi) (Float2 n 0) || Flt2 (Float2 n 0) (lower xi).

Lemma rewrite_ne :
  forall x xi n, BND x xi ->
  rewrite_ne_helper xi n = true ->
  (x <> Float1 n)%R.
Proof.
intros x xi n Hx Hb.
rewrite <- (Rmult_1_r (Float1 n)).
change (x <> F2R (Float radix2 n 0)).
unfold Float1.
destruct (orb_prop _ _ Hb) as [H|H] ; clear Hb.
generalize (Flt2_correct _ _ H). clear H. intro H.
apply Rlt_not_eq.
apply Rle_lt_trans with (1 := proj2 Hx).
exact H.
generalize (Flt2_correct _ _ H). clear H. intro H.
apply Rgt_not_eq.
unfold Rgt.
apply Rlt_le_trans with (2 := proj1 Hx).
exact H.
Qed.

Definition rewrite_lt_helper (xi : FF) (n : Z) :=
 Flt2 (upper xi) (Float2 n 0).

Lemma rewrite_lt :
  forall x xi n, BND x xi ->
  rewrite_lt_helper xi n = true ->
  (x < Float1 n)%R.
Proof.
intros x xi n Hx Hb.
rewrite <- (Rmult_1_r (Float1 n)).
generalize (Flt2_correct _ _ Hb). clear Hb. intro H.
apply Rle_lt_trans with (1 := proj2 Hx).
exact H.
Qed.

Definition rewrite_le_helper (xi : FF) (n : Z) :=
 Fle2 (upper xi) (Float2 n 0).

Lemma rewrite_le :
  forall x xi n, BND x xi ->
  rewrite_le_helper xi n = true ->
  (x <= Float1 n)%R.
Proof.
intros x xi n Hx Hb.
rewrite <- (Rmult_1_r (Float1 n)).
generalize (Fle2_correct _ _ Hb). clear Hb. intro H.
apply Rle_trans with (1 := proj2 Hx).
exact H.
Qed.

Definition rewrite_gt_helper (xi : FF) (n : Z) :=
 Flt2 (Float2 n 0) (lower xi).

Lemma rewrite_gt :
  forall x xi n, BND x xi ->
  rewrite_gt_helper xi n = true ->
  (x > Float1 n)%R.
Proof.
intros x xi n Hx Hb.
rewrite <- (Rmult_1_r (Float1 n)).
generalize (Flt2_correct _ _ Hb). clear Hb. intro H.
unfold Rgt.
apply Rlt_le_trans with (2 := proj1 Hx).
exact H.
Qed.

Definition rewrite_ge_helper (xi : FF) (n : Z) :=
 Fle2 (Float2 n 0) (lower xi).

Lemma rewrite_ge :
  forall x xi n, BND x xi ->
  rewrite_ge_helper xi n = true ->
  (x >= Float1 n)%R.
Proof.
intros x xi n Hx Hb.
rewrite <- (Rmult_1_r (Float1 n)).
generalize (Fle2_correct _ _ Hb). clear Hb. intro H.
apply Rle_ge.
apply Rle_trans with (2 := proj1 Hx).
exact H.
Qed.

Definition rewrite_lt0_helper (xi : FF) :=
 Fneg (upper xi).

Lemma rewrite_lt0 :
 forall x : R, forall xi : FF, BND x xi ->
 rewrite_lt0_helper xi = true ->
 (x < 0)%R.
Proof.
intros x xi Hx Hb.
generalize (Fneg_correct _ Hb). clear Hb. intro H.
apply Rle_lt_trans with (1 := proj2 Hx).
exact H.
Qed.

Definition rewrite_le0_helper (xi : FF) :=
 Fneg0 (upper xi).

Lemma rewrite_le0 :
 forall x : R, forall xi : FF, BND x xi ->
 rewrite_le0_helper xi = true ->
 (x <= 0)%R.
Proof.
intros x xi Hx Hb.
generalize (Fneg0_correct _ Hb). clear Hb. intro H.
apply Rle_trans with (1 := proj2 Hx).
exact H.
Qed.

Definition rewrite_gt0_helper (xi : FF) :=
 Fpos (lower xi).

Lemma rewrite_gt0 :
 forall x : R, forall xi : FF, BND x xi ->
 rewrite_gt0_helper xi = true ->
 (x > 0)%R.
Proof.
intros x xi Hx Hb.
generalize (Fpos_correct _ Hb). clear Hb. intro H.
unfold Rgt.
apply Rlt_le_trans with (2 := proj1 Hx).
exact H.
Qed.

Definition rewrite_ge0_helper (xi : FF) :=
 Fpos0 (lower xi).

Lemma rewrite_ge0 :
 forall x : R, forall xi : FF, BND x xi ->
 rewrite_ge0_helper xi = true ->
 (x >= 0)%R.
Proof.
intros x xi Hx Hb.
generalize (Fpos0_correct _ Hb). clear Hb. intro H.
apply Rle_ge.
apply Rle_trans with (2 := proj1 Hx).
exact H.
Qed.