From hydras.Ackermann Require Import primRec.
From hydras.Ackermann Require Import cPair.
From Coq Require Import Arith.
From hydras.Ackermann Require Import code.
From hydras.Ackermann Require Import codeSubFormula.
From hydras.Ackermann Require Import folProp.
From hydras.Ackermann Require Import folProof.
From hydras.Ackermann Require Import Languages.
From hydras.Ackermann Require Import subAll.
From hydras.Ackermann Require Import subProp.
From hydras.Ackermann Require Import folLogic3.
From hydras.Ackermann Require Import folReplace.
From hydras.Ackermann Require Import LNN.
From hydras.Ackermann Require Import codeNatToTerm.
From Goedel Require Import PRrepresentable.
From hydras.Ackermann Require Import ListExt.
From Coq Require Import List.
From hydras.Ackermann Require Import NN.
From hydras.Ackermann Require Import expressible.

Definition subStar (a v n : nat) := codeSubFormula a v (codeNatToTerm n).

Lemma subStarIsPR : isPR 3 subStar.
Proof.
unfold subStar in |- *.
apply
 compose3_3IsPR
  with
    (f1 := fun a v n : nat => a)
    (f2 := fun a v n : nat => v)
    (f3 := fun a v n : nat => codeNatToTerm n).
apply pi1_3IsPR.
apply pi2_3IsPR.
apply filter001IsPR.
apply codeNatToTermIsPR.
apply codeSubFormulaIsPR.
Qed.

Section LNN_FixPoint.

Let codeFormula := codeFormula LNN codeLNTFunction codeLNNRelation.

Lemma FixPointLNN :
 forall (A : Formula) (v : nat),
 {B : Formula |
   SysPrf NN
     (iffH B (substituteFormula LNN A v (natToTermLNN (codeFormula B)))) /\
   (forall x : nat,
    In x (freeVarFormula LNN B) <->
    In x (list_remove _ eq_nat_dec v (freeVarFormula LNN A)))}.
Proof.
intros.
set (subStarFormula := primRecFormula _ (proj1_sig subStarIsPR)) in *.
assert (represent : Representable NN 3 subStar subStarFormula).
unfold subStarFormula in |- *.
apply primRecRepresentable.
set (nv := newVar (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)) in *.
assert (0 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
unfold nv in H.
rewrite <- H.
simpl in |- *.
right.
auto.
assert (1 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
unfold nv in H0.
rewrite <- H0.
simpl in |- *.
auto.
assert (2 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
unfold nv in H1.
rewrite <- H1.
simpl in |- *.
auto.
assert (3 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
unfold nv in H2.
rewrite <- H2.
simpl in |- *.
auto.
assert (3 < nv).
destruct nv as [| n].
elim H; auto.
destruct n.
elim H0; auto.
destruct n.
elim H1; auto.
destruct n.
elim H2; auto.
repeat apply lt_n_S.
apply lt_O_Sn.
set
 (Theta :=
  existH v
    (andH
       (substituteFormula LNN
          (substituteFormula LNN
             (substituteFormula LNN
                (substituteFormula LNN subStarFormula 3 (var nv)) 2
                (natToTerm nv)) 1 (var nv)) 0 (var v)) A))
 in *.
exists (substituteFormula LNN Theta nv (natToTerm (codeFormula Theta))).
split.
set
 (N :=
  natToTermLNN
    (codeFormula
       (substituteFormula LNN Theta nv (natToTerm (codeFormula Theta)))))
 in *.
unfold Theta at 1 in |- *.
rewrite (subFormulaExist LNN).
induction (eq_nat_dec v nv).
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
fold nv in |- *.
simpl in |- *.
auto.
induction
 (In_dec eq_nat_dec v (freeVarTerm LNN (natToTerm (codeFormula Theta)))).
elim (closedNatToTerm _ _ a).
clear b b0.
rewrite (subFormulaAnd LNN).
apply
 iffTrans
  with
    (existH v
       (andH
          (substituteFormula LNN
             (substituteFormula LNN
                (substituteFormula LNN
                   (substituteFormula LNN subStarFormula 3
                      (natToTerm (codeFormula Theta))) 2
                   (natToTerm nv)) 1 (natToTerm (codeFormula Theta))) 0
             (var v)) A)).
apply (reduceExist LNN).
apply closedNN.
apply (reduceAnd LNN).
eapply iffTrans.
apply (subFormulaExch LNN).
assumption.
unfold not in |- *; intros.
induction H4 as [H4| H4].
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
fold nv in |- *.
rewrite <- H4.
simpl in |- *.
auto.
apply H4.
apply closedNatToTerm.
apply (reduceSub LNN).
apply closedNN.
eapply iffTrans.
apply (subSubFormula LNN).
assumption.
apply closedNatToTerm.
rewrite (subTermVar1 LNN).
apply (reduceSub LNN).
apply closedNN.
eapply iffTrans.
apply (subFormulaExch LNN).
assumption.
apply closedNatToTerm.
apply closedNatToTerm.
apply (reduceSub LNN).
apply closedNN.
apply (subFormulaTrans LNN).
unfold not in |- *; intros.
assert (In nv (freeVarFormula LNN subStarFormula)).
eapply In_list_remove1.
apply H4.
induction represent as (H6, H7).
elim (lt_not_le _ _ H3).
auto.
apply (subFormulaNil LNN).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
fold nv in |- *.
simpl in |- *.
repeat right.
auto.
apply iffI.
apply impI.
apply existSys.
apply closedNN.
unfold not in |- *; intros.
induction (freeVarSubFormula3 _ _ _ _ _ H4).
elim (In_list_remove2 _ _ _ _ _ H5).
auto.
elim (closedNatToTerm _ _ H5).
apply impE with (substituteFormula LNN (equal (var 0) N) 0 (var v)).
rewrite (subFormulaEqual LNN).
rewrite (subTermVar1 LNN).
rewrite (subTermNil LNN).
apply impI.
apply impE with (substituteFormula LNN A v (var v)).
apply (subWithEquals LNN).
apply Axm; right; constructor.
rewrite (subFormulaId LNN).
eapply andE2.
apply Axm; left; right; constructor.
unfold N in |- *.
apply closedNatToTerm.
apply
 impE
  with
    (substituteFormula LNN
       (substituteFormula LNN
          (substituteFormula LNN
             (substituteFormula LNN subStarFormula 3
                (natToTerm (codeFormula Theta))) 2
             (natToTerm nv)) 1 (natToTerm (codeFormula Theta))) 0
       (var v)).
apply iffE1.
apply sysWeaken.
apply (reduceSub LNN).
apply closedNN.
induction represent as (H4, H5).
simpl in H5.
unfold N in |- *.
replace
 (codeFormula
    (substituteFormula LNN Theta nv (natToTerm (codeFormula Theta)))) with
 (subStar (codeFormula Theta) nv (codeFormula Theta)).
apply H5.
unfold subStar in |- *.
rewrite codeNatToTermCorrectLNN.
unfold codeFormula at 1 in |- *.
rewrite codeSubFormulaCorrect.
reflexivity.
eapply andE1.
apply Axm; right; constructor.
apply impI.
apply existI with N.
rewrite (subFormulaAnd LNN).
apply andI.
apply sysWeaken.
eapply
 impE
      with
      (substituteFormula LNN
         (substituteFormula LNN (equal (var 0) N) 0 (var v)) v N).
apply iffE2.
apply (reduceSub LNN).
apply closedNN.
apply (reduceSub LNN).
apply closedNN.
induction represent as (H4, H5).
simpl in H5.
unfold N in |- *.
replace
 (codeFormula
    (substituteFormula LNN Theta nv (natToTerm (codeFormula Theta)))) with
 (subStar (codeFormula Theta) nv (codeFormula Theta)).
apply H5.
unfold subStar in |- *.
rewrite codeNatToTermCorrectLNN.
unfold codeFormula at 1 in |- *.
rewrite codeSubFormulaCorrect.
reflexivity.
repeat rewrite (subFormulaEqual LNN).
repeat rewrite (subTermVar1 LNN).
repeat rewrite (subTermNil LNN N).
apply eqRefl.
unfold N in |- *.
apply closedNatToTerm.
unfold N in |- *.
apply closedNatToTerm.
apply Axm; right; constructor.
intro.
split.
intro.
unfold Theta at 1 in H4.
unfold existH, andH in H4.
induction represent as (H5, H6).
repeat
 match goal with
 | H1:(?X1 = ?X2),H2:(?X1 <> ?X2) |- _ =>
     elim H2; apply H1
 | H1:(?X1 = ?X2),H2:(?X2 <> ?X1) |- _ =>
     elim H2; symmetry  in |- *; apply H1
 | H:(In ?X3 (freeVarFormula LNN (fol.existH LNN ?X1 ?X2))) |- _ =>
     assert (In X3 (list_remove nat eq_nat_dec X1 (freeVarFormula LNN X2)));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNN (fol.forallH LNN ?X1 ?X2))) |- _ =>
     assert (In X3 (list_remove nat eq_nat_dec X1 (freeVarFormula LNN X2)));
      [ apply H | clear H ]
 | H:(In ?X3 (list_remove nat eq_nat_dec ?X1 (freeVarFormula LNN ?X2))) |- _
 =>
     assert (In X3 (freeVarFormula LNN X2));
      [ eapply In_list_remove1; apply H
      | assert (X3 <> X1); [ eapply In_list_remove2; apply H | clear H ] ]
 | H:(In ?X3 (freeVarFormula LNN (fol.andH LNN ?X1 ?X2))) |- _ =>
     assert (In X3 (freeVarFormula LNN X1 ++ freeVarFormula LNN X2));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNN (fol.impH LNN ?X1 ?X2))) |- _ =>
     assert (In X3 (freeVarFormula LNN X1 ++ freeVarFormula LNN X2));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNN (fol.notH LNN ?X1))) |- _ =>
     assert (In X3 (freeVarFormula LNN X1)); [ apply H | clear H ]
 | H:(In _ (_ ++ _)) |- _ =>
     induction (in_app_or _ _ _ H); clear H
 | H:(In _ (freeVarFormula LNN (substituteFormula LNN ?X1 ?X2 ?X3))) |- _ =>
     induction (freeVarSubFormula3 _ _ _ _ _ H); clear H
 | H:(In _ (freeVarTerm LNN (natToTerm _))) |- _ =>
     elim (closedNatToTerm _ _ H)
 | H:(In _ (freeVarTerm LNN Zero)) |- _ =>
     elim H
 | H:(In _ (freeVarTerm LNN (Succ _))) |- _ =>
     rewrite freeVarSucc in H
 | H:(In _ (freeVarTerm LNN (var _))) |- _ =>
     simpl in H; decompose sum H; clear H
 | H:(In _ (freeVarTerm LNN (fol.var LNN _))) |- _ =>
     simpl in H; decompose sum H; clear H
 end.
elim (le_not_lt _ _ (H5 _ H4)).
destruct x as [| n].
elim H10; auto.
destruct n.
elim H11; auto.
destruct n.
elim H12; auto.
destruct n.
elim H13; auto.
repeat apply lt_n_S.
apply lt_O_Sn.
apply In_list_remove3; auto.
intro.
assert (In x (freeVarFormula LNN A));
 [ eapply In_list_remove1; apply H4
 | assert (x <> v); [ eapply In_list_remove2; apply H4 | clear H4 ] ].
