Require Import QArith micromega.Lia.

Local Open Scope Q_scope.

Definition alphaQ_high w : Q := (633/1024) ^ w.

Definition alphaQ (w : Z) : Q :=
  if (w <=? 66)%Z then
  match w with
  | 0%Z => 1 | 1%Z => 1 | 2%Z => 689491/2^20 | 3%Z => 779411/2^21
  | 4%Z => 880833/2^22 | 5%Z => 165219/2^20 | 6%Z => 97723/2^20 | 7%Z => 882313/2^24
  | 8%Z => 306733/2^23 | 9%Z => 92045/2^22 | 10%Z => 439213/2^25 | 11%Z => 281681/2^25
  | 12%Z => 689007/2^27 | 13%Z => 824303/2^28 | 14%Z => 257817/2^27 | 15%Z => 634229/2^29
  | 16%Z => 386245/2^29 | 17%Z => 942951/2^31 | 18%Z => 583433/2^31 | 19%Z => 713653/2^32
  | 20%Z => 432891/2^32 | 21%Z => 133569/2^31 | 22%Z => 328293/2^33 | 23%Z => 800421/2^35
  | 24%Z => 489233/2^35 | 25%Z => 604059/2^36 | 26%Z => 738889/2^37 | 27%Z => 112215/2^35
  | 28%Z => 276775/2^37 | 29%Z => 84973/2^36 | 30%Z => 829297/2^40 | 31%Z => 253443/2^39
  | 32%Z => 625405/2^41 | 33%Z => 95625/2^39 | 34%Z => 465055/2^42 | 35%Z => 286567/2^42
  | 36%Z => 175951/2^42 | 37%Z => 858637/2^45 | 38%Z => 65647/2^42 | 39%Z => 40469/2^42
  | 40%Z => 24751/2^42 | 41%Z => 240917/2^46 | 42%Z => 593411/2^48 | 43%Z => 364337/2^48
  | 44%Z => 889015/2^50 | 45%Z => 543791/2^50 | 46%Z => 41899/2^47 | 47%Z => 205005/2^50
  | 48%Z => 997791/2^53 | 49%Z => 307191/2^52 | 50%Z => 754423/2^54 | 51%Z => 57527/2^51
  | 52%Z => 281515/2^54 | 53%Z => 694073/2^56 | 54%Z => 212249/2^55 | 55%Z => 258273/2^56
  | 56%Z => 636093/2^58 | 57%Z => 781081/2^59 | 58%Z => 952959/2^60 | 59%Z => 291475/2^59
  | 60%Z => 718599/2^61 | 61%Z => 878997/2^62 | 62%Z => 534821/2^62 | 63%Z => 329285/2^62
  | 64%Z => 404341/2^63 | 65%Z => 986633/2^65 | 66%Z => 603553/2^65 | _ => 0 end
  else alphaQ_high w.

Definition alphaQ_nat_high (w : nat) : Q := (633/1024) ^ (Z.of_nat w).

Definition alphaQ_nat (w : nat) : Q :=
  match w with
  | 0%nat => 1 | 1%nat => 1 | 2%nat => 689491/2^20 | 3%nat => 779411/2^21
  | 4%nat => 880833/2^22 | 5%nat => 165219/2^20 | 6%nat => 97723/2^20 | 7%nat => 882313/2^24
  | 8%nat => 306733/2^23 | 9%nat => 92045/2^22 | 10%nat => 439213/2^25 | 11%nat => 281681/2^25
  | 12%nat => 689007/2^27 | 13%nat => 824303/2^28 | 14%nat => 257817/2^27 | 15%nat => 634229/2^29
  | 16%nat => 386245/2^29 | 17%nat => 942951/2^31 | 18%nat => 583433/2^31 | 19%nat => 713653/2^32
  | 20%nat => 432891/2^32 | 21%nat => 133569/2^31 | 22%nat => 328293/2^33 | 23%nat => 800421/2^35
  | 24%nat => 489233/2^35 | 25%nat => 604059/2^36 | 26%nat => 738889/2^37 | 27%nat => 112215/2^35
  | 28%nat => 276775/2^37 | 29%nat => 84973/2^36 | 30%nat => 829297/2^40 | 31%nat => 253443/2^39
  | 32%nat => 625405/2^41 | 33%nat => 95625/2^39 | 34%nat => 465055/2^42 | 35%nat => 286567/2^42
  | 36%nat => 175951/2^42 | 37%nat => 858637/2^45 | 38%nat => 65647/2^42 | 39%nat => 40469/2^42
  | 40%nat => 24751/2^42 | 41%nat => 240917/2^46 | 42%nat => 593411/2^48 | 43%nat => 364337/2^48
  | 44%nat => 889015/2^50 | 45%nat => 543791/2^50 | 46%nat => 41899/2^47 | 47%nat => 205005/2^50
  | 48%nat => 997791/2^53 | 49%nat => 307191/2^52 | 50%nat => 754423/2^54 | 51%nat => 57527/2^51
  | 52%nat => 281515/2^54 | 53%nat => 694073/2^56 | 54%nat => 212249/2^55 | 55%nat => 258273/2^56
  | 56%nat => 636093/2^58 | 57%nat => 781081/2^59 | 58%nat => 952959/2^60 | 59%nat => 291475/2^59
  | 60%nat => 718599/2^61 | 61%nat => 878997/2^62 | 62%nat => 534821/2^62 | 63%nat => 329285/2^62
  | 64%nat => 404341/2^63 | 65%nat => 986633/2^65 | 66%nat => 603553/2^65 | _ => alphaQ_nat_high w
  end.

Lemma alphaQ_nat_67 w : (67 <= w)%nat -> alphaQ_nat w = alphaQ_nat_high w.
Proof. intros; repeat (destruct w; [lia|]). reflexivity. Qed.

Lemma alphaQ31 i : (31 <= i < 67)%Z -> ((alphaQ i) ^ 49 < 1 / (2 ^ ((34 * i - 23))))%Q.
Proof.
  intros.
  repeat match goal with
         | [ H: (?a <= ?b < ?a)%Z |- _ ] => fail 1
         | [ H : (?a <= ?b < ?c)%Z |- _ ] => destruct (Z.eq_dec a b) as [E|E]; [subst; reflexivity|
                                                                             let H2 := fresh in assert (H2 : (a + 1 <= b < c)%Z) by lia; clear E; simpl in H2; clear H]
         end.
  lia.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


From stdpp Require Import numbers list.

Fixpoint rangeReversed (n : nat) : list nat :=
  match n with
  | 0 => []
  | S n => n :: rangeReversed n
  end.

(* generates [0, 1, 2, ..., n - 1] *)
Definition range (n : nat) := reverse (rangeReversed n).

(* generates [left, left + 1, left + 2, ... right - 1, right] *)
Definition range2 (left right : nat) := map (fun x => x + left) (range (right - left + 1)).

Lemma rangeZero : range 0 = [].
Proof. easy. Qed.

Lemma rangeOne : range 1 = [0].
Proof. easy. Qed.

Lemma rangeSucc (n : nat) : range (S n) = range n ++ [n].
Proof.
  induction n; try easy; unfold range; simpl; rewrite reverse_cons; reflexivity.