apply freeVarSubFormula1.
unfold not in |- *; intros.
rewrite <- H4 in H5.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNN A)).
fold nv in |- *.
simpl in |- *.
repeat right.
auto.
unfold Theta in |- *.
apply
 (In_list_remove3 nat eq_nat_dec x v
    (freeVarFormula LNN
       (substituteFormula LNN
          (substituteFormula LNN
             (substituteFormula LNN
                (substituteFormula LNN subStarFormula 3 (var nv)) 2
                (natToTerm nv)) 1 (var nv)) 0 (var v)) ++
     freeVarFormula LNN A)).
apply in_or_app.
auto.
assumption.
Qed.

End LNN_FixPoint.

From hydras.Ackermann Require Import PA.
From hydras.Ackermann Require Import NN2PA.

Section LNT_FixPoint.

Let codeFormula := codeFormula LNT codeLNTFunction codeLNTRelation.

Lemma FixPointLNT :
 forall (A : Formula) (v : nat),
 {B : Formula |
   SysPrf PA
     (iffH B (substituteFormula LNT A v (natToTermLNT (codeFormula B)))) /\
   (forall x : nat,
    In x (freeVarFormula LNT B) <->
    In x (list_remove _ eq_nat_dec v (freeVarFormula LNT A)))}.
Proof.
intros.
set (subStarFormula := primRecFormula _ (proj1_sig subStarIsPR)) in *.
assert (represent : Representable NN 3 subStar subStarFormula).
unfold subStarFormula in |- *.
apply primRecRepresentable.
set (nv := newVar (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)) in *.
assert (0 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
unfold nv in H.
rewrite <- H.
simpl in |- *.
right.
auto.
assert (1 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
unfold nv in H0.
rewrite <- H0.
simpl in |- *.
auto.
assert (2 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
unfold nv in H1.
rewrite <- H1.
simpl in |- *.
auto.
assert (3 <> nv).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
unfold nv in H2.
rewrite <- H2.
simpl in |- *.
auto.
assert (3 < nv).
destruct nv as [| n].
elim H; auto.
destruct n.
elim H0; auto.
destruct n.
elim H1; auto.
destruct n.
elim H2; auto.
repeat apply lt_n_S.
apply lt_O_Sn.
set
 (Theta :=
  existH v
    (andH
       (substituteFormula LNT
          (substituteFormula LNT
             (substituteFormula LNT
                (substituteFormula LNT (LNN2LNT_formula subStarFormula) 3
                   (var nv)) 2 (natToTerm nv)) 1 (var nv)) 0
          (var v)) A)) in *.
exists (substituteFormula LNT Theta nv (natToTerm (codeFormula Theta))).
split.
set
 (N :=
  natToTermLNT
    (codeFormula
       (substituteFormula LNT Theta nv (natToTerm (codeFormula Theta)))))
 in *.
unfold Theta at 1 in |- *.
rewrite (subFormulaExist LNT).
induction (eq_nat_dec v nv).
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
fold nv in |- *.
simpl in |- *.
auto.
induction
 (In_dec eq_nat_dec v (freeVarTerm LNT (natToTerm (codeFormula Theta)))).
elim (closedNatToTerm _ _ a).
clear b b0.
rewrite (subFormulaAnd LNT).
apply
 iffTrans
  with
    (existH v
       (andH
          (substituteFormula LNT
             (substituteFormula LNT
                (substituteFormula LNT
                   (substituteFormula LNT (LNN2LNT_formula subStarFormula) 3
                      (natToTerm (codeFormula Theta))) 2
                   (natToTerm nv)) 1 (natToTerm (codeFormula Theta))) 0
             (var v)) A)).
apply (reduceExist LNT).
apply closedPA.
apply (reduceAnd LNT).
eapply iffTrans.
apply (subFormulaExch LNT).
assumption.
unfold not in |- *; intros.
induction H4 as [H4| H4].
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
fold nv in |- *.
rewrite <- H4.
simpl in |- *.
auto.
apply H4.
apply closedNatToTerm.
apply (reduceSub LNT).
apply closedPA.
eapply iffTrans.
apply (subSubFormula LNT).
assumption.
apply closedNatToTerm.
rewrite (subTermVar1 LNT).
apply (reduceSub LNT).
apply closedPA.
eapply iffTrans.
apply (subFormulaExch LNT).
assumption.
apply closedNatToTerm.
apply closedNatToTerm.
apply (reduceSub LNT).
apply closedPA.
apply (subFormulaTrans LNT).
unfold not in |- *; intros.
assert (In nv (freeVarFormula LNT (LNN2LNT_formula subStarFormula))).
eapply In_list_remove1.
apply H4.
induction represent as (H6, H7).
elim (lt_not_le _ _ H3).
apply H6.
apply LNN2LNT_freeVarFormula1.
assumption.
apply (subFormulaNil LNT).
unfold not in |- *; intros.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
fold nv in |- *.
simpl in |- *.
repeat right.
auto.
apply iffI.
apply impI.
apply existSys.
apply closedPA.
unfold not in |- *; intros.
induction (freeVarSubFormula3 _ _ _ _ _ H4).
elim (In_list_remove2 _ _ _ _ _ H5).
auto.
elim (closedNatToTerm _ _ H5).
apply impE with (substituteFormula LNT (equal (var 0) N) 0 (var v)).
rewrite (subFormulaEqual LNT).
rewrite (subTermVar1 LNT).
rewrite (subTermNil LNT).
apply impI.
apply impE with (substituteFormula LNT A v (var v)).
apply (subWithEquals LNT).
apply Axm; right; constructor.
rewrite (subFormulaId LNT).
eapply andE2.
apply Axm; left; right; constructor.
unfold N in |- *.
apply closedNatToTerm.
apply
 impE
  with
    (substituteFormula LNT
       (substituteFormula LNT
          (substituteFormula LNT
             (substituteFormula LNT (LNN2LNT_formula subStarFormula) 3
                (natToTerm (codeFormula Theta))) 2
             (natToTerm nv)) 1 (natToTerm (codeFormula Theta))) 0
       (var v)).
apply iffE1.
apply sysWeaken.
apply (reduceSub LNT).
apply closedPA.
induction represent as (H4, H5).
simpl in H5.
unfold N in |- *.
replace
 (codeFormula
    (substituteFormula LNT Theta nv (natToTerm (codeFormula Theta)))) with
 (subStar (codeFormula Theta) nv (codeFormula Theta)).
replace
 (equal (var 0)
    (natToTermLNT (subStar (codeFormula Theta) nv (codeFormula Theta)))) with
 (LNN2LNT_formula
    (LNN.equal (LNN.var 0)
       (LNN.natToTerm (subStar (codeFormula Theta) nv (codeFormula Theta))))).
apply
 iffTrans
  with
    (LNN2LNT_formula
       (substituteFormula LNN
          (substituteFormula LNN
             (substituteFormula LNN subStarFormula 3
                (LNN.natToTerm (codeFormula Theta))) 2
             (LNN.natToTerm nv)) 1 (LNN.natToTerm (codeFormula Theta)))).
apply iffSym.
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
apply iffRefl.
rewrite <- LNN2LNT_iff.
apply NN2PA.
apply H5.
rewrite <- LNN2LNT_natToTerm.
reflexivity.
unfold subStar in |- *.
rewrite codeNatToTermCorrectLNT.
unfold codeFormula at 1 in |- *.
rewrite codeSubFormulaCorrect.
reflexivity.
eapply andE1.
apply Axm; right; constructor.
apply impI.
apply existI with N.
rewrite (subFormulaAnd LNT).
apply andI.
apply sysWeaken.
eapply
 impE
      with
      (substituteFormula LNT
         (substituteFormula LNT (equal (var 0) N) 0 (var v)) v N).
apply iffE2.
apply (reduceSub LNT).
apply closedPA.
apply (reduceSub LNT).
apply closedPA.
induction represent as (H4, H5).
simpl in H5.
unfold N in |- *.
replace
 (codeFormula
    (substituteFormula LNT Theta nv (natToTerm (codeFormula Theta)))) with
 (subStar (codeFormula Theta) nv (codeFormula Theta)).
replace
 (equal (var 0)
    (natToTermLNT (subStar (codeFormula Theta) nv (codeFormula Theta)))) with
 (LNN2LNT_formula
    (LNN.equal (LNN.var 0)
       (LNN.natToTerm (subStar (codeFormula Theta) nv (codeFormula Theta))))).
apply
 iffTrans
  with
    (LNN2LNT_formula
       (substituteFormula LNN
          (substituteFormula LNN
             (substituteFormula LNN subStarFormula 3
                (LNN.natToTerm (codeFormula Theta))) 2
             (LNN.natToTerm nv)) 1 (LNN.natToTerm (codeFormula Theta)))).
apply iffSym.
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
eapply iffTrans; [ apply LNN2LNT_subFormula | idtac ].
rewrite LNN2LNT_natToTerm; apply (reduceSub LNT);
 [ apply closedPA | idtac ].
apply iffRefl.
rewrite <- LNN2LNT_iff.
apply NN2PA.
apply H5.
rewrite <- LNN2LNT_natToTerm.
reflexivity.
unfold subStar in |- *.
rewrite codeNatToTermCorrectLNT.
unfold codeFormula at 1 in |- *.
rewrite codeSubFormulaCorrect.
reflexivity.
repeat rewrite (subFormulaEqual LNT).
repeat rewrite (subTermVar1 LNT).
repeat rewrite (subTermNil LNT N).
apply eqRefl.
unfold N in |- *.
apply closedNatToTerm.
unfold N in |- *.
apply closedNatToTerm.
apply Axm; right; constructor.
intro.
split.
intro.
unfold Theta at 1 in H4.
unfold existH, andH in H4.
induction represent as (H5, H6).
repeat
 match goal with
 | H1:(?X1 = ?X2),H2:(?X1 <> ?X2) |- _ =>
     elim H2; apply H1
 | H1:(?X1 = ?X2),H2:(?X2 <> ?X1) |- _ =>
     elim H2; symmetry  in |- *; apply H1
 | H:(In ?X3 (freeVarFormula LNT (fol.existH LNT ?X1 ?X2))) |- _ =>
     assert (In X3 (list_remove nat eq_nat_dec X1 (freeVarFormula LNT X2)));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNT (fol.forallH LNT ?X1 ?X2))) |- _ =>
     assert (In X3 (list_remove nat eq_nat_dec X1 (freeVarFormula LNT X2)));
      [ apply H | clear H ]
 | H:(In ?X3 (list_remove nat eq_nat_dec ?X1 (freeVarFormula LNT ?X2))) |- _
 =>
     assert (In X3 (freeVarFormula LNT X2));
      [ eapply In_list_remove1; apply H
      | assert (X3 <> X1); [ eapply In_list_remove2; apply H | clear H ] ]
 | H:(In ?X3 (freeVarFormula LNT (fol.andH LNT ?X1 ?X2))) |- _ =>
     assert (In X3 (freeVarFormula LNT X1 ++ freeVarFormula LNT X2));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNT (fol.impH LNT ?X1 ?X2))) |- _ =>
     assert (In X3 (freeVarFormula LNT X1 ++ freeVarFormula LNT X2));
      [ apply H | clear H ]
 | H:(In ?X3 (freeVarFormula LNT (fol.notH LNT ?X1))) |- _ =>
     assert (In X3 (freeVarFormula LNT X1)); [ apply H | clear H ]
 | H:(In _ (_ ++ _)) |- _ =>
     induction (in_app_or _ _ _ H); clear H
 | H:(In _ (freeVarFormula LNT (substituteFormula LNT ?X1 ?X2 ?X3))) |- _ =>
     induction (freeVarSubFormula3 _ _ _ _ _ H); clear H
 | H:(In _ (freeVarTerm LNT (natToTerm _))) |- _ =>
     elim (closedNatToTerm _ _ H)
 | H:(In _ (freeVarTerm LNT Zero)) |- _ =>
     elim H
 | H:(In _ (freeVarTerm LNT (Succ _))) |- _ =>
     rewrite freeVarSucc in H
 | H:(In _ (freeVarTerm LNT (var _))) |- _ =>
     simpl in H; decompose sum H; clear H
 | H:(In _ (freeVarTerm LNT (fol.var LNT _))) |- _ =>
     simpl in H; decompose sum H; clear H
 end.
elim (le_not_lt x 3).
apply H5.
apply LNN2LNT_freeVarFormula1.
assumption.
destruct x as [| n].
elim H10; auto.
destruct n.
elim H11; auto.
destruct n.
elim H12; auto.
destruct n.
elim H13; auto.
repeat apply lt_n_S.
apply lt_O_Sn.
apply In_list_remove3; auto.
intro.
assert (In x (freeVarFormula LNT A));
 [ eapply In_list_remove1; apply H4
 | assert (x <> v); [ eapply In_list_remove2; apply H4 | clear H4 ] ].
apply freeVarSubFormula1.
unfold not in |- *; intros.
rewrite <- H4 in H5.
elim (newVar1 (v :: 1 :: 2 :: 3 :: 0 :: freeVarFormula LNT A)).
fold nv in |- *.
simpl in |- *.
repeat right.
auto.
unfold Theta in |- *.
apply
 (In_list_remove3 nat eq_nat_dec x v
    (freeVarFormula LNT
       (substituteFormula LNT
          (substituteFormula LNT
             (substituteFormula LNT
                (substituteFormula LNT (LNN2LNT_formula subStarFormula) 3
                   (var nv)) 2 (natToTerm nv)) 1 (var nv)) 0
          (var v)) ++ freeVarFormula LNT A)).
apply in_or_app.
auto.
assumption.
Qed.

End LNT_FixPoint.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

From Coq Require Import Logic.Classical_Prop Logic.Eqdep_dec Btauto.
From MatchingLogic.Utils Require Import stdpp_ext Lattice.
From MatchingLogic Require Import Syntax NamedAxioms DerivedOperators_Syntax wftactics.
From stdpp Require Import base fin_sets sets propset gmap.

From MatchingLogic.Utils Require Import extralibrary.

Import MatchingLogic.Syntax.Notations.
Import MatchingLogic.Substitution.Notations.
Import MatchingLogic.DerivedOperators_Syntax.Notations.

Set Default Proof Mode "Classic".

Section ml_proof_system.
  Open Scope ml_scope.

  Context {Σ : Signature}.

  (* Proof system for AML ref. snapshot: Section 3 *)

  Reserved Notation "theory ⊢H pattern" (at level 76).
  Inductive ML_proof_system (theory : Theory) :
    Pattern -> Set :=

  (* Hypothesis *)
  | hypothesis (axiom : Pattern) :
      well_formed axiom ->
      (axiom ∈ theory) -> theory ⊢H axiom

  (* FOL reasoning *)
  (* Propositional tautology *)
  | P1 (phi psi : Pattern) :
      well_formed phi -> well_formed psi ->
      theory ⊢H (phi ---> (psi ---> phi))
  | P2 (phi psi xi : Pattern) :
      well_formed phi -> well_formed psi -> well_formed xi ->
      theory ⊢H ((phi ---> (psi ---> xi)) ---> ((phi ---> psi) ---> (phi ---> xi)))
  | P3 (phi : Pattern) :
      well_formed phi ->
      theory ⊢H (((phi ---> Bot) ---> Bot) ---> phi)

  (* Modus ponens *)
  | Modus_ponens (phi1 phi2 : Pattern) :
      theory ⊢H phi1 ->
      theory ⊢H (phi1 ---> phi2) ->
      theory ⊢H phi2

  (* Existential quantifier *)
  | Ex_quan (phi : Pattern) (y : evar) :
      well_formed (patt_exists phi) ->
      theory ⊢H (instantiate (patt_exists phi) (patt_free_evar y) ---> (patt_exists phi))

  (* Existential generalization *)
  | Ex_gen (phi1 phi2 : Pattern) (x : evar) :
      well_formed phi1 -> well_formed phi2 ->
      theory ⊢H (phi1 ---> phi2) ->
      x ∉ (free_evars phi2) ->
      theory ⊢H (exists_quantify x phi1 ---> phi2)

  (* Frame reasoning *)
  (* Propagation bottom *)
  | Prop_bott_left (phi : Pattern) :
      well_formed phi ->
      theory ⊢H (patt_bott $ phi ---> patt_bott)

  | Prop_bott_right (phi : Pattern) :
      well_formed phi ->
      theory ⊢H (phi $ patt_bott ---> patt_bott)

  (* Propagation disjunction *)
  | Prop_disj_left (phi1 phi2 psi : Pattern) :
      well_formed phi1 -> well_formed phi2 -> well_formed psi ->
      theory ⊢H (((phi1 or phi2) $ psi) ---> ((phi1 $ psi) or (phi2 $ psi)))

  | Prop_disj_right (phi1 phi2 psi : Pattern) :
      well_formed phi1 -> well_formed phi2 -> well_formed psi ->
      theory ⊢H ((psi $ (phi1 or phi2)) ---> ((psi $ phi1) or (psi $ phi2)))

  (* Propagation exist *)
  | Prop_ex_left (phi psi : Pattern) :
      well_formed (ex , phi) -> well_formed psi ->
      theory ⊢H (((ex , phi) $ psi) ---> (ex , phi $ psi))

  | Prop_ex_right (phi psi : Pattern) :
      well_formed (ex , phi) -> well_formed psi ->
      theory ⊢H ((psi $ (ex , phi)) ---> (ex , psi $ phi))

  (* Framing *)
  | Framing_left (phi1 phi2 psi : Pattern) :
      well_formed psi ->
      theory ⊢H (phi1 ---> phi2) ->
      theory ⊢H ((phi1 $ psi) ---> (phi2 $ psi))

  | Framing_right (phi1 phi2 psi : Pattern) :
      well_formed psi ->
      theory ⊢H (phi1 ---> phi2) ->
      theory ⊢H ((psi $ phi1) ---> (psi $ phi2))

  (* Fixpoint reasoning *)
  (* Set Variable Substitution *)
  | Svar_subst (phi psi : Pattern) (X : svar) :
      well_formed phi -> well_formed psi ->
      theory ⊢H phi -> theory ⊢H (phi^[[svar: X ↦ psi]])

  (* Pre-Fixpoint *)
  | Pre_fixp (phi : Pattern) :
      well_formed (patt_mu phi) ->
      theory ⊢H (instantiate (patt_mu phi) (patt_mu phi) ---> (patt_mu phi))

  (* Knaster-Tarski *)
  | Knaster_tarski (phi psi : Pattern) :
      well_formed (patt_mu phi) ->
      theory ⊢H ((instantiate (patt_mu phi) psi) ---> psi) ->
      theory ⊢H ((@patt_mu Σ phi) ---> psi)

  (* Technical rules *)
  (* Existence *)
  | Existence : theory ⊢H (ex , patt_bound_evar 0)

  (* Singleton *)
  | Singleton_ctx (C1 C2 : Application_context) (phi : Pattern) (x : evar) :
      well_formed phi ->
      theory ⊢H (! ((subst_ctx C1 (patt_free_evar x and phi)) and
                   (subst_ctx C2 (patt_free_evar x and (! phi)))))

  where "theory ⊢H pattern" := (ML_proof_system theory pattern).

  Instance ML_proof_system_eqdec: forall gamma phi, EqDecision (ML_proof_system gamma phi).
  Proof. intros. intros x y.
         unfold Decision. Fail decide equality.
  Abort.

  Lemma proved_impl_wf Γ ϕ:
    Γ ⊢H ϕ -> well_formed ϕ.
  Proof.
    intros pf.
    induction pf; wf_auto2. Set Printing All.
  Qed.

  Lemma cast_proof {Γ} {ϕ} {ψ} (e : ψ = ϕ) : ML_proof_system Γ ϕ -> ML_proof_system Γ ψ.
  Proof. intros H. rewrite <- e in H. exact H. Defined.

End ml_proof_system.

Module Notations_private.

  Notation "theory ⊢H pattern" := (ML_proof_system theory pattern) (at level 95, no associativity).

End Notations_private.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e416m2e208m1_9limbs.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.


(*****************************************************)
(*****************************************************)
(****                                             ****)
(****   A formalization of the univalence axiom   ****)
(****                                             ****)
(*****************************************************)
(*****************************************************)

Definition equivalence {X Y : Set} (f : X -> Y) :=
  forall y,
  let fiber := { x | f x = y }
  in { x : fiber | forall z : fiber, x = z }.

Definition equalityToEquivalence (X Y : Set) (H : X = Y) :
  { f : X -> Y & equivalence f }.
Proof.
  rewrite <- H.
  exists (@id X).
  unfold equivalence.
  intros.
  exists (exist (fun x => x = y) y eq_refl).
  intros.
  destruct z.
  rewrite <- e.
  reflexivity.
Defined.

Axiom univalence : forall X Y, equivalence (equalityToEquivalence X Y).


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NCorder.
Require Export lemma__angletrichotomy2.
Require Export lemma__crossbar2.
Require Export lemma__equalanglesflip.
Require Export lemma__equalanglessymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelflip.
Require Export lemma__ray4.
Require Export lemma__samesideflip.
Require Export lemma__samesidesymmetric.
Require Export logic.
Require Export proposition__07.
Require Export proposition__26A.
Require Export proposition__39A.
Definition proposition__39 : forall A B C D, (euclidean__axioms.Triangle A B C) -> ((euclidean__axioms.Triangle D B C) -> ((euclidean__defs.OS A D B C) -> ((euclidean__axioms.ET A B C D B C) -> ((euclidean__axioms.neq A D) -> (euclidean__defs.Par A D B C))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
assert (* Cut *) (euclidean__defs.OS D A B C) as H4.
- assert (* Cut *) ((euclidean__defs.OS D A B C) /\ ((euclidean__defs.OS A D C B) /\ (euclidean__defs.OS D A C B))) as H4.
-- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric B C A D H1).
-- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
exact H5.
- assert (* Cut *) (euclidean__defs.OS A D C B) as H5.
-- apply (@lemma__samesideflip.lemma__samesideflip B C A D H1).
-- assert (* Cut *) (euclidean__defs.OS D A C B) as H6.
--- assert (* Cut *) ((euclidean__defs.OS D A C B) /\ ((euclidean__defs.OS A D B C) /\ (euclidean__defs.OS D A B C))) as H6.
---- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric C B A D H5).
---- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H7.
--- assert (euclidean__axioms.nCol A B C) as H7 by exact H.
assert (euclidean__axioms.nCol D B C) as H8 by exact H0.
assert (* Cut *) (euclidean__axioms.neq A B) as H9.
---- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H9.
----- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H7).
----- destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H10.
---- assert (* Cut *) (euclidean__axioms.neq B D) as H10.
----- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D)))))) as H10.
------ apply (@lemma__NCdistinct.lemma__NCdistinct D B C H8).
------ destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H17.
----- assert (* Cut *) (euclidean__axioms.neq B A) as H11.
------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H9).
------ assert (* Cut *) (euclidean__axioms.neq B C) as H12.
------- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D)))))) as H12.
-------- apply (@lemma__NCdistinct.lemma__NCdistinct D B C H8).
-------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H15.
------- assert (* Cut *) (euclidean__axioms.neq C A) as H13.
-------- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H13.
--------- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H7).
--------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H23.
-------- assert (* Cut *) (euclidean__axioms.neq C B) as H14.
--------- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D)))))) as H14.
---------- apply (@lemma__NCdistinct.lemma__NCdistinct D B C H8).
---------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H23.
--------- assert (* Cut *) (euclidean__axioms.neq C D) as H15.
---------- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C D)))))) as H15.
----------- apply (@lemma__NCdistinct.lemma__NCdistinct D B C H8).
----------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H25.
---------- assert (* Cut *) (A = A) as H16.
----------- apply (@logic.eq__refl Point A).
----------- assert (* Cut *) (C = C) as H17.
------------ apply (@logic.eq__refl Point C).
------------ assert (* Cut *) (D = D) as H18.
------------- apply (@logic.eq__refl Point D).
------------- assert (* Cut *) (B = B) as H19.
-------------- apply (@logic.eq__refl Point B).
-------------- assert (* Cut *) (euclidean__defs.Out B C C) as H20.
--------------- apply (@lemma__ray4.lemma__ray4 B C C).
----------------right.
left.
exact H17.