Qed.

Lemma range2LeftLeft (left : nat) : range2 left left = [left].
Proof.
  unfold range2.
  assert (H : left - left + 1 = 1). { lia. }
  rewrite H, rangeOne, map_cons. easy.
Qed.

Lemma range2LeftSucc (left : nat) : range2 left (S left) = [left; S left].
Proof.
  unfold range2.
  assert (H : S left - left + 1 = 2). { lia. }
  rewrite H, rangeSucc, map_app, rangeOne. easy.
Qed.

Lemma range2LeftAdd (left delta : nat) : range2 left (S (left + delta)) = range2 left (left + delta) ++ [S (left + delta)].
Proof.
  unfold range2.
  assert (H : S (left + delta) - left + 1 = S (S delta)). { lia. }
  assert (H' : left + delta - left + 1 = S delta). { lia. }
  rewrite H, H', ?rangeSucc, ?map_app. simpl. rewrite Nat.add_comm. reflexivity.
Qed.


(* Julien Narboux *)
(* Formalization of *)
(* Tarski's axiomatic *)

Require Export Ch07_midpoint.

Unset Regular Subst Tactic.

Definition Per := fun A B C =>
  exists C', is_midpoint B C C' /\ Cong A C A C'.

Lemma l8_2 : forall A B C, Per A B C -> Per C B A.
Proof.
intros.
unfold Per in *.
DecompExAnd H C'.
assert (exists A', is_midpoint B A A').
apply symmetric_point_construction.
DecompEx H A'.
assert (Cong C' A' C A).
eapply l7_13;eauto.
assert (Cong A C' A' C).
eapply l7_13;eauto.
eapply l7_2.
eauto.
eauto.
exists A'.
intuition.
unfold is_midpoint in *;intuition.
eapply cong_transitivity with (C:=A) (D:=C').
sTarski.
sTarski.
Qed.

Hint Resolve l8_2 : Perp.

Ltac Perp := eauto with Perp.

Lemma l8_3 : forall A B C A',
 Per A B C -> A<>B -> Col B A A' -> Per A' B C.
Proof.
intros.
unfold Per in H.
DecompExAnd H C'.
unfold Per.
exists C'.
intuition.
eapply (l4_17).
unfold not;apply H0.
eauto with Col.
auto.
unfold is_midpoint in H3;intuition.
Qed.

Lemma l8_4 : forall A B C C',
  Per A B C -> is_midpoint B C C' -> Per A B C'.
Proof.
intros.
unfold Per in H.
DecompExAnd H C''.
assert (C' =C'').
eapply symmetric_point_unicity.
apply H0.
apply H2.
smart_subst C''.
unfold Per.
exists C.
intuition.
Qed.

Lemma l8_5 : forall A B, Per A B B.
intros.
unfold Per.
exists B;intuition.
Qed.

Hint Resolve l8_5 : Perp.

Lemma l8_6 : forall A B C A',
  Per A B C -> Per A' B C -> Bet A C A' -> B=C.
intros.
unfold Per in *.
DecompExAnd H C'.
suppose (Cong A' C A' C').
assert (C=C').
eapply l4_19.
2:apply H4.
2:apply H.
assumption.
subst C'.
eapply l7_3.
assumption.
DecompExAnd H0 C''.
assert (Cong C C C' C'').
eapply l7_13.
apply l7_2.
apply H3.
apply l7_2.
apply H2.
treat_equalities.
auto.
Qed.

Ltac let_symmetric C P A :=
let id1:=fresh in (assert (id1:(exists A', is_midpoint P A A'));
[apply symmetric_point_construction|DecompEx id1 C]).

Lemma l8_7 : forall A B C, Per A B C -> Per A C B -> B=C.
Proof.
intros.
unfold Per in H.
DecompExAnd H C'.
let_symmetric A' C A.
cases_equality B C.
auto.
assert (Per C' C A).
eapply (l8_3 ).
eapply l8_2.
apply H0.
assumption.
unfold is_midpoint in H2;intuition;Col.
assert (Cong A C' A' C').
unfold Per in H4.
DecompExAnd H4 Z.
assert (A'=Z).
eapply symmetric_point_unicity;eauto.
subst Z.
sTarski.
unfold is_midpoint in *;intuition.
assert (Cong A' C A' C').
eapply cong_transitivity with (C:=A) (D:=C');sTarski.
eapply cong_transitivity with (C:=A) (D:=C);sTarski.
assert (Per A' B C).
unfold Per.
exists C'.
unfold is_midpoint;intuition.
eapply l8_6.
apply H9.
unfold Per.
exists C'.
unfold is_midpoint;intuition.
apply H3.
Between.
Qed.

Hint Resolve l8_7 : Perp.

Lemma l8_8 : forall A B, Per A B A -> A=B.
Proof with Perp.
intros.
eapply l8_7...
Qed.

Lemma l8_9 : forall A B C, Per A B C -> Col A B C -> A=B \/ C=B.
Proof with Perp.
intros.
cases_equality A B.
left;auto.
right.
assert (Per C B C).
eapply l8_3...
eauto with Col.
Perp.
Qed.

Lemma l8_10 : forall A B C A' B' C',
  Per A B C -> Cong_3 A B C A' B' C' -> Per A' B' C'.
Proof with Perp.
intros.
cases_equality B C.
unfold Cong_3 in H0;intuition.
treat_equalities...
assert (B'<>C').
unfold Cong_3 in H0;intuition.
treat_equalities...
unfold Per in H.
DecompExAnd H D.
let_symmetric D' B' C'.
assert (OFSC C B D A C' B' D' A').
unfold OFSC,Cong_3,is_midpoint in *;intuition.
eapply cong_transitivity with (C:=B) (D:=C);sTarski.
eapply cong_transitivity with (C:=B') (D:=C');sTarski.
assert (Cong D A D' A').
eapply five_segments_with_def;eauto.
unfold OFSC,Cong_3,is_midpoint in *;intuition.
clean_duplicated_hyps.
assert (Cong A' C' A' D').
eapply cong_transitivity with (C:=A) (D:=C);sTarski.
eapply cong_transitivity with (C:=A) (D:=D);sTarski.
unfold Per.
exists D'.
intuition.
unfold is_midpoint...
Qed.

Definition Perp_in := fun X A B C D =>
   A<>B /\ C<>D /\ Col X A B /\ Col X C D /\
   (forall U V,  Col U A B -> Col V C D -> Per U X V).

Definition Perp := fun A B C D => exists X, Perp_in X A B C D.

Lemma l8_12 : forall A B C D X, Perp_in X A B C D ->  Perp_in X C D A B.
Proof with Perp.
unfold Perp_in.
intros;intuition.
Qed.

Lemma l8_13_2 : forall A B C D X,
   A <> B -> C <> D -> Col X A B -> Col X C D ->
  (exists U, exists V :Point, Col U A B /\ Col V C D /\ U<>X /\ V<>X /\ Per U X V) ->
  Perp_in X A B C D.
Proof.
intros.
DecompEx H3 U.
DecompEx H4 V.
decompose [and] H3;clear H3.
unfold Perp_in.
repeat split;auto.
intros.
assert (Per U0 X V).
eapply l8_3; try apply H9;auto.
assert (Col A X U0).
eapply col_transitivity_1;Col.
assert (Col B U U0).
eapply col_transitivity_1;Col.
assert (Col A U X).
eapply col_transitivity_1;Col.
assert (Col B U X).
eapply col_transitivity_1;Col.
cases_equality B U.
smart_subst U.
assert (Col B X U0).
eapply col_transitivity_2;Col.
Col.
assert (Col U U0 X).
eapply col_transitivity_2;Col.
Col.
apply l8_2.
eapply  l8_3.
apply l8_2.
apply H10.
auto.
assert (Col D V V0).
eapply col_transitivity_1;Col.
assert (Col C V V0).
eapply col_transitivity_1;Col.
assert (Col C V X).
eapply col_transitivity_1;Col.
assert (Col C V0 X).
eapply col_transitivity_1;Col.
cases_equality C X.
smart_subst X.
auto.
eapply col_transitivity_1;Col.
Qed.

Definition DistLn := fun A B C D =>
(exists X, Col X A B /\ ~Col X C D) \/ (exists X, ~ Col X A B /\ Col X C D).

Lemma l8_14_1 : forall A B, ~ Perp A B A B.
Proof.
unfold Perp.
unfold not;intros.
DecompEx H X.
unfold Perp_in in H0.
decompose [and] H0;clear H0.
clear H3 H2.
assert (Per A X A).
apply H5;Tarski.
assert (A=X);Perp.
assert (Per B X B).
apply H5;Tarski.
subst X.
assert (B=A);Perp.
Qed.

Hint Resolve l8_14_1 : Perp.

(*
Lemma l8_14_1 : forall A B C D, Perp A B C D -> DistLn A B C D.
Proof.
unfold Perp.
intros.

DecompEx H X.
unfold Perp_in in H0.
decompose [and] H0;clear H0.
unfold DistLn.
elim (classic (exists X0 : Point, Col X0 A B /\ ~ Col X0 C D));intro.
left;auto.
right.
suppose (forall X0, ~ Col X0 A B \/ Col X0 C D).
exists X.
split;auto.
assert
*)

Lemma l8_14_2_1a : forall X A B C D,
 Perp_in X A B C D -> Perp A B C D.
Proof with Perp.
unfold Perp.
intros.
exists X.
intuition.
Qed.

Lemma l8_14_2_1b : forall X A B C D Y,
 Perp_in X A B C D -> Col Y A B -> Col Y C D -> X=Y.
Proof with Perp.
intros.
unfold Perp_in in H.
decompose [and] H;clear H.
assert (Per Y X Y).
apply H7...
symmetry.
eapply l8_8...
Qed.

Lemma l8_14_2_1b_bis : forall A B C D X,
 Perp A B C D -> Col X A B -> Col X C D -> Perp_in X A B C D.
Proof with Perp.
intros.
unfold Perp in H.
DecompEx H Y.
assert (X=Y).
symmetry.
eapply l8_14_2_1b;eauto.
subst.
auto.
Qed.

Hint Resolve  l8_14_2_1b_bis : Perp.

Lemma l8_14_2_2 : forall X A B C D,
 Perp A B C D -> (forall Y, Col Y A B -> Col Y C D -> X=Y) ->
 Perp_in X A B C D.
Proof with Perp.
intros.
unfold Perp in H.
DecompEx H X0.
assert (X=X0).
apply H0;unfold Perp_in in H1;intuition.
subst...
Qed.

Lemma l8_14_3 : forall A B C D X Y,
  Perp_in X A B C D -> Perp_in Y A B C D -> X=Y.
Proof with Perp.
intros.
unfold Perp_in in *.
decompose [and] H;clear H.
decompose [and] H0;clear H0.
eapply l8_8.
eapply H10;auto.
Qed.

Lemma l8_15_1 : forall A B C X,
  A<>B -> Col A B X -> Perp A B C X ->
  Perp_in X A B C X.
Proof with Perp.
intros.
unfold Perp in H1.
DecompEx H1 X0.
unfold Perp_in in *.
intuition.
assert (Per X X0 X).
apply H6;Col;Tarski...
assert (X =X0)...
subst X0.
apply H6...
Qed.

Lemma l8_15_2 : forall A B C X,
 A<>B -> Col A B X -> Perp_in X A B C X ->
  Perp A B C X.
Proof with Perp.
intros.
unfold Perp.
exists X.
auto.
Qed.

Lemma l8_16_1 : forall A B C U X,
  A<>B -> Col A B X -> Col A B U -> U<>X -> Perp A B C X -> ~ Col A B C /\ Per C X U.
Proof with Perp.
intros.
assert (Perp_in X  A B C X).
eapply l8_15_1...
assert (Per C X U).
unfold Perp, Perp_in in *.
DecompEx H3 X0.
intuition.
split;auto.
assert (C<>X).
unfold not;intro.
subst X.
unfold Perp_in in H4;intuition.
assert (~ Col U C X).
unfold not;intro.
assert (C=X \/ U=X).
eapply l8_9...
Col.
intuition.
unfold not;intro.
assert (Col A X C).
eapply col_transitivity_1;Col.
assert (Col A C U).
eapply col_transitivity_1;Col.
assert (A<>C).
unfold not;intro.
unfold Perp_in in *;intuition.
smart_subst C.
assert (A<>B);auto.
assert (Col A X U).
eapply col_transitivity_1;Col.
intuition.
assert (Col C U X).
eapply col_transitivity_2;Col.
intuition.
Qed.

Lemma l8_16_2 : forall A B C U X,
  A<>B -> Col A B X -> Col A B U -> U<>X ->
 ~ Col A B C -> Per C X U ->Perp A B C X.
Proof with Perp.
intros.
assert (C<>X).
unfold not;intro.
smart_subst X;auto.
assert (Perp_in X A B C X).
eapply l8_13_2...
Col.
Tarski.
exists U.
exists C.
intuition.
exists X...
Qed.

Lemma l8_18_unicity : forall A B C X Y,
  ~ Col A B C ->
  Col A B X -> Perp A B C X ->
  Col A B Y -> Perp A B C Y ->
  X=Y.
Proof with Perp.
intros.
assert (Perp_in X A B C X).
eapply l8_15_1.
unfold not;intro;subst B;auto.
intuition.
Col.
assumption.
assert (Perp_in Y A B C Y).
eapply l8_15_1.
unfold not;intro;subst B;auto.
intuition.
Col.
assumption.
unfold Perp_in in *.
decompose [and] H4;clear H4.
decompose [and] H5;clear H5.
eapply l8_7 with (A:=C).
apply l8_2.
apply H11.
Col.
Tarski.
apply l8_2.
apply H15.
assumption.
Tarski.
Qed.

Ltac show_distinct X Y := assert (X<>Y);[unfold not;intro;treat_equalities|idtac].

Lemma l8_18_existence : forall A B C,
  ~ Col A B C -> exists X,
  Col A B X /\ Perp A B C X.
Proof with Tarski.
intros.
assert (exists Y, Bet B A Y /\ Cong A Y A C)...
DecompExAnd H0 Y.
assert (exists P : Point, is_midpoint P C Y).
eapply l7_25.
apply cong_symmetry;eauto.
DecompEx H0 P.
assert (Per A P Y).
unfold Per.
exists C;intuition;Tarski.
assert (exists Z, Bet A Y Z /\ Cong Y Z Y P)...
DecompExAnd H4 Z.
assert (exists Q, Bet P Y Q /\ Cong Y Q Y A)...
DecompExAnd H4 Q.
let_symmetric Q' Z Q.
assert (exists C', Bet Q' Y C' /\ Cong Y C' Y C)...
DecompExAnd H4 C'.
assert (OFSC A Y Z Q Q Y P A).
unfold OFSC;intuition.
show_distinct A Y...
assert (Cong Z Q P A).
eapply five_segments_with_def;eauto.
assert (Cong_3 A P Y Q Z Y).
unfold Cong_3;intuition.
assert (Per Q Z Y).
eapply l8_10.
2:apply H14.
auto.
assert (Cong Y Q Y Q').
assert (Per Y Z Q);Perp.
unfold Per in H16;intuition.
elim H16;intro Q'';intros.
decompose [and] H17.
assert (Q''=Q').
eapply symmetric_point_unicity.
apply H18.
auto.
subst Q''.
auto.
assert (exists X : Point, is_midpoint X C C').
eapply l7_25.
apply cong_symmetry;eauto.
DecompEx H17 X.
assert (Per Y X C).
unfold Per.
exists C';intuition.
show_distinct Q Y...
cases_equality C C'.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
show_distinct P Y...
assert (Col A B C)...
intuition.
show_distinct A B...
show_distinct A C...
show_distinct B C...
show_distinct Y C...
assert (Col P Y Q)...
assert (Col P Y C)...
assert (Col P Q C).
eapply col_transitivity_1;try apply H1;auto.
assert (Col Y Q C).
eapply col_transitivity_2;try apply H1;auto.
assert (Col Y Q' P).
eapply col_transitivity_1;try apply H21;auto.
assert (Col C Q' P).
eapply col_transitivity_2;try apply H21;auto.
assert (Col A Y B)...
assert (Col A Y Z)...
assert (Col A B Z).
eapply col_transitivity_1;try apply H10;auto.
assert (Col Y B Z).
eapply col_transitivity_2;try apply H10;auto.
assert (Col Q Y P)...
assert (Col Q' Y P).
Col.
assert (Col P Q Q').
eapply col_transitivity_1;try apply H1;auto.
Col.
assert (Col Y Q Q').
eapply col_transitivity_2;try apply H1;auto.
Col.
assert (Col Z Q Q')...
Col.
show_distinct Q' Q...
assert (Col P B C).
eapply col_transitivity_1;try apply H1;auto.
intuition.
assert (Col Q' P Y).
eapply col_transitivity_1;try apply H42;Col.
assert (Col Q' Z Y).
eapply col_transitivity_1;try apply H42;Col.
show_distinct Z Y...
assert (Col Z A Q').
eapply col_transitivity_1;try apply H45;Col.
assert (Col Y A Q').
eapply col_transitivity_2;try apply H45;Col.
show_distinct Z A...
assert (Col Z B Q').
eapply col_transitivity_1;try apply H48;Col.
assert (Col A B Q').
eapply col_transitivity_2;try apply H48;Col.
assert (Col B Y Q').
eapply col_transitivity_2;try apply H12;Col.
show_distinct Y Q'...
assert (Col Y Q B).
eapply col_transitivity_1;try apply H52;Col.
show_distinct Y B...
assert (Col Y B C).
eapply col_transitivity_1;try apply H52;Col.
assert (B<>Y)...
assert (Col B A C).
eapply col_transitivity_1;try apply H56;Col.
assert (Col A B C)...
Col.
intuition.
(* Now we know that C<> C' ! *)
suppose (OFSC Q Y C Z Q' Y C' Z).
assert (Cong C Z C' Z).
eapply five_segments_with_def;eauto.
assert (Col Z Y X).
eapply upper_dim.
apply H20.
apply cong_commutativity.
assumption.
sTarski.
unfold is_midpoint in H18;intuition.
show_distinct Y Z.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
show_distinct C X.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
show_distinct Y X.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
treat_equalities.
auto.
clean_trivial_hyps.
clean_duplicated_hyps.
Focus 2.
assert (Perp_in X Y Z C X).
eapply l8_13_2...
Col.
exists Y.
exists C.
repeat split...
assert (Col A B X).
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
clean_trivial_hyps.
clean_duplicated_hyps.
assert (Col A Y B)...
assert (Col A Y Z)...
assert (Col Y B Z).
eapply col_transitivity_2.
apply H10.
auto.
auto.
assert (Col Y Z X)...
Col.
assert (Col Y B X).
eapply col_transitivity_1.
apply H24.
Col.
Col.
assert (X<>Y)...
assert (Col X A B).
eapply col_transitivity_1.
apply H39.
assert (Col Y Z X)...
assert (Col Y Z A)...
assert (Col Y X A).
eapply col_transitivity_1;try apply H24;auto.
Col.
Col.
Col.
exists X.
split...
unfold Perp.
exists X.
unfold Perp_in.
repeat split.
unfold not;intro;subst B;intuition.
assumption.
Col.
Tarski.
unfold Perp_in in H27.
decompose [and] H27;clear H27.
intros.
apply H34.
2:assumption.
unfold OFSC,Cong_3,is_midpoint in *;DecompAndAll.
assert (Col A Y Z)...
assert (Col A B U)...
Col.
assert (Col A B Y).
Col.
assert (Col A Y Z).
assert (Col A U Y).
assert (A<>B).
unfold not;intro.
subst B;intuition.
eapply col_transitivity_1.
apply H53.
auto.
auto.
auto.
assert (Col Y U Z).
assert (Y<>A)...
eapply col_transitivity_1.
apply H54.
2:Col.
assert (Col A Y U).
eapply col_transitivity_1.
assert (A<>B)...
unfold not;intro;subst B;intuition.
apply H55.
Col.
Col.
Col.
Col.
Focus 2.
unfold OFSC;repeat split;sTarski...
2:unfold OFSC ,is_midpoint, Cong_3 in *;DecompAndAll.
2:apply cong_right_commutativity.
2:assumption.
unfold is_midpoint in H1.
DecompAndAll.
show_distinct P Y...
clear  H6 H2 H3 H7 H9 H5 H12 H13 H14 H15 H16 H18 H17 H22 H0 H.
Between.
(* retour de focus *)
show_distinct A B...
show_distinct A C...
show_distinct B C...
show_distinct Y C...
show_distinct P Y...
show_distinct A Y...
show_distinct A Z...
show_distinct Y B...
show_distinct Y Z...
show_distinct C' Y...
show_distinct Q Q'...
assert (Col P B C).
eapply col_transitivity_1;try apply H32;Col.
intuition.
show_distinct Y Q...
clear H17 H0 H3 H7 H9 H12 H13 H15 H16 H22 H26 H27 H29 H30 H21 H33 H34 H38 H40.
assert (Col B A Y)...
assert (Col A Y Z)...
assert (Col P Y Q)...
assert (Col P Y C)...
assert (Col P Q C).
eapply col_transitivity_1;try apply H32;auto.
assert (Col Y Q C).
eapply col_transitivity_2;try apply H32;auto.
assert (Col Q' Y  C')...
assert (Col Q Z Q')...
assert (Col C Y C')...
clear H18 H23 H35 H4 H5 H11 H8 H2 H6.
assert (Col A Z B).
eapply col_transitivity_1;try apply H36;Col.
assert (Col Y Z B).
eapply col_transitivity_2;try apply H36;Col.
assert (Col C' C Q').
eapply col_transitivity_1;try apply H42;Col.
assert (Col Y C Q').
eapply col_transitivity_2;try apply H42;Col.
assert (Col C P Q').
eapply col_transitivity_1;try apply H25;Col.
assert (Col Y P Q').
eapply col_transitivity_2;try apply H25;Col.
assert (Col Y Q Q').
eapply col_transitivity_2;try apply H32;Col.
assert (Col P Q Q').
eapply col_transitivity_2;try apply H32;Col.
assert (Col Q Z P).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Q Z Y).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Q' Z P).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Q' Z Y).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Q' P Y).
eapply col_transitivity_2;try apply H43;Col.
assert (Col Y Z C).
eapply col_transitivity_1;try apply H43;Col.
assert (Col Y A C).
eapply col_transitivity_1;try apply H41;Col.
assert (Col A B C).
eapply col_transitivity_1;try apply H10;Col.
intuition.
Qed.

Lemma l8_20_1 : forall A B C C' D P,
  Per A B C -> is_midpoint P C' D ->
  is_midpoint A C' C -> is_midpoint B D C ->
   Per B A P.
Proof.
intros.
let_symmetric B' A B.
let_symmetric D' A D.
let_symmetric P' A P.
cases_equality A B.

subst B.
Perp.
(*
split;Perp.
intros.
unfold not;intro.
subst P.
assert (C=D').
eapply symmetric_point_unicity;eauto.
subst D'.
assert (C=D).
eapply symmetric_point_unicity.
apply H1.
auto.
subst D.
assert (A=C).
Midpoint.
auto.
*)
assert (Per B' B C).
eapply l8_3.
apply H.
auto.
unfold is_midpoint in H4;intuition;Col.

assert (Per B B' C').

eapply l8_10.
apply H7.
unfold Cong_3;repeat split;Tarski.
eapply l7_13.
apply H4.
apply H1.
eapply l7_13.
eapply l7_2.
apply H4.
apply H1.

suppose (Cong B C' B D').
suppose (IFSC C' P D B D' P' C B).
assert (Cong P B P' B).
eapply l4_2;eauto.
unfold Per.
exists P'.
intuition.
(*
unfold not;intros.
subst P.
assert (C=D).
eapply symmetric_point_unicity;try apply H1;eauto.
smart_subst D.
assert (B=C).
eapply l7_3;eauto.
auto.
*)
unfold IFSC in *;repeat split.
unfold is_midpoint in *;DecompAndAll;auto.
Focus 5.
unfold is_midpoint in H2;DecompAndAll.
sTarski.
4:sTarski.
eapply (l7_15).
apply H5.
apply H6.
apply H1.
unfold is_midpoint in H0;DecompAndAll;Between.
assert (Cong C D' C' D).
eapply (l7_13 A C D' C' D);Midpoint.
sTarski.

assert (Cong P C' P' C).
eapply l7_13.
apply l7_2.
apply H6.
apply l7_2.
apply H1.

eapply cong_transitivity with (C:=P) (D:=C').
unfold is_midpoint in H0;DecompAndAll.
sTarski.
auto.

unfold Per in H8.
DecompExAnd H8 D0.
suppose (D0=D').
subst D0;auto.

assert (is_midpoint B' C' D').
unfold is_midpoint;split.
eapply l7_15.
apply l7_2.
apply H1.
apply H4.
apply H5.
unfold is_midpoint in H2;decompose [and] H2;Between.
eapply l7_16.
apply  l7_2.
apply H1.
apply H4.
apply H4.
apply H5.
unfold is_midpoint in H2;decompose [and] H2;sTarski.
eapply symmetric_point_unicity;eauto.
Qed.

Lemma l8_20_2 : forall A B C C' D P,
  Per A B C -> is_midpoint P C' D ->
  is_midpoint A C' C -> is_midpoint B D C ->
   B<>C -> A<>P.
Proof.
intros.
unfold not;intros.
subst P.
assert (C=D).
eapply symmetric_point_unicity;try apply H1;eauto.
smart_subst D.
assert (B=C).
eapply l7_3;eauto.
auto.
Qed.

Lemma l8_21_aux : forall A B C,
 A<> B -> ~ Col A B C -> exists P, exists T, Perp A B P A /\ Col A B T /\ Bet C T P.
Proof with Tarski.
intros.
assert (exists X : Point, Col A B X /\ Perp A B C X).
eapply l8_18_existence...
DecompExAnd H1 X.
assert (Per A X C).
assert (Perp_in X A B C X).
eapply l8_15_1;auto.
unfold Perp_in in H1.
DecompAndAll.
apply H9;Tarski.

assert (HH:=H1).
unfold Per in H1.
DecompExAnd H1 C'.

let_symmetric C'' A C.

assert (exists P, is_midpoint P C' C'').
eapply l7_25.
unfold is_midpoint in H2.
decompose [and] H2.

eapply cong_transitivity with (C:=C) (D:=A).
2:apply H7.
sTarski.
DecompEx H1 P.

assert (Per X A P).

eapply l8_20_1.
apply HH.
apply l7_2.
apply H7.
Midpoint.
Midpoint.

show_distinct X C.
unfold is_midpoint in*;DecompAndAll.
intuition.

assert (A<>P).
eapply l8_20_2.
apply HH.
apply l7_2.
apply H7.
Midpoint.
Midpoint.
auto.

assert (exists T, Bet P T C /\ Bet A T X).
eapply l3_17 with (A:=C'') (A':=C');unfold is_midpoint in *;intuition.
DecompExAnd H10 T.

cases_equality A X.
exists P.
exists T.
treat_equalities.
repeat split;Tarski;Between.

unfold Perp.
assert (Perp_in A A B C A).
eapply l8_15_1;auto.
Tarski.
unfold Perp_in in H3.
decompose [and] H3;clear H3.
exists A.
unfold Perp_in;repeat split;Tarski;auto.
intros.
eapply H16;auto.
assert (Col A P C).
Col.
assert (Col A P V).
Col.
assert (Col A C V).
eapply col_transitivity_1;try apply H9;auto.
Col.

assert (Col A B T).
eapply col_transitivity_1.
apply H10.
unfold is_midpoint;intuition.
unfold is_midpoint;intuition.
exists P.
exists T.
repeat split;Between.
unfold Perp.
exists A.
eapply l8_13_2;auto.
Tarski.
Tarski.

exists X.
exists P.
repeat split.
Col.
Tarski.
auto.
auto.
auto.
Qed.

Lemma l8_21 : forall A B C,
 A<> B ->  exists P, exists T, Perp A B P A /\ Col A B T /\ Bet C T P.
Proof with Tarski.
intros.
cases_col A B C.
assert (exists C', ~ Col A B C').
eapply l6_25...
DecompEx H1 C'.

assert (  exists P : Point,
         (exists T : Point, Perp A B P A /\ Col A B T /\ Bet C' T P)).
apply (l8_21_aux A B C');auto.
DecompEx H1 P.
DecompEx H3 T.
exists P.
exists C.
intuition.

eapply l8_21_aux;auto.
Qed.

Lemma perp_symmetry : forall A B C D, Perp A B C D -> Perp C D A B.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_commutativity : forall A B C D, Perp A B C D -> Perp B A D C.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_left_commutativity : forall A B C D, Perp A B C D -> Perp B A C D.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_right_commutativity : forall A B C D, Perp A B C D -> Perp A B D C.
Proof.
unfold Perp.
intros.
DecompEx H X.
exists X.
unfold Perp_in in *.
intuition.
Qed.

Lemma perp_in_left_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X B A C D.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_right_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X A B D C.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_commutativity : forall A B C D X,
Perp_in X A B C D -> Perp_in X B A D C.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Lemma perp_in_symmetry : forall A B C D X,
Perp_in X A B C D -> Perp_in X C D A B.
Proof.
unfold Perp_in.
intros.
intuition.
Qed.

Hint Resolve perp_symmetry perp_commutativity perp_left_commutativity perp_right_commutativity : sPerp.
Hint Resolve perp_in_symmetry perp_in_commutativity perp_in_left_commutativity perp_in_right_commutativity : sPerp.

Ltac sPerp := eauto with sPerp.

Lemma perp_per_1 : forall A B C, A<>B -> Perp A B C A -> Per B A C.
Proof.
intros.
assert (Perp_in A A B C A).
eapply l8_15_1;auto.
Tarski.
unfold Perp_in in H1.
intuition.
Qed.

Lemma perp_per_2 : forall A B C, A<>B -> Perp A B A C -> Per B A C.
Proof.
intros.
assert (Perp A B C A);eauto with sPerp.
apply perp_per_1;auto.
Qed.

Hint Resolve perp_per_1 perp_per_2 : Perp.

Lemma perp_col : forall A B C D E,
 A<>E ->
 Perp A B C D -> Col A B E -> Perp A E C D.
Proof with Col.
unfold Perp,Perp_in.
intros.
DecompExAnd H0 X.
exists X.
repeat split;auto.
assert (Col A E X).
eapply col_transitivity_1;try apply H3...
Col.
intros.
apply H8.

assert (Col A B U).
eapply col_transitivity_1;try apply H...
Col.
Col.
Qed.

Hint Resolve perp_col : Perp.

Lemma perp_not_eq_1 : forall A B C D,
 Perp A B C D -> A<>B.
Proof.
unfold Perp.
intros.
DecompEx H X.
unfold Perp_in in H0.
intuition.
Qed.

Lemma perp_not_eq_2 : forall A B C D,
 Perp A B C D -> C<>D.
Proof.
intros.
assert (Perp C D A B);sPerp.
eapply perp_not_eq_1;eauto.
Qed.

Hint Resolve perp_not_eq_1 perp_not_eq_2 : Perp.

Lemma perp_perp_in : forall A B C,
Perp A B C A -> Perp_in A A B C A.
Proof.
intros.
apply l8_15_1;Perp.
Tarski.
Qed.

Hint Resolve perp_perp_in : Perp.


Require Import logic.

(* Here we define a parameterized module Invariance that expects as a
   parameter a module D of module type DYN. This parameterization
   allows us to give a generic proof of the theorem
   InvarianceUnderBisimulation.

   We can later take this functor and apply it to a module D of type
   DYN to obtain a module with a proof of the theorem for a concrete
   set of dynamic operators.

   The reader can find a more detailed explanation on modules in the
   file logic.v.

*)

Module Invariance (D: DYN).

(* We use the functor DynLogic to define a dynamic logic with the
   dynamic operators defined in D.

*)
Module DynLogic := DynLogic D.

(* This Import command makes the components of the module DynLogic D
   available by their short names. So for instance, we can write
   pointed_model instead of DynLogic.pointed_model.

 *)
Import DynLogic.

Theorem InvarianceUnderBisimulation :
  forall 𝔐 𝔐' : pointed_model,
  𝔐 ⇆ 𝔐' -> 𝔐 ≡ 𝔐'.

Proof.
  move=> 𝔐 𝔐' bis φ.
  move: 𝔐 𝔐' bis.
  elim: φ => [prop | | φ IHφ ψ IHψ | f φ IH] /=
             𝔐 𝔐'.
  + move=> [Z [bis HZ]].
    rewrite !to_st_val !to_st_point.
    by apply ((get_AH bis) ?? HZ).

  + by [].

  + move=>bis.
    split; move=> HImpl Hsat;
      apply (IHψ ?? bis);
      apply HImpl;
      by apply (IHφ ?? bis).

  + move=> [Z [bis HZ]].
    split.

    - move=> [q [HqinfW Hsatq]].
      apply ((get_Zig bis) ?? HZ) in HqinfW
        as [q' [Hq'infW' HZqq']].
      exists q'.
      split; first by [].
      apply (IH q) ; last by [].
      exists Z.
      by rewrite !to_st_to_pm.

    - move=> [q' [Hq'infW' Hsatq']].
      apply ((get_Zag bis) ?? HZ) in Hq'infW'
          as [q [HqinfW HZqq']].
      exists q.
      split; first by [].
      eapply (IH q); last by eassumption.
      exists Z.
      by rewrite !to_st_to_pm.
Qed.

End Invariance.


(* Require Import List.
Import ListNotations.
Require Import Fin.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop path ssrfun.

Inductive ter : Type :=
| T : nat -> ter.

Inductive var : Type :=
| V : nat -> var.

Inductive symbol : Type :=
| Ts : ter -> symbol
| Vs : var -> symbol.

Inductive rhs : Type :=
| Con : seq rhs -> rhs
| And : seq rhs -> rhs
| Neg : rhs -> rhs
| Sym : symbol -> rhs.

Definition rule : Type := (var * rhs).

Definition Grammar : Type := seq ter * seq var * seq rule * var.

Section Section1.

  Section Section11.

    Let A := nat.

    Definition f1 (lst: seq A) := [seq (take x lst, drop x lst) | x <- iota 0 (length lst)].

    Fixpoint f2 lst n :=
      match n with
      | 0 => nil
      | 1 => lst
      | S n =>
        let n2 := map (fun x => (fst x, f1 (snd x))) lst in
        let n3 := flatten  (map  (fun x => map (fun y => (fst x ++ [fst y], snd y)) (snd x))  n2) in
        f2 n3 n
      end.

    Definition f lst n :=
      let n1 := map (fun x => ([fst x],snd x)) (f1 lst) in
      let res := f2 n1 n in
      map fst (filter (fun x => snd x == []) res).

  End Section11.

  Section Section12.

    Definition minimum xs :=
      match xs with
      | nil => 0
      | y::ys => foldl minn y ys
      end.

    Definition maximum xs :=
      match xs with
      | nil => 0
      | y::ys => foldl maxn y ys
      end.

    Definition concat (langs: seq (seq nat -> nat)) :=
      fun string =>
        maximum
          (map minimum
               (map (map (fun x => (fst x) (snd x)))
                    (map (zip langs)
                         (f string (length langs))))).

  End Section12.

End Section1.

Section Section2.

  Let A := nat.

  Definition Interpretation : Type := var -> seq A -> nat.
  Definition ExtendedInterpretation : Type := rhs -> seq A -> nat.

  Definition extendedInterpretation (interpretation: Interpretation): ExtendedInterpretation :=
    let fix intExtHelp (r: rhs) :=
        match r with
        | And nil => fun (string: seq A) => if string == nil then 2 else 0
        | Con nil => fun (string: seq A) => if string == nil then 2 else 0
        | Sym (Ts (T a)) => fun (string: seq A) => if string == [::a] then 2 else 0
        | Sym (Vs a) => fun (string: seq A) => interpretation a string
        | Con rs => fun (string: seq A) => concat (map intExtHelp rs) string
        | Neg r => fun string => 2 - intExtHelp r string
        | And rs => fun (string: seq A) => minimum (map (fun r => intExtHelp r string) rs)
        end in
    fun rhs string => intExtHelp rhs string.

End Section2.

Section Section3.

  Definition isNegative rhs :=
    match rhs with
    | Neg _ => true
    | _ => false
    end.
  Definition isPositive rhs := ~~ (isNegative rhs).

End Section3.

Section Section4.

  Definition eq_r nt (rule: rule) :=
    let (lhs,_) := rule in
    match nt, lhs with
    | V n, V lh => n == lh
    end.

  Definition theta (grammar: Grammar) (intJ: Interpretation) :=
    fun intI nt string =>
      let '(ts, nts, rules, ss) := grammar in
      let extIntI := extendedInterpretation intI in
      let extIntJ := extendedInterpretation intJ in
      let rhss := map snd (filter (fun rule => eq_r nt rule) rules) in

      let res1 :=
          has
            (fun rhs =>
               match rhs with
               | And rhs1 =>
                 let posAts := filter isPositive rhs1 in
                 let negAts := filter isNegative rhs1 in
                 all (fun li => extIntI li string == 2) posAts && all (fun li => extIntJ li string == 2) negAts
               | Neg rhs => extIntJ (Neg rhs) string == 2
               | rhs => extIntI rhs string == 2
               end
            ) rhss in

      let res2 :=
          all
            (fun rhs =>
               match rhs with
               | And rhs1=>
                 let posAts := filter isPositive rhs1 in
                 let negAts := filter isNegative rhs1 in
                 has (fun li => extIntI li string == 0) posAts || has (fun li => extIntJ li string == 0) negAts
               | Neg rhs => extIntJ (Neg rhs) string == 0
               | rhs => extIntI rhs string == 0
               end
            ) rhss in

      if res1 then 2 else if res2 then 0 else 1.

  Definition botIntT (nt: var) := fun (string: seq nat) => 0.
  Definition botIntI (nt: var) := fun (string: seq nat) => 1.

  Fixpoint omeg (grammar: Grammar) (interp: Interpretation) (n: nat): Interpretation :=
    match n with
    | 0 => botIntT
    | S n => theta grammar interp (omeg grammar interp n)
    end.

  Fixpoint m (grammar: Grammar) (n k: nat): Interpretation :=
    match n with
    | 0 => botIntI
    | S n => omeg grammar (m grammar n k) k
    end.

End Section4.

Section WW.

  Definition ww: Grammar:=
    (nil,
     nil,
     [
       (V 0,
        And [
            Neg (Con [Sym (Vs (V 1)); Sym (Vs (V 2))]);
              Neg (Con [Sym (Vs (V 2)); Sym (Vs (V 1))]);
              Neg (Sym (Vs (V 1)));
              Neg (Sym (Vs (V 2)))]);
       (V 1, And [Sym (Ts (T 0))]);
       (V 1, And [Con [Sym (Vs (V 3)); Sym (Vs (V 1)); Sym (Vs (V 3))]]);
       (V 2, And [Sym (Ts (T 1))]);
       (V 2, And [Con [Sym (Vs (V 3)); Sym (Vs (V 2)); Sym (Vs (V 3))]]);
       (V 3, And [Sym (Ts (T 0))]);
       (V 3, And [Sym (Ts (T 1))])
     ],
     V 0).

  Example example1:
    (m ww 2 2) (V 0) [0;0;1; 0;0;1] == 2.
  Proof. by done. Qed.

  Lemma lemma1:
    forall lst,
      lst = [::0] \/ lst = [::1] <-> (m ww 1 1) (V 3) lst == 2.
  Proof.
    intros lst .
    split; [move => [H|H]| move => H].
    - subst lst. by done.
    - subst lst. by done.
    - destruct lst; first by done.
      destruct lst; first destruct n.
      left. by done.
      right. destruct n. by done. simpl in H. by done.
      simpl in H. admit.
  Admitted.

  Lemma lemma2:
    forall lst lst1 lst2,
      (m ww 1 1) (V 2) lst == 2 <-> lst = lst1 ++ [::1] ++ lst2.
  Proof.
  Admitted.

  Lemma lemma3:
    forall lst lst1 lst2,
      (m ww 1 1) (V 1) lst == 2 <-> lst = lst1 ++ [::0] ++ lst2.
  Proof.
  Admitted.

  Lemma lemma4:
    forall lst lst',
      (m ww 2 2) (V 0) lst == 2 <-> lst = lst' ++ lst'.
  Proof.
    intros.
    split; intros.
    admit.
    subst lst.
    simpl.
   Admitted.

  Example example2:
    forall lst, exists k, (m ww k k) (V 0) (lst ++ lst) == 2.
  Proof.
    intros.
    induction lst.
    - exists 2. by done.
  Admitted.

End SectionName5. *)


Require Import Coq.Program.Equality.
Require Import Coq.btauto.Btauto.
Require Import Coq.Lists.Streams.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
From Coq.ssr Require Import ssreflect ssrfun ssrbool.
From mathcomp.ssreflect Require Import seq eqtype ssrnat.

Set Implicit Arguments.
Set Boolean Equality Schemes.
Set Decidable Equality Schemes.

Notation new_line := (String "010" EmptyString) (only parsing).
Check new_line.

Axiom later : forall {T}, T.
Inductive player := player_1 | player_2.
Definition other_player (current_player : player) : player :=
match current_player with
|player_1 => player_2
|player_2 => player_1
end.

(*Definition pile := seq.*)
Definition set_cell_in_pile (q : seq nat) (index : nat) (n : nat) (p : player) : seq nat :=
(set_nth 0 q index n).

Definition game_result (current_player : player) : player :=
other_player current_player.

Definition output_result (q : seq nat) (current_player : player) : player := later.
foldr String.append ""%string (map).
Compute output_result seq nat.
Definition game_state (q : seq nat) (current_player : player) : player :=
if q == [::] then game_result current_player else play_game q (other_player current_player).

Definition make_move (q : seq nat) (current_player : player) (index : nat) (n : nat) : seq nat + player :=
if (n <= nth 0 q index) && (n != 0) then inl (set_cell_in_pile q index (nth 0 q index - n) current_player) && (game_state q current_player) else inr (game_result current_player).


(** A hight-level assembler manipulating both data and proofs. *)
Require Import ZArith.
Require Import List.
Require Import Compiler.Source.

Set Implicit Arguments.
Import ListNotations.
Local Open Scope Z_scope.

Module Sig.
  Definition t := list (Z -> Prop).
End Sig.

Module Stack.
  Inductive t : Sig.t -> Type :=
  | nil : t nil
  | cons : forall P, {z : Z | P z} -> forall sig, t sig -> t (P :: sig).
End Stack.

Module Instr.
  Inductive t : Type :=
  | const : forall (P : Z -> Prop),
    {z : Z | P z} -> t
  | unop : forall (P1 P : Z -> Prop) (op : UnOp.t),
    (forall z1, P1 z1 -> P (UnOp.eval op z1)) -> t
  | binop : forall (P1 P2 P : Z -> Prop) (op : BinOp.t),
    (forall z1 z2, P1 z1 -> P2 z2 -> P (BinOp.eval op z1 z2)) -> t.

  Definition input_sig (i : t) (context : Sig.t) : Sig.t :=
    match i with
    | const _ _ => context
    | unop P1 _ _ _ => P1 :: context
    | binop P1 P2 _ _ _ => P1 :: P2 :: context
    end.

  Definition output_sig (i : t) (context : Sig.t) : Sig.t :=
    match i with
    | const P _ | unop _ P _ _ | binop _ _ P _ _ => P :: context
    end.

  Definition eval (i : t) (context : Sig.t) (s : Stack.t (input_sig i context))
    : Stack.t (output_sig i context).
    destruct i as [P z | P1 P op Hcast | P1 P2 P op Hcast]; simpl in *.
    - exact (Stack.cons P z s).

    - inversion_clear s as [|P' z1 sig s'].
      destruct z1 as (z1, H1).
      exact (Stack.cons P (existT _ (UnOp.eval op z1) (Hcast z1 H1)) s').

    - inversion_clear s as [|P' z1 sig s']; inversion_clear s' as [|P' z2 sig s''].
      destruct z1 as (z1, H1); destruct z2 as (z2, H2).
      exact (Stack.cons P (existT _ (BinOp.eval op z1 z2) (Hcast z1 z2 H1 H2)) s'').
  Defined.
End Instr.

Module Program.
  Inductive t (P : Z -> Prop) : Sig.t -> Type :=
  | nil : t P [P]
  | cons : forall (i : Instr.t) context,
    t P (Instr.output_sig i context) -> t P (Instr.input_sig i context).

  Fixpoint length P input_sig (p : t P input_sig) : nat :=
    match p with
    | nil _ => 0
    | cons _ _ p => S (length p)
    end.

  Fixpoint eval_aux P input_sig (p : t P input_sig) (s : Stack.t input_sig)
    : {z : Z | P z}.
    destruct p as [|i context p].
    - inversion_clear s as [|P' z sig s'].
      exact z.

    - exact (
      let s := Instr.eval i context s in
      eval_aux _ _ p s).
  Defined.

  Definition eval P (p : t P []) : {z : Z | P z} :=
    eval_aux p Stack.nil.

  Module Test.
    Definition P (z : Z) := True.

    (** const 12 *)
    Definition p1 :=
      cons (Instr.const P (existT _ 12 I)) _ (
      nil P).

    (** const 12; uminus *)
    Definition p2 :=
      cons (Instr.const P (existT _ 12 I)) _ (
      cons (Instr.unop _ _ UnOp.uminus (fun _ _ => I)) _ (
      nil P)).

    (** const 12; const 5; plus *)
    Definition p3 :=
      cons (Instr.const P (existT _ 12 I)) _ (
      cons (Instr.const P (existT _ 5 I)) _ (
      cons (Instr.binop _ _ _ BinOp.plus (fun _ _ _ _ => I)) _ (
      nil P))).

    Check eq_refl : 12 = projT1 (eval p1).
    Check eq_refl : - 12 =  projT1 (eval p2).
    Check eq_refl : 17 =  projT1 (eval p3).
  End Test.
End Program.


Require Import ExtLib_Any.
Require Import ExtLib_Functor.
Require Import ExtLib_Applicative.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Class Monad@{d c} (m : Type@{d} -> Type@{c}) : Type :=
{ ret : forall {t : Type@{d}}, t -> m t
; bind : forall {t u : Type@{d}}, m t -> (t -> m u) -> m u
}.

Section monadic.

  Definition liftM@{d c}
              {m : Type@{d} -> Type@{c}}
              {M : Monad m}
              {T U : Type@{d}} (f : T -> U) : m T -> m U :=
    fun x => bind x (fun x => ret (f x)).

  Definition liftM2@{d c}
              {m : Type@{d} -> Type@{c}}
              {M : Monad m}
              {T U V : Type@{d}} (f : T -> U -> V) : m T -> m U -> m V :=
    Eval cbv beta iota zeta delta [ liftM ] in
      fun x y => bind x (fun x => liftM (f x) y).

  Definition liftM3@{d c}
              {m : Type@{d} -> Type@{c}}
              {M : Monad m}
              {T U V W : Type@{d}} (f : T -> U -> V -> W) : m T -> m U -> m V -> m W :=
    Eval cbv beta iota zeta delta [ liftM2 ] in
      fun x y z => bind x (fun x => liftM2 (f x) y z).

  Definition apM@{d c}
              {m : Type@{d} -> Type@{c}}
              {M : Monad m}
              {A B : Type@{d}} (fM:m (A -> B)) (aM:m A) : m B :=
    bind fM (fun f => liftM f aM).

  (* Left-to-right composition of Kleisli arrows. *)
  Definition mcompose@{c d}
             {m:Type@{d}->Type@{c}}
             {M: Monad m}
             {T U V:Type@{d}}
             (f: T -> m U) (g: U -> m V): (T -> m V) :=
    fun x => bind (f x) g.

End monadic.

Module MonadNotation.

  Delimit Scope monad_scope with monad.

  Notation "c >>= f" := (@bind _ _ _ _ c f) (at level 58, left associativity) : monad_scope.
  Notation "f =<< c" := (@bind _ _ _ _ c f) (at level 61, right associativity) : monad_scope.
  Notation "f >=> g" := (@mcompose _ _ _ _ _ f g) (at level 61, right associativity) : monad_scope.

  Notation "x <- c1 ;; c2" := (@bind _ _ _ _ c1 (fun x => c2))
    (at level 61, c1 at next level, right associativity) : monad_scope.

  Notation "e1 ;; e2" := (_ <- e1%monad ;; e2%monad)%monad
    (at level 61, right associativity) : monad_scope.

  Notation "' pat <- c1 ;; c2" :=
    (@bind _ _ _ _ c1 (fun x => match x with pat => c2 end))
    (at level 61, pat pattern, c1 at next level, right associativity) : monad_scope.

End MonadNotation.

Section Instances.

Universe d c.
Context (m : Type@{d} -> Type@{c}) {M : Monad m}.

Global Instance Functor_Monad@{} : Functor m :=
{ fmap := @liftM _ _ }.

Global Instance Applicative_Monad@{} : Applicative m :=
{ pure := @ret _ _
; ap := @apM _ _
}.

End Instances.