---------------- exact H12.
--------------- assert (* Cut *) (euclidean__defs.Out B A A) as H21.
---------------- apply (@lemma__ray4.lemma__ray4 B A A).
-----------------right.
left.
exact H16.

----------------- exact H11.
---------------- assert (* Cut *) (euclidean__defs.Out B D D) as H22.
----------------- apply (@lemma__ray4.lemma__ray4 B D D).
------------------right.
left.
exact H18.

------------------ exact H10.
----------------- assert (* Cut *) (euclidean__defs.Out C B B) as H23.
------------------ apply (@lemma__ray4.lemma__ray4 C B B).
-------------------right.
left.
exact H19.

------------------- exact H14.
------------------ assert (* Cut *) (euclidean__defs.Out C A A) as H24.
------------------- apply (@lemma__ray4.lemma__ray4 C A A).
--------------------right.
left.
exact H16.

-------------------- exact H13.
------------------- assert (* Cut *) (euclidean__defs.Out C D D) as H25.
-------------------- apply (@lemma__ray4.lemma__ray4 C D D).
---------------------right.
left.
exact H18.

--------------------- exact H15.
-------------------- assert (* Cut *) (~(~(euclidean__defs.Par A D B C))) as H26.
--------------------- intro H26.
assert (* Cut *) (~(euclidean__defs.LtA C B D C B A)) as H27.
---------------------- intro H27.
assert (* Cut *) (exists M, (euclidean__axioms.BetS A M C) /\ (euclidean__defs.Out B D M)) as H28.
----------------------- apply (@lemma__crossbar2.lemma__crossbar2 D B C A C A H27 H4 H20 H21).
----------------------- destruct H28 as [M H29].
destruct H29 as [H30 H31].
assert (* Cut *) (euclidean__defs.Par A D B C) as H32.
------------------------ apply (@proposition__39A.proposition__39A A B C D M H7 H2 H30 H31).
------------------------ apply (@H26 H32).
---------------------- assert (* Cut *) (~(euclidean__defs.LtA C B A C B D)) as H28.
----------------------- intro H28.
assert (* Cut *) (exists M, (euclidean__axioms.BetS D M C) /\ (euclidean__defs.Out B A M)) as H29.
------------------------ apply (@lemma__crossbar2.lemma__crossbar2 A B C D C D H28 H1 H20 H22).
------------------------ destruct H29 as [M H30].
destruct H30 as [H31 H32].
assert (* Cut *) (euclidean__axioms.ET D B C A B C) as H33.
------------------------- apply (@euclidean__axioms.axiom__ETsymmetric A B C D B C H2).
------------------------- assert (* Cut *) (euclidean__defs.Par D A B C) as H34.
-------------------------- apply (@proposition__39A.proposition__39A D B C A M H8 H33 H31 H32).
-------------------------- assert (* Cut *) (euclidean__defs.Par A D B C) as H35.
--------------------------- assert (* Cut *) ((euclidean__defs.Par A D B C) /\ ((euclidean__defs.Par D A C B) /\ (euclidean__defs.Par A D C B))) as H35.
---------------------------- apply (@lemma__parallelflip.lemma__parallelflip D A B C H34).
---------------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H36.
--------------------------- apply (@H26 H35).
----------------------- assert (* Cut *) (~(~(euclidean__defs.CongA C B D C B A))) as H29.
------------------------ intro H29.
assert (* Cut *) (euclidean__axioms.nCol C B A) as H30.
------------------------- assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H30.
-------------------------- apply (@lemma__NCorder.lemma__NCorder A B C H7).
-------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H38.
------------------------- assert (* Cut *) (euclidean__axioms.nCol C B D) as H31.
-------------------------- assert (* Cut *) ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol D C B) /\ (euclidean__axioms.nCol C B D))))) as H31.
--------------------------- apply (@lemma__NCorder.lemma__NCorder D B C H8).
--------------------------- destruct H31 as [H32 H33].
destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
exact H39.
-------------------------- assert (* Cut *) (euclidean__defs.LtA C B D C B A) as H32.
--------------------------- apply (@lemma__angletrichotomy2.lemma__angletrichotomy2 C B D C B A H31 H30 H29 H28).
--------------------------- apply (@H27 H32).
------------------------ assert (* Cut *) (euclidean__axioms.nCol A C B) as H30.
------------------------- assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H30.
-------------------------- apply (@lemma__NCorder.lemma__NCorder A B C H7).
-------------------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
exact H37.
------------------------- assert (* Cut *) (euclidean__axioms.Triangle A C B) as H31.
-------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H31.
--------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
--------------------------- exact H30.
-------------------------- assert (* Cut *) (euclidean__axioms.nCol D C B) as H32.
--------------------------- assert (* Cut *) ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol B C D) /\ ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol D C B) /\ (euclidean__axioms.nCol C B D))))) as H32.
---------------------------- apply (@lemma__NCorder.lemma__NCorder D B C H8).
---------------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H39.
--------------------------- assert (* Cut *) (euclidean__axioms.Triangle D C B) as H33.
---------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H33.
----------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
----------------------------- exact H32.
---------------------------- assert (* Cut *) (euclidean__defs.OS A D C B) as H34.
----------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H34.
------------------------------ apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------ exact H5.
----------------------------- assert (* Cut *) (euclidean__axioms.ET A B C D C B) as H35.
------------------------------ assert (* Cut *) ((euclidean__axioms.ET A B C B C D) /\ ((euclidean__axioms.ET A B C D C B) /\ ((euclidean__axioms.ET A B C B D C) /\ ((euclidean__axioms.ET A B C C B D) /\ (euclidean__axioms.ET A B C C D B))))) as H35.
------------------------------- apply (@euclidean__axioms.axiom__ETpermutation A B C D B C H2).
------------------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H38.
------------------------------ assert (* Cut *) (euclidean__axioms.ET D C B A B C) as H36.
------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H36.
-------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
-------------------------------- apply (@euclidean__axioms.axiom__ETsymmetric A B C D C B H35).
------------------------------- assert (* Cut *) (euclidean__axioms.ET D C B A C B) as H37.
-------------------------------- assert (* Cut *) ((euclidean__axioms.ET D C B B C A) /\ ((euclidean__axioms.ET D C B A C B) /\ ((euclidean__axioms.ET D C B B A C) /\ ((euclidean__axioms.ET D C B C B A) /\ (euclidean__axioms.ET D C B C A B))))) as H37.
--------------------------------- apply (@euclidean__axioms.axiom__ETpermutation D C B A B C H36).
--------------------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H40.
-------------------------------- assert (* Cut *) (euclidean__axioms.ET A C B D C B) as H38.
--------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H38.
---------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
---------------------------------- apply (@euclidean__axioms.axiom__ETsymmetric D C B A C B H37).
--------------------------------- assert (* Cut *) (~(euclidean__defs.LtA B C D B C A)) as H39.
---------------------------------- intro H39.
assert (* Cut *) (exists M, (euclidean__axioms.BetS A M B) /\ (euclidean__defs.Out C D M)) as H40.
----------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H40.
------------------------------------ apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------------ apply (@lemma__crossbar2.lemma__crossbar2 D C B A B A H39 H6 H23 H24).
----------------------------------- destruct H40 as [M H41].
destruct H41 as [H42 H43].
assert (* Cut *) (euclidean__defs.Par A D C B) as H44.
------------------------------------ assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H44.
------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------------- apply (@proposition__39A.proposition__39A A C B D M H31 H38 H42 H43).
------------------------------------ assert (* Cut *) (euclidean__defs.Par A D B C) as H45.
------------------------------------- assert (* Cut *) ((euclidean__defs.Par D A C B) /\ ((euclidean__defs.Par A D B C) /\ (euclidean__defs.Par D A B C))) as H45.
-------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip A D C B H44).
-------------------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H48.
------------------------------------- apply (@H26 H45).
---------------------------------- assert (* Cut *) (~(euclidean__defs.LtA B C A B C D)) as H40.
----------------------------------- intro H40.
assert (* Cut *) (exists M, (euclidean__axioms.BetS D M B) /\ (euclidean__defs.Out C A M)) as H41.
------------------------------------ assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H41.
------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------------- apply (@lemma__crossbar2.lemma__crossbar2 A C B D B D H40 H34 H23 H25).
------------------------------------ destruct H41 as [M H42].
destruct H42 as [H43 H44].
assert (* Cut *) (euclidean__axioms.ET D C B A C B) as H45.
------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H45.
-------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
-------------------------------------- exact H37.
------------------------------------- assert (* Cut *) (euclidean__defs.Par D A C B) as H46.
-------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H46.
--------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
--------------------------------------- apply (@proposition__39A.proposition__39A D C B A M H33 H45 H43 H44).
-------------------------------------- assert (* Cut *) (euclidean__defs.Par A D B C) as H47.
--------------------------------------- assert (* Cut *) ((euclidean__defs.Par A D C B) /\ ((euclidean__defs.Par D A B C) /\ (euclidean__defs.Par A D B C))) as H47.
---------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip D A C B H46).
---------------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H51.
--------------------------------------- apply (@H26 H47).
----------------------------------- assert (* Cut *) (~(~(euclidean__defs.CongA B C D B C A))) as H41.
------------------------------------ intro H41.
assert (* Cut *) (euclidean__axioms.nCol B C A) as H42.
------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol C B A) /\ ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol A B C) /\ (euclidean__axioms.nCol B C A))))) as H42.
-------------------------------------- apply (@lemma__NCorder.lemma__NCorder A C B H31).
-------------------------------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H50.
------------------------------------- assert (* Cut *) (euclidean__axioms.nCol B C D) as H43.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.nCol C D B) /\ ((euclidean__axioms.nCol C B D) /\ ((euclidean__axioms.nCol B D C) /\ ((euclidean__axioms.nCol D B C) /\ (euclidean__axioms.nCol B C D))))) as H43.
--------------------------------------- apply (@lemma__NCorder.lemma__NCorder D C B H33).
--------------------------------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H51.
-------------------------------------- assert (* Cut *) (euclidean__defs.LtA B C D B C A) as H44.
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H44.
---------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
---------------------------------------- apply (@lemma__angletrichotomy2.lemma__angletrichotomy2 B C D B C A H43 H42 H41 H40).
--------------------------------------- apply (@H29).
----------------------------------------intro H45.
apply (@H39 H44).

------------------------------------ assert (* Cut *) (euclidean__defs.CongA B C A B C D) as H42.
------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H42.
-------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
-------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H43.
--------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
--------------------------------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric B C D B C A H42).
------------------------------------- assert (* Cut *) (euclidean__axioms.Cong B C B C) as H43.
-------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H43.
--------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H44.
---------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
---------------------------------------- apply (@euclidean__axioms.cn__congruencereflexive B C).
-------------------------------------- assert (* Cut *) (euclidean__defs.CongA D B C A B C) as H44.
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H44.
---------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
---------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H45.
----------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
----------------------------------------- apply (@lemma__equalanglesflip.lemma__equalanglesflip C B D C B A H45).
--------------------------------------- assert (* Cut *) (euclidean__defs.CongA A B C D B C) as H45.
---------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H45.
----------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
----------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H46.
------------------------------------------ apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------------------ apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric D B C A B C H44).
---------------------------------------- assert (* Cut *) ((euclidean__axioms.Cong A B D B) /\ ((euclidean__axioms.Cong A C D C) /\ (euclidean__defs.CongA B A C B D C))) as H46.
----------------------------------------- assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H46.
------------------------------------------ apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
------------------------------------------ assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H47.
------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
------------------------------------------- apply (@proposition__26A.proposition__26A A B C D B C H7 H8 H45 H42 H43).
----------------------------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H47.
------------------------------------------ destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
assert (* Cut *) ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq B D)))))) as H51.
------------------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct D C B H33).
------------------------------------------- destruct H51 as [H52 H53].
destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
exact H60.
------------------------------------------ assert (* Cut *) (A = D) as H48.
------------------------------------------- destruct H46 as [H48 H49].
destruct H49 as [H50 H51].
assert (* Cut *) (euclidean__defs.CongA B C D B C A) as H52.
-------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA B C D B C A) H41).
-------------------------------------------- assert (* Cut *) (euclidean__defs.CongA C B D C B A) as H53.
--------------------------------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.CongA C B D C B A) H29).
--------------------------------------------- apply (@proposition__07.proposition__07 B C A D H47 H48 H50 H1).
------------------------------------------- apply (@H3 H48).
--------------------- apply (@euclidean__tactics.NNPP (euclidean__defs.Par A D B C)).
----------------------intro H27.
destruct H7 as [H28 H29].
destruct H8 as [H30 H31].
destruct H29 as [H32 H33].
destruct H31 as [H34 H35].
destruct H33 as [H36 H37].
destruct H35 as [H38 H39].
destruct H37 as [H40 H41].
destruct H39 as [H42 H43].
destruct H41 as [H44 H45].
destruct H43 as [H46 H47].
assert (* Cut *) (False) as H48.
----------------------- apply (@H26 H27).
----------------------- contradiction H48.

Qed.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import Coq.Lists.List.

Require Import Relation.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Dynamic.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationAcc.
Require Import ValidationUtil.
Require Import ValidationAll.
Require Import ValidationEqtp.
Require Import ValidationEqual.
Require Import ValidationExist.
Require Import ValidationSigma.
Require Import ValidationFuture.
Require Import ValidationIstp.
Require Import ValidationRec.
Require Import ValidationLevel.
Require Import ValidationMisc.
Require Import ValidationMu.
Require Import ValidationNat.
Require Import ValidationOf.
Require Import ValidationPi.
Require Import ValidationQuotient.
Require Import ValidationSimple.
Require Import ValidationSet.
Require Import ValidationSquash.
Require Import ValidationSubtype.
Require Import ValidationSum.
Require Import ValidationUniv.

(* All the rules generated by the rule generator are correct. *)

Theorem all_rules_valid :
  fold_right (fun P Q => P * Q)%type unit all_obligations.
Proof.
cbn.
repeat split.

exact forallForm_valid.
exact forallEq_valid.
exact forallFormUniv_valid.
exact forallEqUniv_valid.
exact forallSub_valid.
exact forallIntroOf_valid.
exact forallIntroEq_valid.
exact forallIntro_valid.
exact forallElimOf_valid.
exact forallElimEq_valid.
exact forallElim_valid.
exact forallEta_valid.
exact forallExt_valid.
exact forallOfExt_valid.
exact forallFormInv1_valid.
exact forallFormInv2_valid.
exact arrowForm_valid.
exact arrowEq_valid.
exact arrowFormUniv_valid.
exact arrowEqUniv_valid.
exact arrowSub_valid.
exact arrowForallSub_valid.
exact forallArrowSub_valid.
exact arrowIntroOf_valid.
exact arrowIntroEq_valid.
exact arrowIntro_valid.
exact arrowElimOf_valid.
exact arrowElimEq_valid.
exact arrowElim_valid.
exact arrowEta_valid.
exact arrowExt_valid.
exact arrowOfExt_valid.
exact arrowFormInv1_valid.
exact arrowFormInv2_valid.
exact tarrowKind_valid.
exact tarrowKindEq_valid.
exact tarrowForm_valid.
exact tarrowEq_valid.
exact tarrowFormUniv_valid.
exact tarrowEqUniv_valid.
exact tarrowArrowEq_valid.
exact tarrowArrowEqUniv_valid.
exact tarrowIntroOf_valid.
exact tarrowIntroEq_valid.
exact tarrowIntro_valid.
exact tarrowElimOf_valid.
exact tarrowElimEq_valid.
exact tarrowElim_valid.
exact tarrowEta_valid.
exact tarrowExt_valid.
exact karrowKind_valid.
exact karrowKindEq_valid.
exact karrowForm_valid.
exact karrowEq_valid.
exact karrowFormUniv_valid.
exact karrowEqUniv_valid.
exact karrowArrowEq_valid.
exact karrowArrowEqUniv_valid.
exact karrowIntroOf_valid.
exact karrowIntroEq_valid.
exact karrowIntro_valid.
exact karrowElimOf_valid.
exact karrowElimEq_valid.
exact karrowElim_valid.
exact karrowEta_valid.
exact karrowExt_valid.
exact intersectForm_valid.
exact intersectEq_valid.
exact intersectFormUniv_valid.
exact intersectEqUniv_valid.
exact intersectIntroOf_valid.
exact intersectIntroEq_valid.
exact intersectIntro_valid.
exact intersectElimOf_valid.
exact intersectElimEq_valid.
exact intersectElim_valid.
exact intersectFormInv1_valid.
exact intersectFormInv2_valid.
exact guardForm_valid.
exact guardEq_valid.
exact guardFormUniv_valid.
exact guardEqUniv_valid.
exact guardIntroOf_valid.
exact guardIntroEq_valid.
exact guardIntro_valid.
exact guardElimOf_valid.
exact guardElimEq_valid.
exact guardElim_valid.
exact guardSatEq_valid.
exact existsForm_valid.
exact existsEq_valid.
exact existsFormUniv_valid.
exact existsEqUniv_valid.
exact existsSub_valid.
exact existsIntroOf_valid.
exact existsIntroEq_valid.
exact existsIntro_valid.
exact existsElim1Of_valid.
exact existsElim1Eq_valid.
exact existsElim2Of_valid.
exact existsElim2Eq_valid.
exact existsEta_valid.
exact existsExt_valid.
exact existsLeft_valid.
exact existsFormInv1_valid.
exact existsFormInv2_valid.
exact existsFormInv2Eq_valid.
exact prodKind_valid.
exact prodKindEq_valid.
exact prodForm_valid.
exact prodEq_valid.
exact prodFormUniv_valid.
exact prodEqUniv_valid.
exact prodExistsEq_valid.
exact prodExistsEqUniv_valid.
exact prodSub_valid.
exact prodExistsSub_valid.
exact existsProdSub_valid.
exact prodIntroOf_valid.
exact prodIntroEq_valid.
exact prodIntro_valid.
exact prodElim1Of_valid.
exact prodElim1Eq_valid.
exact prodElim1_valid.
exact prodElim2Of_valid.
exact prodElim2Eq_valid.
exact prodElim2_valid.
exact prodEta_valid.
exact prodExt_valid.
exact prodLeft_valid.
exact prodFormInv1_valid.
exact prodFormInv2_valid.
exact sumForm_valid.
exact sumEq_valid.
exact sumFormUniv_valid.
exact sumEqUniv_valid.
exact sumSub_valid.
exact sumIntro1Of_valid.
exact sumIntro1Eq_valid.
exact sumIntro1_valid.
exact sumIntro2Of_valid.
exact sumIntro2Eq_valid.
exact sumIntro2_valid.
exact sumElimOf_valid.
exact sumElimOfNondep_valid.
exact sumElimEq_valid.
exact sumElim_valid.
exact sumElimNondep_valid.
exact sumElimIstype_valid.
exact sumElimEqtype_valid.
exact sumcaseType_valid.
exact sumFormInv1_valid.
exact sumFormInv2_valid.
exact futureKind_valid.
exact futureKindEq_valid.
exact futureForm_valid.
exact futureEq_valid.
exact futureFormUniv_valid.
exact futureEqUniv_valid.
exact futureSub_valid.
exact futureIntroOf_valid.
exact futureIntroEq_valid.
exact futureIntro_valid.
exact futureElimOf_valid.
exact futureElimOfLetnext_valid.
exact futureElimOfLetnextNondep_valid.
exact futureElimEq_valid.
exact futureElimIstype_valid.
exact futureElimIstypeLetnext_valid.
exact futureElimEqtype_valid.
exact futureEta_valid.
exact futureExt_valid.
exact futureLeft_valid.
exact recKind_valid.
exact recKindEq_valid.
exact recForm_valid.
exact recEq_valid.
exact recFormUniv_valid.
exact recEqUniv_valid.
exact recUnroll_valid.
exact recUnrollUniv_valid.
exact recBisimilar_valid.
exact muForm_valid.
exact muEq_valid.
exact muFormUniv_valid.
exact muEqUniv_valid.
exact muUnroll_valid.
exact muUnrollUniv_valid.
exact muInd_valid.
exact muIndUniv_valid.
exact voidForm_valid.
exact voidEq_valid.
exact voidFormUniv_valid.
exact voidEqUniv_valid.
exact voidElim_valid.
exact voidSub_valid.
exact abortType_valid.
exact unitKind_valid.
exact unitKindEq_valid.
exact unitForm_valid.
exact unitEq_valid.
exact unitFormUniv_valid.
exact unitEqUniv_valid.
exact unitIntroOf_valid.
exact unitIntro_valid.
exact unitExt_valid.
exact unitLeft_valid.
exact boolForm_valid.
exact boolEq_valid.
exact boolFormUniv_valid.
exact boolEqUniv_valid.
exact boolIntro1Of_valid.
exact boolIntro2Of_valid.
exact boolElimOf_valid.
exact boolElimEq_valid.
exact boolElim_valid.
exact boolElimIstype_valid.
exact boolElimEqtype_valid.
exact boolLeft_valid.
exact iteType_valid.
exact natForm_valid.
exact natEq_valid.
exact natFormUniv_valid.
exact natEqUniv_valid.
exact natElimEq_valid.
exact natElimEqtype_valid.
exact zeroType_valid.
exact succType_valid.
exact univKind_valid.
exact univKindEq_valid.
exact univForm_valid.
exact univEq_valid.
exact univFormUniv_valid.
exact univFormUnivSucc_valid.
exact univEqUniv_valid.
exact univCumulativeOf_valid.
exact univCumulativeEq_valid.
exact univCumulativeSuccOf_valid.
exact univSub_valid.
exact univForgetOf_valid.
exact univForgetEq_valid.
exact univIntroEqtype_valid.
exact univFormInv_valid.
exact kindForm_valid.
exact kindEq_valid.
exact kindFormUniv_valid.
exact kindEqUniv_valid.
exact kindForgetOf_valid.
exact kindForgetEq_valid.
exact kindUnivSub_valid.
exact levelForm_valid.
exact levelEq_valid.
exact levelFormUniv_valid.
exact levelEqUniv_valid.
exact lleqForm_valid.
exact lleqEq_valid.
exact lleqFormUniv_valid.
exact lleqEqUniv_valid.
exact lzeroLevel_valid.
exact lsuccLevel_valid.
exact lsuccEq_valid.
exact lmaxLevel_valid.
exact lmaxEq_valid.
exact lleqRefl_valid.
exact lleqTrans_valid.
exact lleqZero_valid.
exact lleqSucc_valid.
exact lleqIncrease_valid.
exact lleqMaxL_valid.
exact lleqMaxR1_valid.
exact lleqMaxR2_valid.
exact lleqResp_valid.
exact lsuccMaxDistTrans_valid.
exact lzeroType_valid.
exact lsuccType_valid.
exact lmaxType_valid.
exact eqForm_valid.
exact eqEq_valid.
exact eqFormUniv_valid.
exact eqEqUniv_valid.
exact eqIntro_valid.
exact eqElim_valid.
exact eqExt_valid.
exact eqLeft_valid.
exact eqRefl_valid.
exact eqSymm_valid.
exact eqTrans_valid.
exact eqFormInv1_valid.
exact eqFormInv2_valid.
exact eqFormInv3_valid.
exact ofForm_valid.
exact ofEq_valid.
exact ofFormUniv_valid.
exact ofEqUniv_valid.
exact ofIntro_valid.
exact ofElim_valid.
exact ofTrivialize_valid.
exact ofExt_valid.
exact ofLeft_valid.
exact ofEquand1_valid.
exact ofEquand2_valid.
exact eqtpForm_valid.
exact eqtpEq_valid.
exact eqtpFormUniv_valid.
exact eqtpEqUniv_valid.
exact eqtpIntro_valid.
exact eqtpElim_valid.
exact eqtpExt_valid.
exact eqtpLeft_valid.
exact eqtpFunct_valid.
exact equivalenceOf_valid.
exact equivalenceEq_valid.
exact equivalence_valid.
exact equivalenceLeft_valid.
exact eqtpRefl_valid.
exact eqtpSymm_valid.
exact eqtpTrans_valid.
exact istpForm_valid.
exact istpEq_valid.
exact istpFormUniv_valid.
exact istpEqUniv_valid.
exact istpIntro_valid.
exact istpElim_valid.
exact istpExt_valid.
exact istpLeft_valid.
exact inhabitedForm_valid.
exact subtypeForm_valid.
exact subtypeEq_valid.
exact subtypeFormUniv_valid.
exact subtypeEqUniv_valid.
exact subtypeIntro_valid.
exact subtypeExt_valid.
exact subtypeLeft_valid.
exact subsumptionOf_valid.
exact subsumptionEq_valid.
exact subsumption_valid.
exact subsumptionLeft_valid.
exact subtypeRefl_valid.
exact subtypeReflEqtype_valid.
exact subtypeTrans_valid.
exact subtypeIstp1_valid.
exact subtypeIstp2_valid.
exact setForm_valid.
exact setEq_valid.
exact setFormUniv_valid.
exact setEqUniv_valid.
exact setWeakenOf_valid.
exact setWeakenEq_valid.
exact setWeaken_valid.
exact setIntroOf_valid.
exact setIntroEq_valid.
exact setIntro_valid.
exact setIntroOfSquash_valid.
exact squashIntroOfSquash_valid.
exact setElim_valid.
exact setLeft_valid.
exact setSquash_valid.
exact setFormInv_valid.
exact setSubElim_valid.
exact squashForm_valid.
exact squashEq_valid.
exact squashFormUniv_valid.
exact squashEqUniv_valid.
exact squashIntroOf_valid.
exact squashIntro_valid.
exact squashElim_valid.
exact squashExt_valid.
exact squashLeft_valid.
exact quotientForm_valid.
exact quotientEq_valid.
exact quotientFormUniv_valid.
exact quotientEqUniv_valid.
exact quotientIntroOf_valid.
exact quotientIntroEq_valid.
exact quotientElimOf_valid.
exact quotientElimEq_valid.
exact quotientElimIstype_valid.
exact quotientElimEqtype_valid.
exact quotientDescent_valid.
exact quotientLeft_valid.
exact quotientLeftRefl_valid.
exact quotientLeftIstype_valid.
exact quotientLeftEqtype_valid.
exact quotientLeftOf_valid.
exact quotientLeftEq_valid.
exact quotientLeftOfDep_valid.
exact quotientLeftEqDep_valid.
exact quotientFormInv_valid.
exact iforallForm_valid.
exact iforallEq_valid.
exact iforallFormUniv_valid.
exact iforallEqUniv_valid.
exact iforallIntroOf_valid.
exact iforallIntroEq_valid.
exact iforallIntro_valid.
exact iforallElimOf_valid.
exact iforallElimEq_valid.
exact iforallElim_valid.
exact foralltpForm_valid.
exact foralltpEq_valid.
exact foralltpIntroOf_valid.
exact foralltpIntroEq_valid.
exact foralltpIntro_valid.
exact foralltpElimOf_valid.
exact foralltpElimEq_valid.
exact foralltpElim_valid.
exact iexistsForm_valid.
exact iexistsEq_valid.
exact iexistsFormUniv_valid.
exact iexistsEqUniv_valid.
exact iexistsIntroOf_valid.
exact iexistsIntroEq_valid.
exact iexistsIntro_valid.
exact iexistsElimOf_valid.
exact iexistsElimEq_valid.
exact iexistsElim_valid.
exact iexistsElimIstype_valid.
exact iexistsElimEqtype_valid.
exact substitution_valid.
exact substitutionSimple_valid.
exact generalize_valid.
exact assert_valid.
exact assert'_valid.
exact inhabitant_valid.
exact letForm_valid.
exact eeqtpSymm_valid.
exact weakenEqtpEeqtp_valid.
exact accInd_valid.
Qed.

(* Hardcoded rules *)

Lemma hypothesis_valid :
  forall G1 A G2,
    tr
      (G2 ++ hyp_tm A :: G1)
      (Defs.dof (var (length G2)) (subst (sh (S (length G2))) A)).
Proof.
prepare.
intros G1 a G2.
apply tr_hyp_tm.
replace (length G2) with (0 + length G2) by auto.
apply index_app_right.
apply index_0.
Qed.

Lemma hypothesisOf_valid :
  forall G1 A G2,
    tr
      (G2 ++ hyp_tm A :: G1)
      (Defs.dof Defs.triv (app (app Defs.of (subst (sh (S (length G2))) A)) (var (length G2)))).
Proof.
prepare.
intros G1 a G2.
apply tr_hyp_tm.
replace (length G2) with (0 + length G2) by auto.
apply index_app_right.
apply index_0.
Qed.

Lemma hypothesisEq_valid :
  forall G1 A G2,
    tr
      (G2 ++ hyp_tm A :: G1)
      (Defs.dof Defs.triv (app (app (app Defs.eq (subst (sh (S (length G2))) A)) (var (length G2))) (var (length G2)))).
Proof.
prepare.
intros G1 a G2.
apply tr_hyp_tm.
replace (length G2) with (0 + length G2) by auto.
apply index_app_right.
apply index_0.
Qed.

Lemma hypothesisOfTp_valid :
  forall G1 G2,
    tr
      (G2 ++ hyp_tp :: G1)
      (Defs.dof Defs.triv (app Defs.istp (var (length G2)))).
Proof.
prepare.
intros G1 G2.
apply tr_hyp_tp.
replace (length G2) with (0 + length G2) by auto.
apply index_app_right.
apply index_0.
Qed.

Lemma hypothesisEqTp_valid :
  forall G1 G2,
    tr
      (G2 ++ hyp_tp :: G1)
      (Defs.dof Defs.triv (app (app Defs.eqtp (var (length G2))) (var (length G2)))).
Proof.
prepare.
intros G1 G2.
apply tr_hyp_tp.
replace (length G2) with (0 + length G2) by auto.
apply index_app_right.
apply index_0.
Qed.

Lemma weaken_valid :
  forall G1 G2 G3 A M,
    tr (G3 ++ G1) (Defs.dof M A)
    -> tr
         (substctx (sh (length G2)) G3 ++ G2 ++ G1)
         (Defs.dof
            (subst (under (length G3) (sh (length G2))) M)
            (subst (under (length G3) (sh (length G2))) A)).
Proof.
prepare.
intros G1 G2 G3 a m H.
apply weakening.
  {
  simpsub.
  rewrite <- compose_assoc.
  rewrite -> compose_sh_unlift.
  simpsub.
  auto.
  }

  {
  rewrite -> length_substctx.
  simpsub.
  rewrite <- !compose_under.
  rewrite <- !compose_assoc.
  rewrite -> compose_sh_unlift.
  simpsub.
  auto.
  }

  {
  rewrite -> length_substctx.
  simpsub.
  rewrite <- !compose_under.
  rewrite -> compose_sh_unlift.
  simpsub.
  auto.
  }
Qed.

Lemma compose_dots_dots :
  forall obj (i j k l m n : nat) (s s' : @sub obj),
    i >= l
    -> i - l + j <= n
    -> compose (dots i j s) (dots k l (dots m n s'))
       = dots (i - l + m) j (compose s (dots k l (dots m n s'))).
Proof.
intros obj i j k l m n s s' Hlo Hhi.
revert i s Hlo Hhi.
induct j.

(* 0 *)
{
intros i s Hlo Hhi.
cbn.
auto.
}

(* S *)
{
intros j IH i s Hlo Hhi.
cbn.
rewrite -> IH; try omega.
f_equal.
simpsub.
f_equal.
rewrite -> project_dots_ge; try omega.
rewrite -> project_dots_lt; try omega.
f_equal.
omega.
}
Qed.

Lemma exchange_valid :
  forall G1 G2 G3 G4 A M,
    let l := length G4 in
    let m := length G3 in
    let n := length G2 in
    let s := dots m n (dots 0 m (sh (m+n)))
    in
      tr
        (G4 ++ substctx (sh m) G2 ++ G3 ++ G1)
        (Defs.dof M A)
      -> tr
           (substctx s G4 ++ substctx (sh n) G3 ++ G2 ++ G1)
           (Defs.dof
              (subst (under l s) M)
              (subst (under l s) A)).
Proof.
prepare.
intros G1 G2 G3 G4 a p H.
set (l := length G4).
set (m := length G3).
set (n := length G2).
apply exchange.
  {
  simpsub.
  fold n.
  rewrite <- compose_assoc.
  rewrite -> compose_sh_unlift.
  auto.
  }
rewrite -> !length_substctx.
simpsub.
fold l.
fold m.
fold n.
rewrite <- compose_under.
rewrite -> compose_dots_dots; try omega.
replace (m - m + 0) with 0 by omega.
rewrite -> compose_dots_le; try omega.
cbn [Nat.add].
rewrite -> compose_sh_dots_ge; try omega.
replace (m + n - m) with n by omega.
rewrite -> compose_sh_dots_ge; try omega.
replace (n - n) with 0 by omega.
simpsub.
cbn [Nat.add].
rewrite -> Nat.add_comm.
rewrite <- compose_sh_sh.
rewrite <- (compose_dots_sh _ 0 m (sh m) n).
rewrite <- under_dots.
rewrite -> under_sum.
so (eqsub_trans _#4 (eqsub_under _ (l + n) _ _ (eqsub_dots_id obj m)) (eqsub_under_id _ _)) as Heq.
rewrite -> Heq.
clear Heq.
so (eqsub_trans _#4 (eqsub_under _ n _ _ (eqsub_dots_id obj m)) (eqsub_under_id _ _)) as Heq.
rewrite -> (substctx_eqsub _#4 Heq).
clear Heq.
rewrite -> compose_sh_unlift.
simpsub.
auto.
Qed.

Hint Rewrite def_inl def_inr def_sum def_sumcase : prepare.

(* The sumLeft rule is hardcoded because it involves a pattern not used in any other
   rule.  (To wit: the extract interacts with the far end of the context.)  There seems
   to be no robustness advantage to extending the rule generator with functionality
   that will only be used once.
*)

Lemma sumLeft_valid :
  forall G1 G2 A B C M N,
    tr
      (substctx (dot (app Defs.inl (var 0)) (sh 1)) G2 ++ hyp_tm A :: G1)
      (Defs.dof M (subst (under (length G2) (dot (app Defs.inl (var 0)) (sh 1))) C))
    -> tr
         (substctx (dot (app Defs.inr (var 0)) (sh 1)) G2 ++ hyp_tm B :: G1)
         (Defs.dof N (subst (under (length G2) (dot (app Defs.inr (var 0)) (sh 1))) C))
    -> tr
         (G2 ++ hyp_tm (app (app Defs.sum A) B) :: G1)
         (Defs.dof
            (app
               (app
                  (app
                     Defs.sumcase
                     (var (length G2)))
                  (lam (subst (dots 1 (length G2) (dot (var 0) (sh (S (S (length G2)))))) M)))
               (lam (subst (dots 1 (length G2) (dot (var 0) (sh (S (S (length G2)))))) N)))
            C).
Proof.
prepare.
intros G1 G2 a b c m n Hl Hr.
unfold Defined.sumcase.
unfold Defined.sumleft in Hl.
unfold Defined.sumright in Hr.
set (i := length G2).
assert (forall m,
          @equiv obj
            (subst1 (ppi2 (var i)) (subst (dots 1 i (dot (var 0) (sh (S (S i))))) m))
            (subst (under i (dot (ppi2 (var 0)) sh1)) m)) as Hequiv.
  {
  clear_all.
  intro m.
  apply steps_equiv.
  replace (ppi2 (var i)) with (@subst obj (sh i) (ppi2 (var 0))).
  2:{
    simpsub.
    rewrite -> Nat.add_0_r.
    auto.
    }
  replace (sh (S (S i))) with (@sh obj (S (1 + i))) by auto.
  rewrite -> subst1_dots_under.
  apply star_refl.
  }
rewrite -> !Hequiv; clear Hequiv.
replace (bite (ppi1 (var i))
           (subst (under i (dot (ppi2 (var 0)) sh1)) m)
           (subst (under i (dot (ppi2 (var 0)) sh1)) n))
   with (subst
           (under i (dot (ppi2 (var 0)) (dot (ppi1 (var 0)) sh1)))
           (bite (var (S i))
              (subst (under i (dot (var 0) (sh 2))) m)
              (subst (under i (dot (var 0) (sh 2))) n))).
2:{
  simpsub.
  rewrite -> !project_under_geq; [| omega].
  replace (S i - i) with 1 by omega.
  simpsub.
  rewrite -> Nat.add_0_r.
  rewrite <- compose_under.
  simpsub.
  reflexivity.
  }
apply tr_sigma_eta_hyp.
replace (substctx (dot (ppair (var 1) (var 0)) (sh 2)) G2 ++ hyp_tm (bite (var 0) (subst sh1 a) (subst sh1 b)) :: hyp_tm booltp :: G1)
   with ((substctx (dot (ppair (var 1) (var 0)) (sh 2)) G2 ++ hyp_tm (bite (var 0) (subst sh1 a) (subst sh1 b)) :: nil) ++ hyp_tm booltp :: G1).
2:{
  rewrite <- app_assoc.
  rewrite <- app_comm_cons.
  cbn.
  reflexivity.
  }
set (j := length (substctx (dot (ppair (var 1) (var 0)) (sh 2)) G2 ++ [hyp_tm (bite (var 0) (subst sh1 a) (subst sh1 b))])).
replace (under i (dot (var 0) (sh 2))) with (@under obj (S i) sh1).
2:{
  replace (S i) with (i + 1) by omega.
  rewrite <- under_sum.
  auto.
  }
replace (S i) with j.
2:{
  subst i j.
  rewrite -> app_length.
  rewrite -> length_substctx.
  cbn.
  omega.
  }
apply tr_booltp_eta_hyp.
  {
  rewrite -> app_length.
  rewrite -> length_substctx.
  cbn [length].
  replace (length G2 + 1) with (S (length G2)) by omega.
  rewrite -> substctx_app.
  cbn [length].
  simpsub.
  rewrite <- app_assoc.
  rewrite <- app_comm_cons.
  cbn [List.app].
  assert (equiv (bite btrue a b) a) as Hequiv.
    {
    apply steps_equiv.
    apply star_one.
    apply step_bite2.
    }
  rewrite -> Hequiv.
  force_exact Hl.
  f_equal.
  f_equal.
  rewrite <- under_succ.
  replace (S (length G2)) with (length G2 + 1) by omega.
  rewrite <- under_sum.
  rewrite <- compose_under.
  simpsub.
  reflexivity.
  }

  {
  rewrite -> app_length.
  rewrite -> length_substctx.
  cbn [length].
  replace (length G2 + 1) with (S (length G2)) by omega.
  rewrite -> substctx_app.
  cbn [length].
  simpsub.
  rewrite <- app_assoc.
  rewrite <- app_comm_cons.
  cbn [List.app].
  assert (equiv (bite bfalse a b) b) as Hequiv.
    {
    apply steps_equiv.
    apply star_one.
    apply step_bite3.
    }
  rewrite -> Hequiv.
  force_exact Hr.
  f_equal.
  f_equal.
  rewrite <- under_succ.
  replace (S (length G2)) with (length G2 + 1) by omega.
  rewrite <- under_sum.
  rewrite <- compose_under.
  simpsub.
  reflexivity.
  }
Qed.

(* The remaining rules are:

   1. the reduction rules
   2. checkPositive and checkNegative
   3. the rules pertaining to let hypotheses
   4. the rules pertaining to native integers

   The reduction rules follow immediately from tr_compute and tr_compute_hyp.

   The correctness of checkPositive and checkNegative follow immediately
   from tr_positive_algorithm, and tr_negative_algorithm, assuming the checker
   is implemented correctly with respect to the formal algorithm.

   The let-hypothesis rules pertain to a definition mechanism in the proof
   assistant that does not exist in the type theory.  But the rules are simple
   and it is easy to see they are correct.

   The integer rules cannot be proven correct because native integers do not
   exist in the type theory.  However, all the integer rules do is either
   (a) assert the existence of the integer type, (b) assert the membership of
   native integer literals in the integer type, or (c) establish an isomorphism
   between native integers and defined integers (as quotiented pairs of natural
   numbers).  Thus, we can view the integer type as referring to the defined
   integer type, and the integer literals as referring to representatives of
   equivalence classes in that type.  The correctness of the isomorphism code
   is apparent by inspection.
*)


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


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

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

Print Assumptions sub.


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

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

Print Assumptions carry.


Require Export XR_Rlt_0_sqr.
Require Export XR_R1_neq_R0.

Local Open Scope R_scope.

Lemma Rlt_0_1 : R0 < R1.
Proof.
  rewrite <- Rmult_1_l with R1.
  fold (Rsqr R1).
  apply Rlt_0_sqr.
  exact R1_neq_R0.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Annexes.suma.

Section euclid_5_original_euclid.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma euclid_5__original_euclid : euclid_5 -> euclid_s_parallel_postulate.
Proof.
  intros eucl A B C D P Q R Hos HIsi HSuma HNBet.
  assert(HM := midpoint_existence B C).
  destruct HM as [M].
  assert(HD' := symmetric_point_construction D C).
  destruct HD' as [D'].
  assert(HE := symmetric_point_construction D' M).
  destruct HE as [E].
  assert(Hdiff := HSuma).
  apply suma_distincts in Hdiff.
  spliter.
  assert_diffs.
  assert(HNCol1 : ~ Col B C A) by (apply (one_side_not_col123 _ _ _ D); auto).
  assert(HNCol2 : ~ Col B C D) by (apply (one_side_not_col123 _ _ _ A); Side).
  assert(HNCol3 : ~ Col M C D) by (intro; apply HNCol2; ColR).
  assert(HNCol4 : ~ Col M C D') by (intro; apply HNCol3; ColR).
  assert_diffs.
  assert(HNCol5 : ~ Col D' C B) by (intro; apply HNCol4; ColR).
  assert(HNCol6 : ~ Col M C E) by (intro; apply HNCol4; ColR).
  assert(HSAS := l11_49 C M D' B M E).
  destruct HSAS as [HCong HSAS]; Cong.
    apply l11_14; Between.
  destruct HSAS as [HConga1 HConga2]; auto.
  assert_diffs.
  assert (Hts : TS C B D D') by (apply bet__ts; Between; Col).
  assert(HA' : InAngle A C B E).
  { apply lea_in_angle; auto.
    - apply (l11_30 A B C B C D').
        apply (sams_chara D); Between; SumA.
        apply conga_pseudo_refl; auto.
      apply (l11_10 M C D' M B E); Out.

    - exists D'.
      split.
      { repeat split; auto.
          intro; apply HNCol4; ColR.
        exists M.
        split; [Col|Between].
      }
      apply (l9_8_2 _ _ D); Side.
  }
  destruct HA' as [_ [_ [_ [A' [HBet [Habs|Hout]]]]]].
  { subst.
    exfalso.
    apply HNCol5; ColR.
  }

  assert(HY := eucl B C E D' M A').
  destruct HY as [Y HY]; Col; Cong; repeat split; Between.
    intro; subst; apply HNCol1; ColR.
  { intro.
    subst.
    apply HNBet.
    apply (bet_conga__bet D' C D); Between.
    apply (suma2__conga A B C B C D); auto.
    apply l6_6 in Hout.
    apply (conga3_suma__suma D' C B B C D D' C D); try (apply conga_refl); SumA.
    apply (l11_10 D' C M E B M); Out; CongA.
  }
  unfold BetS in HY.
  spliter.
  exists Y.
  split.
    apply (l6_7 _ _ A'); Out.
  apply (l6_2 _ _ D'); Between.
Qed.

End euclid_5_original_euclid.


(* Definitions for public key encryption. *)

Set Implicit Arguments.
Require Import Crypto.

Local Open Scope rat_scope.

Section IND_CPA.

  Variable Plaintext : Set.
  Variable Ciphertext : Set.
  Variable PrivateKey : Set.
  Variable PublicKey : Set.

  Variable KeyGen : Comp (PrivateKey * PublicKey).
  Variable Encrypt : Plaintext -> PublicKey -> Comp Ciphertext.

  Variable A_state : Set.
  Variable A1 : PublicKey -> Comp (Plaintext * Plaintext * A_state).
  Variable A2 : (Ciphertext * A_state) -> Comp bool.

  Definition IND_CPA_G :=
    [prikey, pubkey] <-$2 KeyGen;
    [p0, p1, a_state] <-$3 (A1 pubkey);
    b <-$ {0, 1};
    pb <- if b then p0 else p1;
                         c <-$ (Encrypt pb pubkey);
                         b' <-$ (A2 (c, a_state));
                         ret (eqb b b').

  Definition IND_CPA_Advantage := | Pr[IND_CPA_G] - 1 / 2 |.

  Definition IND_CPA (epsilon : Rat) :=
    | Pr[IND_CPA_G] - 1 / 2 | <= epsilon.

End IND_CPA.


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

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

Print Assumptions add.


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

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

Print Assumptions carry.


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

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

Print Assumptions carry.


Require Import Arith.
Require Import EqNat.
Require Import Ring.

(* -------------------------------------------------------------------- *)
From mathcomp Require Import div ssreflect eqtype ssrbool ssrnat seq fintype.
From mathcomp Require Import finset zmodp matrix bigop ssralg matrix ssrnum.
From mathcomp Require Import finmap seq ssrfun finfun matrix ssrnum ssrfun.
From mathcomp Require Import bigop ssralg finset fingroup zmodp poly fingraph.
From mathcomp Require Import tuple choice path.
(* -------------------------------------------------------------------- *)

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

Section Delaunay.

Local Notation "p '.1'" :=  (p (inZp 1)).
Local Notation "p '.0'" := (p (inZp 0))
  (at level 2, left associativity, format "p .0").
Local Notation "p '.2'" := (p (inZp 2))
  (at level 2, left associativity, format "p .2").

Variable R : numDomainType.
Variable P : finType.

Variable coords : P -> 'rV[R]_2.

Hypothesis coords_inj : injective coords.

Definition T := (P ^ 3)%type.

Definition oriented (t : T) : bool :=
  (0 < \det (col_mx (coords (t.1) - coords (t.0))
                    (coords (t.2) - (coords t.0))))%R.

Definition in_circle_row (v : 'rV[R]_2) : 'rV[R]_4 :=
    \row_(i < 4)
     if val i == 0 then (v.0.0 * v.0.0  + v.0.1 * v.0.1)%R
     else if val i == 1 then v.0.0
     else if val i == 2 then v.0.1
     else 1%R.

Definition incircle t (p : P) : bool :=
  (\det (col_mx (\matrix_(i < 3) in_circle_row (coords (t i)))
         (in_circle_row (coords p))) < 0)%R.

Definition triangulation := {set T}.

Variable triangulation_order : triangulation -> triangulation -> bool.

Hypothesis wf_triangulation_order : well_founded triangulation_order.

Definition inter_triangle (t1 t2 : T) : {set P} :=
  [set x | x \in codom t1] :&: [set x | x \in codom t2].

Definition third_point (t1 t2 : T) : P :=
 odflt (t2.0) (pick [pred x | x \in
                  [set t2 x | x : 'I_3] :\: inter_triangle t1 t2]).

Definition illegal_edge (t1 t2 : T) : bool :=
  (t1 != t2) &&
  (#|inter_triangle t1 t2| == 2) && incircle t1 (third_point t1 t2).

Definition build_triangle0 (p1 p2 p3 : P) : T :=
  [ffun x => if val x == 0 then p1 else if val x == 1 then p2 else p3].

Local Notation "[ 'triangle' a ; b ; c ]" := (build_triangle0 a b c)
  (format "[ triangle  a ;  b ;  c ]").

Definition build_triangle (p : P) (edge : {set P}) :=
  odflt [ffun _ => p]
    (pick [pred f : {ffun 'I_3 -> P} |
                  ([set x | x \in codom f] == [set p] :|: edge) &&
           oriented f]).

Definition flip_edge (t1 t2 : T) (m : triangulation) : triangulation :=
  let p1 := third_point t2 t1 in
  let p2 := third_point t1 t2 in
  [set build_triangle p1 (inter_triangle t1 t2);
       build_triangle p2 (inter_triangle t1 t2)] :|: (m :\: [set t1; t2]).

Definition find_triangle (m : triangulation) (p : P) : option T :=
  pick [pred t | (t \in m) &&
          oriented ([triangle t.0; t.1; p]) &&
          oriented [triangle t.1; t.2; p] &&
          oriented [triangle t.2; t.0; p]].

Definition Zp_succ (n : nat) (i : 'I_n.+1) := Zp_add i (inZp 1).

Definition border_triangles (m : triangulation) (p : P) : {set T} :=
  [set t | t : T &
     [exists i : 'I_3,  oriented [triangle t (Zp_succ i); t i; p] &&
                 [forall t' : T, ((t' \in m) && (t != t')) ==>
                                  (inter_triangle t t' !=
                                     [set t i ; t (Zp_succ i)])]]].

Definition triangles_out (m : triangulation) (p : P) : {set T} :=
  \bigcup_(t | t \in border_triangles m p)
     [set x | (x \in [set [triangle t (Zp_succ i); t i; p] | i : 'I_3])
   && oriented x].

Definition add_point (m : triangulation) (p : P) : triangulation :=
  match find_triangle m p with
  | Some t => [set [triangle t i ; t (Zp_succ i); p] | i : 'I_3] :|:
              (m :\: [set t])
  | None => triangles_out m p :|: m
  end.

Hypothesis flip_decrease : forall (m : triangulation) t1 t2,
  t1 \in m -> t2 \in m -> illegal_edge t1 t2 ->
  triangulation_order (flip_edge t1 t2 m) m.

Definition rflip_body (m : triangulation)
    (f : forall m', triangulation_order m' m -> triangulation) : triangulation.
case: (set_0Vmem [set x : T * T | (fst x \in m) && (snd x \in m) &&
                   illegal_edge (fst x) (snd x)]).
  move => _; exact m.
move => [[t1 t2]]; rewrite in_set => /andP [] /andP [] intp1 intp2 ill.
apply: (f (flip_edge t1 t2 m) (flip_decrease intp1 intp2 ill)).
Defined.

Definition all_flips (m : triangulation) : triangulation :=
  Fix wf_triangulation_order _ rflip_body m.

Fixpoint delaunay (s : seq P) : triangulation :=
   match s with
   | nil => set0
   | _ :: nil => set0
   | _ :: _ :: nil => set0
   | p1 :: p2 :: p3 :: nil => [set build_triangle p1 [set p2 ; p3]]
   | p :: tl => all_flips (add_point (delaunay tl) p)
   end.


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

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

Print Assumptions add.


(* As you can see that Dominique is Coq wizard :) *)

Require Import Arith Utf8.  (* for lt_irrefl *)

Section eq_nat_pirr.

  Definition eq_0_inv {a} (e : 0 = a) :
    match a return _ = a → Prop with
      | 0   => λ f, eq_refl = f
      | S _ => λ _, False
    end e :=
    match e with
      | eq_refl => eq_refl
    end.

  Definition eq_S_inv {a b} (e : S a = b) :
    match b return _ = b → Prop with
      | 0   => λ _, False
      | S b => λ e, ∃f, eq_S a b f = e
    end e :=
    match e with
      | eq_refl => ex_intro _ eq_refl eq_refl
    end.

  (** Instances give what we want but just FYI *)

  Definition eq_0_pirr (e : 0 = 0) : eq_refl = e := eq_0_inv e.

  Definition eq_S_pirr {a b} (e : S a = S b) :
  ∃f : a = b, eq_S a b f = e := eq_S_inv e.

  Fixpoint eq_nat_pirr {a : nat} : ∀e : a = a, eq_refl = e :=
    match a with
      | 0   => eq_0_inv
      | S a => λ e, let (f,Hf) := eq_S_inv e
                    in match Hf with
                      | eq_refl =>
                      match eq_nat_pirr f with
                        | eq_refl => eq_refl
                      end
                    end
    end.

End eq_nat_pirr.

Local Definition lt_irrefl' {a b} : S a = b → b ≤ a → False :=
  λ e, match e with eq_refl => lt_irrefl _ end.

Section le_pirr.

  Arguments le_n {_}.
  Arguments le_S {_ _}.

  Definition le_eq_inv {a b} (l : a ≤ b) : ∀e : b = a, le_n = eq_rect _ (le a) l _ e :=
    match l with
      | le_n   => λ e, match eq_nat_pirr e  with eq_refl => eq_refl end
      | le_S l => λ e, match lt_irrefl' e l with end
    end.

  Definition le_eq_pirr {a} (l : a ≤ a) : le_n = l := le_eq_inv l eq_refl.

  Definition le_S_inv {a b} (l : a ≤ b) :
     match b return _ ≤ b -> Prop with
       | 0   => λ _, True
       | S b => λ l, S b = a ∨ ∃l', le_S l' = l
     end l :=
     match l with
       | le_n =>
       match a with
         | 0   => I
         | S _ => or_introl eq_refl
       end
       | le_S l' => or_intror (ex_intro _ l' eq_refl)
     end.

  Definition le_S_pirr {a b} (lS : a ≤ S b) : a ≤ b → ∃l, le_S l = lS :=
    match le_S_inv lS with
      | or_introl e => λ l, match lt_irrefl' e l with end
      | or_intror E => λ _, E
    end.

  Section le_pirr.

    Variable (a : nat).

    Fixpoint le_pirr {b} (l₁ : a ≤ b) { struct l₁ } : ∀l₂, l₁ = l₂ :=
      match l₁ with
        | le_n    => λ l₂, le_eq_pirr l₂
        | le_S l₁ => λ l₂, let (l,Hl) := le_S_pirr l₂ l₁
                           in match Hl with
                             | eq_refl =>
                             match le_pirr l₁ l with
                               | eq_refl => eq_refl
                             end
                           end
      end.

  End le_pirr.

  Section le_le_indd.

    Variables (a : nat)
              (P : ∀ {b}, a ≤ b → a ≤ b → Prop)
              (P_n : @P a le_n le_n)
              (P_S : ∀ {b} {l₁ l₂ : a ≤ b}, P l₁ l₂ → P (le_S l₁) (le_S l₂)).

    Fixpoint le_le_indd {b} (l₁ : a ≤ b) { struct l₁ } : ∀l₂, P l₁ l₂ :=
      match l₁ with
        | le_n => λ l₂,
        match le_eq_pirr l₂ with
          | eq_refl => P_n
        end
        | le_S l₁ => λ l₂,
        let (l,Hl) := le_S_pirr l₂ l₁
        in match Hl with
          | eq_refl => P_S (le_le_indd l₁ l)
        end
      end.

  End le_le_indd.

  Theorem le_pirr' a : forall b (l₁ l₂ : a ≤ b), l₁ = l₂.
  Proof. now apply le_le_indd; intros; subst. Qed.

End le_pirr.