Require Import Equality.

Parameter Patch : nat -> nat -> Set.

Inductive Catch (from to : nat) : Type
    := MkCatch : forall (p : Patch from to),
                 Catch from to.
Arguments MkCatch [from to].

Inductive CatchCommute5
        : forall {from mid1 mid2 to : nat},
          Catch from mid1
       -> Catch mid1 to
       -> Catch from mid2
       -> Catch mid2 to
       -> Prop
     := MkCatchCommute5 :
           forall {from mid1 mid2 to : nat}
                  (p : Patch from mid1)
                  (q : Patch mid1 to)
                  (q' : Patch from mid2)
                  (p' : Patch mid2 to),
           CatchCommute5 (MkCatch p) (MkCatch q) (MkCatch q') (MkCatch p').

Inductive CatchCommute {from mid1 mid2 to : nat}
                       (p : Catch from mid1)
                       (q : Catch mid1 to)
                       (q' : Catch from mid2)
                       (p' : Catch mid2 to)
                     : Prop
    := isCatchCommute5 : forall (catchCommuteDetails : CatchCommute5 p q q' p'),
                         CatchCommute p q q' p'.
Notation "<< p , q >> <~> << q' , p' >>"
    := (CatchCommute p q q' p')
    (at level 60, no associativity).

Lemma CatchCommuteUnique2 :
      forall {from mid mid' to : nat}
             {p   : Catch from mid}  {q   : Catch mid  to}
             {q'  : Catch from mid'} {p'  : Catch mid' to}
             {q'' : Catch from mid'} {p'' : Catch mid' to}
             (commute1 : <<p, q>> <~> <<q', p'>>)
             (commute2 : <<p, q>> <~> <<q'', p''>>),
      (p' = p'') /\ (q' = q'').
Proof with auto.
intros.
set (X := commute2).
Fail dependent destruction commute1;
dependent destruction catchCommuteDetails;
dependent destruction commute2;
dependent destruction catchCommuteDetails generalizing X.
revert X.
dependent destruction commute1;
dependent destruction catchCommuteDetails;
dependent destruction commute2;
dependent destruction catchCommuteDetails.
Abort.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__congruenceflip.
Require Export lemma__equalanglesNC.
Require Export lemma__equalanglessymmetric.
Require Export lemma__equalanglestransitive.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__oppositesidesymmetric.
Require Export lemma__rayimpliescollinear.
Require Export lemma__supplements.
Require Export logic.
Require Export proposition__04.
Require Export proposition__07.
Definition proposition__14 : forall A B C D E, (euclidean__defs.RT A B C D B E) -> ((euclidean__defs.Out B C D) -> ((euclidean__axioms.TS E D B A) -> ((euclidean__defs.Supp A B C D E) /\ (euclidean__axioms.BetS A B E)))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro H.
intro H0.
intro H1.
assert (* Cut *) (exists a b c d e, (euclidean__defs.Supp a b c d e) /\ ((euclidean__defs.CongA A B C a b c) /\ (euclidean__defs.CongA D B E d b e))) as H2.
- assert (exists X Y Z U V, (euclidean__defs.Supp X Y U V Z) /\ ((euclidean__defs.CongA A B C X Y U) /\ (euclidean__defs.CongA D B E V Y Z))) as H2 by exact H.
assert (exists X Y Z U V, (euclidean__defs.Supp X Y U V Z) /\ ((euclidean__defs.CongA A B C X Y U) /\ (euclidean__defs.CongA D B E V Y Z))) as __TmpHyp by exact H2.
destruct __TmpHyp as [x H3].
destruct H3 as [x0 H4].
destruct H4 as [x1 H5].
destruct H5 as [x2 H6].
destruct H6 as [x3 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
exists x.
exists x0.
exists x2.
exists x3.
exists x1.
split.
-- exact H8.
-- split.
--- exact H10.
--- exact H11.
- destruct H2 as [a H3].
destruct H3 as [b H4].
destruct H4 as [c H5].
destruct H5 as [d H6].
destruct H6 as [e H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
assert (* Cut *) (euclidean__defs.CongA a b c A B C) as H12.
-- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A B C a b c H10).
-- assert (* Cut *) (euclidean__defs.CongA d b e D B E) as H13.
--- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric D B E d b e H11).
--- assert (* Cut *) (euclidean__axioms.nCol A B C) as H14.
---- apply (@euclidean__tactics.nCol__notCol A B C).
-----apply (@euclidean__tactics.nCol__not__Col A B C).
------apply (@lemma__equalanglesNC.lemma__equalanglesNC a b c A B C H12).

---- assert (* Cut *) (euclidean__axioms.neq A B) as H15.
----- 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 H15.
------ apply (@lemma__NCdistinct.lemma__NCdistinct A B C H14).
------ 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 H16.
----- assert (* Cut *) (euclidean__axioms.nCol D B E) as H16.
------ apply (@euclidean__tactics.nCol__notCol D B E).
-------apply (@euclidean__tactics.nCol__not__Col D B E).
--------apply (@lemma__equalanglesNC.lemma__equalanglesNC d b e D B E H13).

------ assert (* Cut *) (euclidean__axioms.neq B E) as H17.
------- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B E) /\ ((euclidean__axioms.neq D E) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq E B) /\ (euclidean__axioms.neq E D)))))) as H17.
-------- apply (@lemma__NCdistinct.lemma__NCdistinct D B E H16).
-------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H20.
------- assert (* Cut *) (exists T, (euclidean__axioms.BetS A B T) /\ (euclidean__axioms.Cong B T B E)) as H18.
-------- apply (@lemma__extension.lemma__extension A B B E H15 H17).
-------- destruct H18 as [T H19].
destruct H19 as [H20 H21].
assert (* Cut *) (euclidean__axioms.Cong B D B D) as H22.
--------- apply (@euclidean__axioms.cn__congruencereflexive B D).
--------- assert (* Cut *) (euclidean__defs.Supp A B C D T) as H23.
---------- split.
----------- exact H0.
----------- exact H20.
---------- assert (euclidean__defs.CongA a b c A B C) as H24 by exact H12.
assert (euclidean__defs.CongA d b e D B E) as H25 by exact H13.
assert (* Cut *) (euclidean__defs.CongA d b e D B T) as H26.
----------- apply (@lemma__supplements.lemma__supplements a b c d e A B C D T H24 H8 H23).
----------- assert (* Cut *) (euclidean__defs.CongA D B E D B T) as H27.
------------ apply (@lemma__equalanglestransitive.lemma__equalanglestransitive D B E d b e D B T H11 H26).
------------ assert (* Cut *) (euclidean__defs.CongA D B T D B E) as H28.
------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric D B E D B T H27).
------------- assert (* Cut *) (euclidean__axioms.Col A B T) as H29.
-------------- right.
right.
right.
right.
left.
exact H20.
-------------- assert (* Cut *) (euclidean__axioms.neq B T) as H30.
--------------- assert (* Cut *) ((euclidean__axioms.neq B T) /\ ((euclidean__axioms.neq A B) /\ (euclidean__axioms.neq A T))) as H30.
---------------- apply (@lemma__betweennotequal.lemma__betweennotequal A B T H20).
---------------- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
exact H31.
--------------- assert (* Cut *) (euclidean__axioms.neq T B) as H31.
---------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B T H30).
---------------- assert (* Cut *) (B = B) as H32.
----------------- apply (@logic.eq__refl Point B).
----------------- assert (* Cut *) (euclidean__axioms.Col A B B) as H33.
------------------ right.
right.
left.
exact H32.
------------------ assert (* Cut *) (euclidean__axioms.nCol T B C) as H34.
------------------- apply (@euclidean__tactics.nCol__notCol T B C).
--------------------apply (@euclidean__tactics.nCol__not__Col T B C).
---------------------apply (@lemma__NChelper.lemma__NChelper A B C T B H14 H29 H33 H31).

------------------- assert (* Cut *) (euclidean__axioms.nCol C B T) as H35.
-------------------- assert (* Cut *) ((euclidean__axioms.nCol B T C) /\ ((euclidean__axioms.nCol B C T) /\ ((euclidean__axioms.nCol C T B) /\ ((euclidean__axioms.nCol T C B) /\ (euclidean__axioms.nCol C B T))))) as H35.
--------------------- apply (@lemma__NCorder.lemma__NCorder T B C H34).
--------------------- destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
exact H43.
-------------------- assert (* Cut *) (euclidean__axioms.Col B C D) as H36.
--------------------- apply (@lemma__rayimpliescollinear.lemma__rayimpliescollinear B C D H0).
--------------------- assert (* Cut *) (euclidean__axioms.Col C B D) as H37.
---------------------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H37.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder B C D H36).
----------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H38.
---------------------- assert (* Cut *) (euclidean__axioms.neq D B) as H38.
----------------------- assert (* Cut *) ((euclidean__axioms.neq D B) /\ ((euclidean__axioms.neq B E) /\ ((euclidean__axioms.neq D E) /\ ((euclidean__axioms.neq B D) /\ ((euclidean__axioms.neq E B) /\ (euclidean__axioms.neq E D)))))) as H38.
------------------------ apply (@lemma__NCdistinct.lemma__NCdistinct D B E H16).
------------------------ destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
exact H39.
----------------------- assert (* Cut *) (euclidean__axioms.Col C B B) as H39.
------------------------ right.
right.
left.
exact H32.
------------------------ assert (* Cut *) (euclidean__axioms.nCol D B T) as H40.
------------------------- apply (@euclidean__tactics.nCol__notCol D B T).
--------------------------apply (@euclidean__tactics.nCol__not__Col D B T).
---------------------------apply (@lemma__NChelper.lemma__NChelper C B T D B H35 H37 H39 H38).

------------------------- assert (* Cut *) (euclidean__axioms.Cong D T D E) as H41.
-------------------------- assert (* Cut *) (forall A0 B0 C0 a0 b0 c0, (euclidean__axioms.Cong A0 B0 a0 b0) -> ((euclidean__axioms.Cong A0 C0 a0 c0) -> ((euclidean__defs.CongA B0 A0 C0 b0 a0 c0) -> (euclidean__axioms.Cong B0 C0 b0 c0)))) as H41.
--------------------------- intro A0.
intro B0.
intro C0.
intro a0.
intro b0.
intro c0.
intro __.
intro __0.
intro __1.
assert (* AndElim *) ((euclidean__axioms.Cong B0 C0 b0 c0) /\ ((euclidean__defs.CongA A0 B0 C0 a0 b0 c0) /\ (euclidean__defs.CongA A0 C0 B0 a0 c0 b0))) as __2.
---------------------------- apply (@proposition__04.proposition__04 A0 B0 C0 a0 b0 c0 __ __0 __1).
---------------------------- destruct __2 as [__2 __3].
exact __2.
--------------------------- apply (@H41 B D T B D E H22 H21 H28).
-------------------------- assert (* Cut *) (euclidean__axioms.Cong T D E D) as H42.
--------------------------- assert (* Cut *) ((euclidean__axioms.Cong T D E D) /\ ((euclidean__axioms.Cong T D D E) /\ (euclidean__axioms.Cong D T E D))) as H42.
---------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip D T D E H41).
---------------------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
exact H43.
--------------------------- assert (* Cut *) (euclidean__axioms.Cong T B E B) as H43.
---------------------------- assert (* Cut *) ((euclidean__axioms.Cong T B E B) /\ ((euclidean__axioms.Cong T B B E) /\ (euclidean__axioms.Cong B T E B))) as H43.
----------------------------- apply (@lemma__congruenceflip.lemma__congruenceflip B T B E H21).
----------------------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H44.
---------------------------- assert (* Cut *) (euclidean__axioms.Col D B B) as H44.
----------------------------- right.
right.
left.
exact H32.
----------------------------- assert (* Cut *) (euclidean__axioms.TS A D B E) as H45.
------------------------------ apply (@lemma__oppositesidesymmetric.lemma__oppositesidesymmetric D B E A H1).
------------------------------ assert (exists m, (euclidean__axioms.BetS A m E) /\ ((euclidean__axioms.Col D B m) /\ (euclidean__axioms.nCol D B A))) as H46 by exact H45.
destruct H46 as [m H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
assert (* Cut *) (euclidean__axioms.BetS E m A) as H52.
------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A m E H48).
------------------------------- assert (* Cut *) (euclidean__axioms.BetS T B A) as H53.
-------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A B T H20).
-------------------------------- assert (* Cut *) (euclidean__defs.OS T E D B) as H54.
--------------------------------- exists A.
exists B.
exists m.
split.
---------------------------------- exact H44.
---------------------------------- split.
----------------------------------- exact H50.
----------------------------------- split.
------------------------------------ exact H53.
------------------------------------ split.
------------------------------------- exact H52.
------------------------------------- split.
-------------------------------------- exact H40.
-------------------------------------- exact H16.
--------------------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H55.
---------------------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq B T) /\ ((euclidean__axioms.neq C T) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq T B) /\ (euclidean__axioms.neq T C)))))) as H55.
----------------------------------- apply (@lemma__NCdistinct.lemma__NCdistinct C B T H35).
----------------------------------- destruct H55 as [H56 H57].
destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
exact H62.
---------------------------------- assert (* Cut *) (euclidean__axioms.neq C B) as H56.
----------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H55).
----------------------------------- assert (* Cut *) (T = E) as H57.
------------------------------------ apply (@proposition__07.proposition__07 D B T E H38 H42 H43 H54).
------------------------------------ assert (* Cut *) (euclidean__axioms.BetS A B E) as H58.
------------------------------------- apply (@eq__ind__r euclidean__axioms.Point E (fun T0 => (euclidean__axioms.BetS A B T0) -> ((euclidean__axioms.Cong B T0 B E) -> ((euclidean__defs.Supp A B C D T0) -> ((euclidean__defs.CongA d b e D B T0) -> ((euclidean__defs.CongA D B E D B T0) -> ((euclidean__defs.CongA D B T0 D B E) -> ((euclidean__axioms.Col A B T0) -> ((euclidean__axioms.neq B T0) -> ((euclidean__axioms.neq T0 B) -> ((euclidean__axioms.nCol T0 B C) -> ((euclidean__axioms.nCol C B T0) -> ((euclidean__axioms.nCol D B T0) -> ((euclidean__axioms.Cong D T0 D E) -> ((euclidean__axioms.Cong T0 D E D) -> ((euclidean__axioms.Cong T0 B E B) -> ((euclidean__axioms.BetS T0 B A) -> ((euclidean__defs.OS T0 E D B) -> (euclidean__axioms.BetS A B E))))))))))))))))))) with (x := T).
--------------------------------------intro H58.
intro H59.
intro H60.
intro H61.
intro H62.
intro H63.
intro H64.
intro H65.
intro H66.
intro H67.
intro H68.
intro H69.
intro H70.
intro H71.
intro H72.
intro H73.
intro H74.
exact H58.

-------------------------------------- exact H57.
-------------------------------------- exact H20.
-------------------------------------- exact H21.
-------------------------------------- exact H23.
-------------------------------------- exact H26.
-------------------------------------- exact H27.
-------------------------------------- exact H28.
-------------------------------------- exact H29.
-------------------------------------- exact H30.
-------------------------------------- exact H31.
-------------------------------------- exact H34.
-------------------------------------- exact H35.
-------------------------------------- exact H40.
-------------------------------------- exact H41.
-------------------------------------- exact H42.
-------------------------------------- exact H43.
-------------------------------------- exact H53.
-------------------------------------- exact H54.
------------------------------------- assert (* Cut *) (euclidean__defs.Supp A B C D E) as H59.
-------------------------------------- split.
--------------------------------------- exact H0.
--------------------------------------- exact H58.
-------------------------------------- split.
--------------------------------------- exact H59.
--------------------------------------- exact H58.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.GeneralLogic.Complete.Lindenbaum.
Require Import Logic.GeneralLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.GeneralLogic.Complete.Canonical_Kripke.
Require Import Logic.GeneralLogic.Complete.Complete_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.MinimumLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Complete.Lindenbaum_Kripke.
Require Import Logic.PropositionalLogic.Complete.Truth_Kripke.
Require Import Logic.PropositionalLogic.Complete.Canonical_Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.SeparationLogic.Complete.ContextProperty_Flat.
Require Import Logic.SeparationLogic.Complete.Lindenbaum_Flat.
Require Import Logic.SeparationLogic.Complete.Truth_Flat.
Require Import Logic.SeparationLogic.Complete.Canonical_Flat.
Require Import Logic.SeparationLogic.DeepEmbedded.Parameter.
Require Logic.SeparationLogic.DeepEmbedded.SeparationEmpLanguage.
Require Logic.SeparationLogic.DeepEmbedded.FlatSemantics.
Require Logic.SeparationLogic.DeepEmbedded.ParametricSeparationLogic.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Local Open Scope kripke_model_class.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.
Import KripkeModelClass.

Section Complete.

Context {Sigma: SeparationEmpLanguage.PropositionalVariables}
        {CV: Countable SeparationEmpLanguage.Var}
        (SLP: SL_Parameter).

Existing Instances SeparationEmpLanguage.L SeparationEmpLanguage.minL SeparationEmpLanguage.pL SeparationEmpLanguage.sepconL SeparationEmpLanguage.wandL SeparationEmpLanguage.empL.

Existing Instances ParametricSeparationLogic.GP ParametricSeparationLogic.GD ParametricSeparationLogic.AX ParametricSeparationLogic.minAX  ParametricSeparationLogic.ipAX ParametricSeparationLogic.sepconAX ParametricSeparationLogic.wandAX ParametricSeparationLogic.empAX ParametricSeparationLogic.sepcon_orp_AX ParametricSeparationLogic.sepcon_falsep_AX ParametricSeparationLogic.ParAX.

Existing Instances Axiomatization2SequentCalculus_SC Axiomatization2SequentCalculus_bSC Axiomatization2SequentCalculus_fwSC Axiomatization2SequentCalculus_minSC Axiomatization2SequentCalculus_ipSC Axiomatization2SequentCalculus_cpSC.

Existing Instances FlatSemantics.MD FlatSemantics.kMD FlatSemantics.R FlatSemantics.J FlatSemantics.SM FlatSemantics.kminSM FlatSemantics.kpSM FlatSemantics.fsepconSM FlatSemantics.fwandSM FlatSemantics.fempSM.

Definition cP : context -> Prop := Intersection _ (Intersection _ derivable_closed orp_witnessed) consistent.

Lemma AL_DC: at_least derivable_closed cP.
Proof. solve_at_least. Qed.

Lemma AL_OW: at_least orp_witnessed cP.
Proof. solve_at_least. Qed.

Lemma AL_CONSI: at_least consistent cP.
Proof. solve_at_least. Qed.

Lemma LIN_CD: forall x: expr, Lindenbaum_constructable (cannot_derive x) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply SeparationEmpLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_cannot_derive.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_cannot_derive_ensures_derivable_closed.
    - apply Lindenbaum_cannot_derive_ensures_orp_witnessed.
    - apply Lindenbaum_cannot_derive_ensures_consistent.
Qed.

Lemma LIN_SL: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_l Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  apply Lindenbaum_constructable_suffice; auto.
  + apply SeparationEmpLanguage.formula_countable; auto.
  + apply Lindenbaum_preserves_context_sepcon_included_l.
  + unfold cP.
    repeat apply Lindenbaum_ensures_by_conjunct.
    - apply Lindenbaum_context_sepcon_included_l_ensures_derivable_closed.
    - apply Lindenbaum_context_sepcon_included_l_ensures_orp_witnessed.
      * apply AL_DC, (proj2_sig Psi).
      * apply AL_OW, (proj2_sig Psi).
    - apply Lindenbaum_context_sepcon_included_l_ensures_consistent.
      apply AL_CONSI, (proj2_sig Psi).
Qed.

Lemma LIN_SR: forall (Phi: context) (Psi: sig cP), Lindenbaum_constructable (context_sepcon_included_r Phi (proj1_sig Psi)) cP.
Proof.
  intros.
  eapply Lindenbaum_constructable_Same_set.
  + symmetry.
    apply context_sepcon_included_equiv.
    apply AL_DC, (proj2_sig Psi).
  + apply LIN_SL.
Qed.

Definition canonical_frame: FlatSemantics.frame :=
  FlatSemantics.Build_frame (sig cP)
    (fun a b => Included _ (proj1_sig a) (proj1_sig b))
    (fun a b c => Included _ (context_sepcon (proj1_sig a) (proj1_sig b)) (proj1_sig c)).

Definition canonical_eval: SeparationEmpLanguage.Var -> FlatSemantics.sem canonical_frame :=
  fun p a => proj1_sig a (SeparationEmpLanguage.varp p).

Definition canonical_Kmodel: @Kmodel FlatSemantics.MD FlatSemantics.kMD :=
  FlatSemantics.Build_Kmodel canonical_frame canonical_eval.

Definition rel: bijection (Kworlds canonical_Kmodel) (sig cP) := bijection_refl.

Definition H_R:
  forall m n Phi Psi, rel m Phi -> rel n Psi ->
    (m <= n <-> Included _ (proj1_sig Phi) (proj1_sig Psi)).
Proof.
  intros.
  change (m = Phi) in H.
  change (n = Psi) in H0.
  subst; reflexivity.
Qed.

Definition H_J:
  forall m1 m2 m Phi1 Phi2 Phi, rel m1 Phi1 -> rel m2 Phi2 -> rel m Phi ->
    (join m1 m2 m <-> Included _ (context_sepcon (proj1_sig Phi1) (proj1_sig Phi2)) (proj1_sig Phi)).
Proof.
  intros.
  change (m = Phi) in H1.
  change (m1 = Phi1) in H.
  change (m2 = Phi2) in H0.
  subst; reflexivity.
Qed.

Lemma TRUTH:
  forall x: expr, forall m Phi, rel m Phi ->
    (KRIPKE: canonical_Kmodel, m |= x <-> proj1_sig Phi x).
Proof.
  induction x.
  + exact (truth_lemma_andp cP rel AL_DC x1 x2 IHx1 IHx2).
  + exact (truth_lemma_orp cP rel AL_DC AL_OW x1 x2 IHx1 IHx2).
  + exact (truth_lemma_impp cP rel H_R AL_DC LIN_CD x1 x2 IHx1 IHx2).
  + exact (truth_lemma_sepcon cP rel H_J AL_DC LIN_SL LIN_SR x1 x2 IHx1 IHx2).
  + exact (truth_lemma_wand cP rel H_J AL_DC LIN_CD LIN_SR x1 x2 IHx1 IHx2).
  + exact (truth_lemma_emp cP rel H_R H_J AL_DC LIN_CD LIN_SR).
  + exact (truth_lemma_falsep cP rel AL_CONSI).
  + intros; change (m = Phi) in H; subst; reflexivity.
Qed.

Context (SAP: SA_Parameter).

Hypothesis PC: Parameter_coincide SLP SAP.

Theorem ParametricCompleteness:
  strongly_complete (ParametricSeparationLogic.GD SLP) FlatSemantics.SM
    (KripkeModelClass _
      (FlatSemantics.Kmodel_Monotonic +
       FlatSemantics.Kmodel_PreOrder +
       FlatSemantics.Kmodel_SeparationAlgebra +
       FlatSemantics.Kmodel_UpwardsClosed +
       FlatSemantics.Kmodel_DownwardsClosed +
       FlatSemantics.Kmodel_Unital +
       FlatSemantics.Parametric_Kmodel_Class SAP)).
Proof.
  apply (@general_completeness _ _ _ _ _ _ _ _ cP rel LIN_CD TRUTH).
  split; [split; [split; [split; [split; [split |] |] |] |] |].
  + hnf; intros.
    exact (denote_monotonic cP rel H_R
             (SeparationEmpLanguage.varp v)
             (TRUTH (SeparationEmpLanguage.varp v))).
  + exact (po_R cP rel H_R).
  + exact (SA cP rel H_J AL_DC LIN_SR).
  + exact (uSA cP rel H_R H_J AL_DC).
  + exact (dSA cP rel H_R H_J AL_DC).
  + exact (unitSA cP rel H_R H_J AL_DC LIN_SR TRUTH).
  + inversion PC.
    constructor; intros HH; rewrite HH in *.
    - pose proof ParametricSeparationLogic.Parametric_C H.
      exact (classical_canonical_ident cP rel H_R AL_DC AL_OW AL_CONSI).
    - pose proof ParametricSeparationLogic.Parametric_GD H0.
      exact (GodelDummett_canonical_no_branch cP rel H_R AL_DC AL_OW).
    - pose proof ParametricSeparationLogic.Parametric_DM H1.
      exact (DeMorgan_canonical_branch_join cP rel H_R AL_DC AL_OW AL_CONSI LIN_CD).
    - pose proof ParametricSeparationLogic.Parametric_GC H2.
      exact (garbage_collected_canonical_increaing cP rel H_R H_J AL_DC).
    - pose proof ParametricSeparationLogic.Parametric_NE H3.
      exact (nonsplit_canonical_split_smaller cP rel H_R H_J AL_DC TRUTH).
    - pose proof ParametricSeparationLogic.Parametric_ED H4.
      exact (dup_canonical_incr_join cP rel H_J AL_DC TRUTH).
Qed.

End Complete.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Nth.
Require option.Option.
Require list.HdTl.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Definition zero_at (l:(list Z)) (i:Z): Prop := ((list.Nth.nth i
  l) = (Some 0%Z)) /\ forall (j:Z), ((0%Z <= j)%Z /\ (j < i)%Z) ->
  ~ ((list.Nth.nth j l) = (Some 0%Z)).

(* Why3 assumption *)
Definition no_zero (l:(list Z)): Prop := forall (j:Z), ((0%Z <= j)%Z /\
  (j < (list.Length.length l))%Z) -> ~ ((list.Nth.nth j l) = (Some 0%Z)).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(@ref a a_WT)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 goal *)
Theorem WP_parameter_search_loop : forall (l:(list Z)), forall (s:(list Z))
  (i:Z), ((0%Z <= i)%Z /\
  (((i + (list.Length.length s))%Z = (list.Length.length l)) /\
  ((forall (j:Z), (0%Z <= j)%Z -> ((list.Nth.nth j
  s) = (list.Nth.nth (i + j)%Z l))) /\ forall (j:Z), ((0%Z <= j)%Z /\
  (j < i)%Z) -> ~ ((list.Nth.nth j l) = (Some 0%Z))))) -> ((~ (s = nil)) ->
  ((~ (s = nil)) -> forall (o:Z),
  match s with
  | nil => False
  | (cons h _) => (o = h)
  end -> ((~ (o = 0%Z)) -> forall (i1:Z), (i1 = (i + 1%Z)%Z) ->
  ((~ (s = nil)) -> forall (o1:(list Z)),
  match s with
  | nil => False
  | (cons _ t) => (o1 = t)
  end -> forall (s1:(list Z)), (s1 = o1) -> forall (j:Z), ((0%Z <= j)%Z /\
  (j < i1)%Z) -> ~ ((list.Nth.nth j l) = (Some 0%Z)))))).
(* Why3 intros l s i (h1,(h2,(h3,h4))) h5 h6 o h7 h8 i1 h9 h10 o1 h11 s1 h12
        j (h13,h14). *)
intuition.
destruct s.
destruct H9.
subst.
change (Length.length (cons z s)) with (1 + Length.length s)%Z in H.
assert (h: (j < i \/ j= i)%Z) by omega; destruct h.
apply (H5 j); auto with *.
subst j.
apply H6.
clear H0 H1 H8.
assert (H0: (0 <= 0)%Z) by omega.
generalize (H3 0%Z H0).
generalize (Nth.nth_def 0%Z (cons z s)).
intuition.
ring_simplify (i+0)%Z in H4.
clear H8.
rewrite H4 in H1.
rewrite H12 in H1.
injection H1; auto.
Qed.


Require Import Crypto.ModularArithmetic.PrimeFieldTheorems.
Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParams.
Require Import Crypto.ModularArithmetic.PseudoMersenneBaseParamProofs.
Require Import Crypto.ModularArithmetic.ExtendedBaseVector.
Require Import Crypto.ModularArithmetic.Conversion.
Require Import Crypto.ModularArithmetic.Pow2Base.
Require Import Crypto.ModularArithmetic.Pow2BaseProofs.
Require Import Crypto.BaseSystem.
Require Import Crypto.ModularArithmetic.ModularBaseSystemListZOperations.
Require Import Crypto.ModularArithmetic.ModularBaseSystemList.
Require Import Crypto.ModularArithmetic.ModularBaseSystemListProofs.
Require Import Crypto.ModularArithmetic.ModularBaseSystem.
Require Import Crypto.ModularArithmetic.ModularBaseSystemProofs.
Require Import Coq.Lists.List.
Require Import Crypto.Util.Tuple.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.AdditionChainExponentiation.
Require Import Crypto.Util.ListUtil Crypto.Util.ZUtil Crypto.Util.NatUtil Crypto.Util.CaseUtil.
Import ListNotations.
Require Import Coq.ZArith.ZArith Coq.ZArith.Zpower Coq.ZArith.ZArith Coq.ZArith.Znumtheory.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.QArith.QArith Coq.QArith.Qround.
Require Import Crypto.Tactics.VerdiTactics.
Require Export Crypto.Util.FixCoqMistakes.
Local Open Scope Z.

(* Computed versions of some functions. *)

Definition plus_opt := Eval compute in plus.

Definition Z_add_opt := Eval compute in Z.add.
Definition Z_sub_opt := Eval compute in Z.sub.
Definition Z_mul_opt := Eval compute in Z.mul.
Definition Z_div_opt := Eval compute in Z.div.
Definition Z_pow_opt := Eval compute in Z.pow.
Definition Z_opp_opt := Eval compute in Z.opp.
Definition Z_min_opt := Eval compute in Z.min.
Definition Z_ones_opt := Eval compute in Z.ones.
Definition Z_of_nat_opt := Eval compute in Z.of_nat.
Definition Z_le_dec_opt := Eval compute in Z_le_dec.
Definition Z_lt_dec_opt := Eval compute in Z_lt_dec.
Definition Z_shiftl_opt := Eval compute in Z.shiftl.
Definition Z_shiftl_by_opt := Eval compute in Z.shiftl_by.

Definition nth_default_opt {A} := Eval compute in @nth_default A.
Definition set_nth_opt {A} := Eval compute in @set_nth A.
Definition update_nth_opt {A} := Eval compute in @update_nth A.
Definition map_opt {A B} := Eval compute in @List.map A B.
Definition full_carry_chain_opt := Eval compute in @Pow2Base.full_carry_chain.
Definition length_opt := Eval compute in length.
Definition base_from_limb_widths_opt := Eval compute in @Pow2Base.base_from_limb_widths.
Definition minus_opt := Eval compute in minus.
Definition from_list_default_opt {A} := Eval compute in (@from_list_default A).
Definition sum_firstn_opt {A} := Eval compute in (@sum_firstn A).
Definition zeros_opt := Eval compute in (@zeros).
Definition bit_index_opt := Eval compute in bit_index.
Definition digit_index_opt := Eval compute in digit_index.

(* Some automation that comes in handy when constructing base parameters *)
Ltac opt_step :=
  match goal with
  | [ |- _ = match ?e with nil => _ | _ => _ end :> ?T ]
    => refine (_ : match e with nil => _ | _ => _ end = _);
       destruct e
  end.

Definition limb_widths_from_len_step loop len k :=
  (fun i prev =>
    match i with
    | O => nil
    | S i' => let x := (if (Z.eqb ((k * Z.of_nat (len - i + 1)) mod (Z.of_nat len)) 0)
                        then (k * Z.of_nat (len - i + 1)) / Z.of_nat len
                        else (k * Z.of_nat (len - i + 1)) / Z.of_nat len + 1)in
      x - prev:: (loop i' x)
    end).
Definition limb_widths_from_len len k :=
  (fix loop i prev := limb_widths_from_len_step loop len k i prev) len 0.

Definition brute_force_indices0 lw : bool
  := List.fold_right
       andb true
       (List.map
          (fun i
           => List.fold_right
                andb true
                (List.map
                   (fun j
                    => sum_firstn lw (i + j) <=? sum_firstn lw i + sum_firstn lw j)
                   (seq 0 (length lw - i))))
          (seq 0 (length lw))).

Lemma brute_force_indices_correct0 lw
  : brute_force_indices0 lw = true -> forall i j : nat,
      (i + j < length lw)%nat -> sum_firstn lw (i + j) <= sum_firstn lw i + sum_firstn lw j.
Proof.
  unfold brute_force_indices0.
  progress repeat setoid_rewrite fold_right_andb_true_map_iff.
  setoid_rewrite in_seq.
  setoid_rewrite Z.leb_le.
  eauto with omega.
Qed.

Definition brute_force_indices1 lw : bool
  := List.fold_right
       andb true
       (List.map
          (fun i
           => List.fold_right
                andb true
                (List.map
                   (fun j
                    => let w_sum := sum_firstn lw in
                       sum_firstn lw (length lw) + w_sum (i + j - length lw)%nat <=? w_sum i + w_sum j)
                   (seq (length lw - i) (length lw - (length lw - i)))))
          (seq 1 (length lw - 1))).

Lemma brute_force_indices_correct1 lw
  : brute_force_indices1 lw = true -> forall i j : nat,
  (i < length lw)%nat ->
  (j < length lw)%nat ->
  (i + j >= length lw)%nat ->
  let w_sum := sum_firstn lw in
  sum_firstn lw (length lw) + w_sum (i + j - length lw)%nat <= w_sum i + w_sum j.
Proof.
  unfold brute_force_indices1.
  progress repeat setoid_rewrite fold_right_andb_true_map_iff.
  setoid_rewrite in_seq.
  setoid_rewrite Z.leb_le.
  eauto with omega.
Qed.

Ltac construct_params prime_modulus len k :=
  let lwv := (eval cbv in (limb_widths_from_len len k)) in
  let lw := fresh "lw" in pose lwv as lw;
  eapply Build_PseudoMersenneBaseParams with (limb_widths := lw);
  [ abstract (apply fold_right_and_True_forall_In_iff; simpl; repeat (split; [omega |]); auto)
  | abstract (cbv; congruence)
  | abstract (refine (@brute_force_indices_correct0 lw _); vm_cast_no_check (eq_refl true))
  | abstract apply prime_modulus
  | abstract (cbv; congruence)
  | abstract (refine (@brute_force_indices_correct1 lw _); vm_cast_no_check (eq_refl true))].

Definition construct_mul2modulus {m} (prm : PseudoMersenneBaseParams m) : digits :=
  match limb_widths with
  | nil => nil
  | x :: tail =>
      2 ^ (x + 1) - (2 * c) :: List.map (fun w => 2 ^ (w + 1) - 2) tail
  end.

Ltac compute_preconditions :=
  cbv; intros; repeat match goal with H : _ \/ _ |- _  =>
    destruct H; subst; [ congruence | ] end; (congruence || omega).

Ltac subst_precondition := match goal with
  | [H : ?P, H' : ?P -> _ |- _] => specialize (H' H); clear H
end.

Ltac kill_precondition H :=
  forward H; [abstract (try exact eq_refl; clear; cbv; intros; repeat break_or_hyp; intuition)|];
  subst_precondition.

Section Carries.
  Context `{prm : PseudoMersenneBaseParams}
    (* allows caller to precompute k and c *)
    (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_).
  Local Notation base := (Pow2Base.base_from_limb_widths limb_widths).
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition carry_gen_opt_sig fc fi i us
    : { d : list Z | (0 <= fi (S (fi i)) < length us)%nat ->
                     d = carry_gen limb_widths fc fi i us}.
  Proof.
    eexists; intros.
    cbv beta iota delta [carry_gen carry_single Z.pow2_mod].
    rewrite add_to_nth_set_nth.
    change @nth_default with @nth_default_opt in *.
    change @set_nth with @set_nth_opt in *.
    change Z.ones with Z_ones_opt.
    rewrite set_nth_nth_default by assumption.
    rewrite <- @beq_nat_eq_nat_dec.
    reflexivity.
  Defined.

  Definition carry_gen_opt fc fi i us := Eval cbv [proj1_sig carry_gen_opt_sig] in
                                                   proj1_sig (carry_gen_opt_sig fc fi i us).

  Definition carry_gen_opt_correct fc fi i us
    : (0 <= fi (S (fi i)) < length us)%nat ->
      carry_gen_opt fc fi i us = carry_gen limb_widths fc fi i us
    := proj2_sig (carry_gen_opt_sig fc fi i us).

  Definition carry_opt_sig
             (i : nat) (b : list Z)
    : { d : list Z | (length b = length limb_widths)
                     -> (i < length limb_widths)%nat
                     -> d = carry i b }.
  Proof.
    eexists ; intros.
    cbv [carry].
    rewrite <-pull_app_if_sumbool.
    cbv beta delta
      [carry carry_and_reduce carry_simple].
    lazymatch goal with
    | [ |- _ = (if ?br then ?c else ?d) ]
      => let x := fresh "x" in let y := fresh "y" in evar (x:list Z); evar (y:list Z); transitivity (if br then x else y); subst x; subst y
    end.
    Focus 2. {
      cbv zeta.
      break_if; rewrite <-carry_gen_opt_correct by (omega ||
          (replace (length b) with (length limb_widths) by congruence;
           apply Nat.mod_bound_pos; omega)); reflexivity.
    } Unfocus.
    rewrite c_subst.
    rewrite <- @beq_nat_eq_nat_dec.
    cbv [carry_gen_opt].
    reflexivity.
  Defined.

  Definition carry_opt is us := Eval cbv [proj1_sig carry_opt_sig] in
                                          proj1_sig (carry_opt_sig is us).

  Definition carry_opt_correct i us
    : length us = length limb_widths
      -> (i < length limb_widths)%nat
      -> carry_opt i us = carry i us
    := proj2_sig (carry_opt_sig i us).

  Definition carry_sequence_opt_sig (is : list nat) (us : list Z)
    : { b : list Z | (length us = length limb_widths)
                     -> (forall i, In i is -> i < length limb_widths)%nat
                     -> b = carry_sequence is us }.
  Proof.
    eexists. intros H.
    cbv [carry_sequence].
    transitivity (fold_right carry_opt us is).
    Focus 2.
    { induction is; [ reflexivity | ].
      simpl; rewrite IHis, carry_opt_correct.
      - reflexivity.
      - fold (carry_sequence is us). auto using length_carry_sequence.
      - auto using in_eq.
      - intros. auto using in_cons.
      }
    Unfocus.
    reflexivity.
  Defined.

  Definition carry_sequence_opt is us := Eval cbv [proj1_sig carry_sequence_opt_sig] in
                                          proj1_sig (carry_sequence_opt_sig is us).

  Definition carry_sequence_opt_correct is us
    : (length us = length limb_widths)
      -> (forall i, In i is -> i < length limb_widths)%nat
      -> carry_sequence_opt is us = carry_sequence is us
    := proj2_sig (carry_sequence_opt_sig is us).

  Definition carry_gen_opt_cps_sig
             {T} fc fi
             (i : nat)
             (f : list Z -> T)
             (b : list Z)
    : { d : T | (0 <= fi (S (fi i)) < length b)%nat -> d = f (carry_gen limb_widths fc fi i b) }.
  Proof.
    eexists. intros H.
    rewrite <-carry_gen_opt_correct by assumption.
    cbv beta iota delta [carry_gen_opt].
    match goal with |- appcontext[?a &' Z_ones_opt _] =>
    let LHS := match goal with |- ?LHS = ?RHS => LHS end in
    let RHS := match goal with |- ?LHS = ?RHS => RHS end in
    let RHSf := match (eval pattern (a) in RHS) with ?RHSf _ => RHSf end in
    change (LHS = Let_In (a) RHSf) end.
    reflexivity.
  Defined.

  Definition carry_gen_opt_cps {T} fc fi i f b
    := Eval cbv beta iota delta [proj1_sig carry_gen_opt_cps_sig] in
                                 proj1_sig (@carry_gen_opt_cps_sig T fc fi i f b).

  Definition carry_gen_opt_cps_correct {T} fc fi i f b :
   (0 <= fi (S (fi i)) < length b)%nat ->
    @carry_gen_opt_cps T fc fi i f b = f (carry_gen limb_widths fc fi i b)
    := proj2_sig (carry_gen_opt_cps_sig fc fi i f b).

  Definition carry_opt_cps_sig
             {T}
             (i : nat)
             (f : list Z -> T)
             (b : list Z)
    : { d : T | (length b = length limb_widths)
                 -> (i < length limb_widths)%nat
                 -> d = f (carry i b) }.
  Proof.
    eexists. intros.
    cbv beta delta
      [carry carry_and_reduce carry_simple].
    rewrite <-pull_app_if_sumbool.
    lazymatch goal with
    | [ |- _ = ?f (if ?br then ?c else ?d) ]
      => let x := fresh "x" in let y := fresh "y" in evar (x:T); evar (y:T); transitivity (if br then x else y); subst x; subst y
    end.
    Focus 2. {
      cbv zeta.
      break_if; rewrite <-carry_gen_opt_cps_correct by (omega ||
          (replace (length b) with (length limb_widths) by congruence;
           apply Nat.mod_bound_pos; omega)); reflexivity.
    } Unfocus.
    rewrite c_subst.
    rewrite <- @beq_nat_eq_nat_dec.
    reflexivity.
  Defined.

  Definition carry_opt_cps {T} i f b
    := Eval cbv beta iota delta [proj1_sig carry_opt_cps_sig] in proj1_sig (@carry_opt_cps_sig T i f b).

  Definition carry_opt_cps_correct {T} i f b :
    (length b = length limb_widths)
    -> (i < length limb_widths)%nat
    -> @carry_opt_cps T i f b = f (carry i b)
    := proj2_sig (carry_opt_cps_sig i f b).

  Definition carry_sequence_opt_cps_sig {T} (is : list nat) (us : list Z)
     (f : list Z -> T)
    : { b : T | (length us = length limb_widths)
                -> (forall i, In i is -> i < length limb_widths)%nat
                -> b = f (carry_sequence is us) }.
  Proof.
    eexists.
    cbv [carry_sequence].
    transitivity (fold_right carry_opt_cps f (List.rev is) us).
    Focus 2.
    {
      assert (forall i, In i (rev is) -> i < length limb_widths)%nat as Hr. {
        subst. intros. rewrite <- in_rev in *. auto. }
      remember (rev is) as ris eqn:Heq.
      rewrite <- (rev_involutive is), <- Heq in H0 |- *.
      clear H0 Heq is.
      rewrite fold_left_rev_right.
      revert H. revert us; induction ris; [ reflexivity | ]; intros.
      { simpl.
        rewrite <- IHris; clear IHris;
          [|intros; apply Hr; right; assumption|auto using length_carry].
        rewrite carry_opt_cps_correct; [reflexivity|congruence|].
        apply Hr; left; reflexivity.
        } }
    Unfocus.
    cbv [carry_opt_cps].
    reflexivity.
  Defined.

  Definition carry_sequence_opt_cps {T} is us (f : list Z -> T) :=
    Eval cbv [proj1_sig carry_sequence_opt_cps_sig] in
      proj1_sig (carry_sequence_opt_cps_sig is us f).

  Definition carry_sequence_opt_cps_correct {T} is us (f : list Z -> T)
    : (length us = length limb_widths)
      -> (forall i, In i is -> i < length limb_widths)%nat
      -> carry_sequence_opt_cps is us f = f (carry_sequence is us)
    := proj2_sig (carry_sequence_opt_cps_sig is us f).

  Lemma full_carry_chain_bounds : forall i, In i (Pow2Base.full_carry_chain limb_widths) ->
    (i < length limb_widths)%nat.
  Proof.
    unfold Pow2Base.full_carry_chain; intros.
    apply Pow2BaseProofs.make_chain_lt; auto.
  Qed.

  Definition carry_full_opt_sig (us : list Z) :
    { b : list Z | (length us = length limb_widths)
                   -> b = carry_full us }.
  Proof.
    eexists;  cbv [carry_full]; intros.
    match goal with |- ?LHS = ?RHS => change (LHS = id RHS) end.
    rewrite <-carry_sequence_opt_cps_correct with (f := id)  by (auto; apply full_carry_chain_bounds).
    change @Pow2Base.full_carry_chain with full_carry_chain_opt.
    reflexivity.
  Defined.

  Definition carry_full_opt (us : list Z) : list Z
    := Eval cbv [proj1_sig carry_full_opt_sig] in proj1_sig (carry_full_opt_sig us).

  Definition carry_full_opt_correct us
    : length us = length limb_widths
      -> carry_full_opt us = carry_full us
    := proj2_sig (carry_full_opt_sig us).

  Definition carry_full_opt_cps_sig
             {T}
             (f : list Z -> T)
             (us : list Z)
    : { d : T | length us = length limb_widths
                -> d = f (carry_full us) }.
  Proof.
    eexists; intros.
    rewrite <- carry_full_opt_correct by auto.
    cbv beta iota delta [carry_full_opt].
    rewrite carry_sequence_opt_cps_correct by (auto || apply full_carry_chain_bounds).
    match goal with |- ?LHS = ?f (?g (carry_sequence ?is ?us)) =>
      change (LHS = (fun x => f (g x)) (carry_sequence is us)) end.
    rewrite <-carry_sequence_opt_cps_correct by (auto || apply full_carry_chain_bounds).
    reflexivity.
  Defined.

  Definition carry_full_opt_cps {T} (f : list Z -> T) (us : list Z) : T
    := Eval cbv [proj1_sig carry_full_opt_cps_sig] in proj1_sig (carry_full_opt_cps_sig f us).

  Definition carry_full_opt_cps_correct {T} us (f : list Z -> T)
    : length us = length limb_widths
      -> carry_full_opt_cps f us = f (carry_full us)
    := proj2_sig (carry_full_opt_cps_sig f us).

End Carries.

Section CarryChain.
  Context `{prm : PseudoMersenneBaseParams} {cc : CarryChain limb_widths}.
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition carry__opt_sig {T} (f : digits -> T) (us : digits)
    : { x | x = f (carry_ carry_chain us) }.
  Proof.
    eexists.
    cbv [carry_].
    rewrite <- from_list_default_eq with (d := 0%Z).
    change @from_list_default with @from_list_default_opt.
    erewrite <-carry_sequence_opt_cps_correct by eauto using carry_chain_valid, length_to_list.
    cbv [carry_sequence_opt_cps].
    reflexivity.
  Defined.

  Definition carry__opt_cps {T} (f:digits -> T) (us : digits) : T
    := Eval cbv [proj1_sig carry__opt_sig] in proj1_sig (carry__opt_sig f us).

  Definition carry__opt_cps_correct {T} (f:digits -> T) (us : digits)
    : carry__opt_cps f us = f (carry_ carry_chain us)
    := proj2_sig (carry__opt_sig f us).
End CarryChain.

Section Addition.
  Context `{prm : PseudoMersenneBaseParams} {sc : SubtractionCoefficient} {cc : CarryChain limb_widths}.
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition add_opt_sig (us vs : digits) : { b : digits | b = add us vs }.
  Proof.
    eexists.
    reflexivity.
  Defined.

  Definition add_opt (us vs : digits) : digits
    := Eval cbv [proj1_sig add_opt_sig] in proj1_sig (add_opt_sig us vs).

  Definition add_opt_correct us vs
    : add_opt us vs = add us vs
    := proj2_sig (add_opt_sig us vs).

  Definition carry_add_opt_sig {T} (f:digits -> T)
    (us vs : digits) : { x | x = f (carry_add carry_chain us vs) }.
  Proof.
    eexists.
    cbv [carry_add].
    rewrite <-carry__opt_cps_correct, <-add_opt_correct.
    cbv [carry_sequence_opt_cps carry__opt_cps add_opt add].
    rewrite to_list_from_list.
    reflexivity.
  Defined.

  Definition carry_add_opt_cps {T} (f:digits -> T) (us vs : digits) : T
    := Eval cbv [proj1_sig carry_add_opt_sig] in proj1_sig (carry_add_opt_sig f us vs).

  Definition carry_add_opt_cps_correct {T} (f:digits -> T) (us vs : digits)
    : carry_add_opt_cps f us vs = f (carry_add carry_chain us vs)
    := proj2_sig (carry_add_opt_sig f us vs).

  Definition carry_add_opt := carry_add_opt_cps id.

  Definition carry_add_opt_correct (us vs : digits)
    : carry_add_opt us vs = carry_add carry_chain us vs :=
    carry_add_opt_cps_correct id us vs.
End Addition.

Section Subtraction.
  Context `{prm : PseudoMersenneBaseParams} {sc : SubtractionCoefficient} {cc : CarryChain limb_widths}.
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition sub_opt_sig (us vs : digits) : { b : digits | b = sub coeff coeff_mod us vs }.
  Proof.
    eexists.
    cbv [BaseSystem.add ModularBaseSystem.sub BaseSystem.sub].
    reflexivity.
  Defined.

  Definition sub_opt (us vs : digits) : digits
    := Eval cbv [proj1_sig sub_opt_sig] in proj1_sig (sub_opt_sig us vs).

  Definition sub_opt_correct us vs
    : sub_opt us vs = sub coeff coeff_mod us vs
    := proj2_sig (sub_opt_sig us vs).

  Definition carry_sub_opt_sig {T} (f:digits -> T)
    (us vs : digits) : { x | x = f (carry_sub carry_chain coeff coeff_mod us vs) }.
  Proof.
    eexists.
    cbv [carry_sub].
    rewrite <-carry__opt_cps_correct, <-sub_opt_correct.
    cbv [carry_sequence_opt_cps carry__opt_cps sub_opt].
    rewrite to_list_from_list.
    reflexivity.
  Defined.

  Definition carry_sub_opt_cps {T} (f:digits -> T) (us vs : digits) : T
    := Eval cbv [proj1_sig carry_sub_opt_sig] in proj1_sig (carry_sub_opt_sig f us vs).

  Definition carry_sub_opt_cps_correct {T} (f:digits -> T) (us vs : digits)
    : carry_sub_opt_cps f us vs = f (carry_sub carry_chain coeff coeff_mod us vs)
    := proj2_sig (carry_sub_opt_sig f us vs).

  Definition carry_sub_opt := carry_sub_opt_cps id.

  Definition carry_sub_opt_correct (us vs : digits)
    : carry_sub_opt us vs = carry_sub carry_chain coeff coeff_mod us vs :=
    carry_sub_opt_cps_correct id us vs.

  Definition opp_opt_sig (us : digits) : { b : digits | b = opp coeff coeff_mod us }.
  Proof.
    eexists.
    cbv [opp].
    rewrite <-sub_opt_correct.
    reflexivity.
  Defined.

  Definition opp_opt (us : digits) : digits
    := Eval cbv [proj1_sig opp_opt_sig] in proj1_sig (opp_opt_sig us).

  Definition opp_opt_correct us
    : opp_opt us = opp coeff coeff_mod us
    := proj2_sig (opp_opt_sig us).

  Definition carry_opp_opt_sig (us : digits) : { b : digits | b = carry_opp carry_chain coeff coeff_mod us }.
  Proof.
    eexists.
    cbv [carry_opp].
    rewrite <-carry_sub_opt_correct.
    reflexivity.
  Defined.

  Definition carry_opp_opt (us : digits) : digits
    := Eval cbv [proj1_sig carry_opp_opt_sig] in proj1_sig (carry_opp_opt_sig us).

  Definition carry_opp_opt_correct us
    : carry_opp_opt us = carry_opp carry_chain coeff coeff_mod us
    := proj2_sig (carry_opp_opt_sig us).

End Subtraction.

Section Multiplication.
  Context `{prm : PseudoMersenneBaseParams} {sc : SubtractionCoefficient} {cc : CarryChain limb_widths}
    (* allows caller to precompute k and c *)
    (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_).
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition mul_bi'_step
             (mul_bi' : nat -> list Z -> list Z -> list Z)
             (i : nat) (vsr : list Z) (bs : list Z)
    : list Z
    := match vsr with
       | [] => []
       | v :: vsr' => (v * crosscoef bs i (length vsr'))%Z :: mul_bi' i vsr' bs
       end.

  Definition mul_bi'_opt_step_sig
             (mul_bi' : nat -> list Z -> list Z -> list Z)
             (i : nat) (vsr : list Z) (bs : list Z)
    : { l : list Z | l = mul_bi'_step mul_bi' i vsr bs }.
  Proof.
    eexists.
    cbv [mul_bi'_step].
    opt_step.
    { reflexivity. }
    { cbv [crosscoef].
      change Z.div with Z_div_opt.
      change Z.mul with Z_mul_opt at 2.
      change @nth_default with @nth_default_opt.
      reflexivity. }
  Defined.

  Definition mul_bi'_opt_step
             (mul_bi' : nat -> list Z -> list Z -> list Z)
             (i : nat) (vsr : list Z) (bs : list Z)
    : list Z
    := Eval cbv [proj1_sig mul_bi'_opt_step_sig] in
        proj1_sig (mul_bi'_opt_step_sig mul_bi' i vsr bs).

  Fixpoint mul_bi'_opt
           (i : nat) (vsr : list Z) (bs : list Z) {struct vsr}
    : list Z
    := mul_bi'_opt_step mul_bi'_opt i vsr bs.

  Definition mul_bi'_opt_correct
             (i : nat) (vsr : list Z) (bs : list Z)
    : mul_bi'_opt i vsr bs = mul_bi' bs i vsr.
  Proof.
    revert i; induction vsr as [|vsr vsrs IHvsr]; intros.
    { reflexivity. }
    { simpl mul_bi'.
      rewrite <- IHvsr; clear IHvsr.
      unfold mul_bi'_opt, mul_bi'_opt_step.
      apply f_equal2; [ | reflexivity ].
      cbv [crosscoef].
      change Z.div with Z_div_opt.
      change Z.mul with Z_mul_opt at 2.
      change @nth_default with @nth_default_opt.
      reflexivity. }
  Qed.

  Definition mul'_step
             (mul' : list Z -> list Z -> list Z -> list Z)
             (usr vs : list Z) (bs : list Z)
    : list Z
    := match usr with
       | [] => []
       | u :: usr' => BaseSystem.add (mul_each u (mul_bi bs (length usr') vs)) (mul' usr' vs bs)
       end.

  Lemma map_zeros : forall a n l,
    List.map (Z.mul a) (zeros n ++ l) = zeros n ++ List.map (Z.mul a) l.
  Proof.
    induction n; simpl; [ reflexivity | intros; apply f_equal2; [ omega | congruence ] ].
  Qed.

  Definition mul'_opt_step_sig
             (mul' : list Z -> list Z -> list Z -> list Z)
             (usr vs : list Z) (bs : list Z)
    : { d : list Z | d = mul'_step mul' usr vs bs }.
  Proof.
    eexists.
    cbv [mul'_step].
    match goal with
    | [ |- _ = match ?e with nil => _ | _ => _ end :> ?T ]
      => refine (_ : match e with nil => _ | _ => _ end = _);
           destruct e
    end.
    { reflexivity. }
    { cbv [mul_each mul_bi].
      rewrite <- mul_bi'_opt_correct.
      rewrite map_zeros.
      change @List.map with @map_opt.
      cbv [zeros].
      reflexivity. }
  Defined.

  Definition mul'_opt_step
             (mul' : list Z -> list Z -> list Z -> list Z)
             (usr vs : list Z) (bs : list Z)
    : list Z
    := Eval cbv [proj1_sig mul'_opt_step_sig] in proj1_sig (mul'_opt_step_sig mul' usr vs bs).

  Fixpoint mul'_opt
           (usr vs : list Z) (bs : list Z)
    : list Z
    := mul'_opt_step mul'_opt usr vs bs.

  Definition mul'_opt_correct
           (usr vs : list Z) (bs : list Z)
    : mul'_opt usr vs bs = mul' bs usr vs.
  Proof.
    revert vs; induction usr as [|usr usrs IHusr]; intros.
    { reflexivity. }
    { simpl.
      rewrite <- IHusr; clear IHusr.
      apply f_equal2; [ | reflexivity ].
      cbv [mul_each mul_bi].
      rewrite map_zeros.
      rewrite <- mul_bi'_opt_correct.
      cbv [zeros].
      reflexivity. }
  Qed.

  Definition mul_opt_sig (us vs : digits) : { b : digits | b = mul us vs }.
  Proof.
    eexists.
    cbv [mul ModularBaseSystemList.mul BaseSystem.mul mul_each mul_bi mul_bi' zeros reduce].
    rewrite <- from_list_default_eq with (d := 0%Z).
    change (@from_list_default Z) with (@from_list_default_opt Z).
    apply f_equal.
    rewrite ext_base_alt by auto using limb_widths_pos with zarith.
    rewrite <- mul'_opt_correct.
    change @Pow2Base.base_from_limb_widths with base_from_limb_widths_opt.
    rewrite Z.map_shiftl by apply k_nonneg.
    rewrite c_subst.
    fold k; rewrite k_subst.
    change @List.map with @map_opt.
    change @Z.shiftl_by with @Z_shiftl_by_opt.
    reflexivity.
  Defined.

  Definition mul_opt (us vs : digits) : digits
    := Eval cbv [proj1_sig mul_opt_sig] in proj1_sig (mul_opt_sig us vs).

  Definition mul_opt_correct us vs
    : mul_opt us vs = mul us vs
    := proj2_sig (mul_opt_sig us vs).

  Definition carry_mul_opt_sig {T} (f:digits -> T)
    (us vs : digits) : { x | x = f (carry_mul carry_chain us vs) }.
  Proof.
    eexists.
    cbv [carry_mul].
    rewrite <-carry__opt_cps_correct, <-mul_opt_correct.
    cbv [carry_sequence_opt_cps carry__opt_cps mul_opt].
    erewrite from_list_default_eq.
    rewrite to_list_from_list.
    reflexivity.
    Grab Existential Variables.
    rewrite mul'_opt_correct.
    distr_length.
    assert (0 < length limb_widths)%nat by (pose proof limb_widths_nonnil; destruct limb_widths; congruence || simpl; omega).
    rewrite Min.min_l; break_match; try omega.
    rewrite Max.max_l; omega.
  Defined.

  Definition carry_mul_opt_cps {T} (f:digits -> T) (us vs : digits) : T
    := Eval cbv [proj1_sig carry_mul_opt_sig] in proj1_sig (carry_mul_opt_sig f us vs).

  Definition carry_mul_opt_cps_correct {T} (f:digits -> T) (us vs : digits)
    : carry_mul_opt_cps f us vs = f (carry_mul carry_chain us vs)
    := proj2_sig (carry_mul_opt_sig f us vs).

  Definition carry_mul_opt := carry_mul_opt_cps id.

  Definition carry_mul_opt_correct (us vs : digits)
    : carry_mul_opt us vs = carry_mul carry_chain us vs :=
    carry_mul_opt_cps_correct id us vs.

End Multiplication.

Import Morphisms.
Global Instance Proper_fold_chain {T} {Teq} {Teq_Equivalence : Equivalence Teq}
  : Proper (Logic.eq
              ==> (fun f g => forall x1 x2 y1 y2 : T, Teq x1 x2 -> Teq y1 y2 -> Teq (f x1 y1) (g x2 y2))
              ==> Logic.eq
              ==> SetoidList.eqlistA Teq
              ==> Teq) fold_chain.
Proof.
  do 9 intro.
  subst; induction y1; repeat intro;
    unfold fold_chain; fold @fold_chain.
  + inversion H; assumption || reflexivity.
  + destruct a.
    apply IHy1.
    econstructor; try assumption.
    apply H0; eapply Proper_nth_default; eauto; reflexivity.
Qed.

Section PowInv.
  Context `{prm : PseudoMersenneBaseParams}
          (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_)
          {cc : CarryChain limb_widths}.
  Local Notation digits := (tuple Z (length limb_widths)).
  Context (one_ : digits) (one_subst : one = one_).

  Fixpoint fold_chain_opt {T} (id : T) op chain acc :=
  match chain with
  | [] => match acc with
          | [] => id
          | ret :: _ => ret
          end
  | (i, j) :: chain' =>
      Let_In (op (nth_default id acc i) (nth_default id acc j))
      (fun ijx => fold_chain_opt id op chain' (ijx :: acc))
  end.

  Lemma fold_chain_opt_correct : forall {T} (id : T) op chain acc,
    fold_chain_opt id op chain acc = fold_chain id op chain acc.
  Proof.
    reflexivity.
  Qed.

  Definition pow_opt_sig x chain :
    {y | eq y (ModularBaseSystem.pow x chain)}.
  Proof.
    eexists.
    cbv beta iota delta [ModularBaseSystem.pow].
    transitivity (fold_chain one_ (carry_mul_opt k_ c_) chain [x]).
    Focus 2. {
      apply Proper_fold_chain; auto; try reflexivity.
      cbv [eq]; intros.
      rewrite carry_mul_opt_correct by assumption.
      rewrite carry_mul_rep, mul_rep by reflexivity.
      congruence.
    } Unfocus.
    rewrite <-fold_chain_opt_correct.
    reflexivity.
  Defined.

  Definition pow_opt x chain : digits
    := Eval cbv [proj1_sig pow_opt_sig] in (proj1_sig (pow_opt_sig x chain)).

  Definition pow_opt_correct x chain
    : eq (pow_opt x chain) (ModularBaseSystem.pow x chain)
    := Eval cbv [proj2_sig pow_opt_sig] in (proj2_sig (pow_opt_sig x chain)).

  Context {ec : ExponentiationChain (modulus - 2)}.

  Definition inv_opt_sig x:
    {y | eq y (inv chain chain_correct x)}.
  Proof.
    eexists.
    cbv [inv].
    rewrite <-pow_opt_correct.
    reflexivity.
  Defined.

  Definition inv_opt x : digits
    := Eval cbv [proj1_sig inv_opt_sig] in (proj1_sig (inv_opt_sig x)).

  Definition inv_opt_correct x
    : eq (inv_opt x) (inv chain chain_correct x)
    := Eval cbv [proj2_sig inv_opt_sig] in (proj2_sig (inv_opt_sig x)).
End PowInv.

Section Conversion.

  Definition convert'_opt_sig {lwA lwB}
             (nonnegA : forall x, In x lwA -> 0 <= x)
             (nonnegB : forall x, In x lwB -> 0 <= x)
             bits_fit inp i out :
    { y | y = convert' nonnegA nonnegB bits_fit inp i out}.
  Proof.
    eexists.
    rewrite convert'_equation.
    change sum_firstn with @sum_firstn_opt.
    change length with length_opt.
    change Z_le_dec with Z_le_dec_opt.
    change Z.of_nat with Z_of_nat_opt.
    change digit_index with digit_index_opt.
    change bit_index with bit_index_opt.
    change Z.min with Z_min_opt.
    change (nth_default 0 lwA) with (nth_default_opt 0 lwA).
    change (nth_default 0 lwB) with (nth_default_opt 0 lwB).
    cbv [update_by_concat_bits concat_bits Z.pow2_mod].
    change Z.ones with Z_ones_opt.
    change @update_nth with @update_nth_opt.
    change plus with plus_opt.
    change Z.sub with Z_sub_opt.
    reflexivity.
  Defined.

  Definition convert'_opt {lwA lwB}
             (nonnegA : forall x, In x lwA -> 0 <= x)
             (nonnegB : forall x, In x lwB -> 0 <= x)
             bits_fit inp i out :=
    Eval cbv [proj1_sig convert'_opt_sig] in
      proj1_sig (convert'_opt_sig nonnegA nonnegB bits_fit inp i out).

  Definition convert'_opt_correct {lwA lwB}
             (nonnegA : forall x, In x lwA -> 0 <= x)
             (nonnegB : forall x, In x lwB -> 0 <= x)
             bits_fit inp i out :
    convert'_opt nonnegA nonnegB bits_fit inp i out = convert' nonnegA nonnegB bits_fit inp i out :=
    Eval cbv [proj2_sig convert'_opt_sig] in
      proj2_sig (convert'_opt_sig nonnegA nonnegB bits_fit inp i out).

  Context {modulus} (prm : PseudoMersenneBaseParams modulus)
          {target_widths} (target_widths_nonneg : forall x, In x target_widths -> 0 <= x) (bits_eq : sum_firstn limb_widths (length limb_widths) = sum_firstn target_widths (length target_widths)).
  Local Notation digits := (tuple Z (length limb_widths)).
  Local Notation target_digits := (tuple Z (length target_widths)).

  Definition pack_opt_sig (x : digits) : { y | y = pack target_widths_nonneg bits_eq x}.
  Proof.
    eexists.
    cbv [pack].
    rewrite <- from_list_default_eq with (d := 0%Z).
    change @from_list_default with @from_list_default_opt.
    cbv [ModularBaseSystemList.pack convert].
    change length with length_opt.
    change sum_firstn with @sum_firstn_opt.
    change zeros with zeros_opt.
    reflexivity.
  Defined.

  Definition pack_opt (x : digits) : target_digits :=
    Eval cbv [proj1_sig pack_opt_sig] in proj1_sig (pack_opt_sig x).

  Definition pack_correct (x : digits) :
    pack_opt x = pack target_widths_nonneg bits_eq x
    := Eval cbv [proj2_sig pack_opt_sig] in proj2_sig (pack_opt_sig x).

  Definition unpack_opt_sig (x : target_digits) : { y | y = unpack target_widths_nonneg bits_eq x}.
  Proof.
    eexists.
    cbv [unpack].
    rewrite <- from_list_default_eq with (d := 0%Z).
    change @from_list_default with @from_list_default_opt.
    cbv [ModularBaseSystemList.unpack convert].
    change length with length_opt.
    change sum_firstn with @sum_firstn_opt.
    change zeros with zeros_opt.
    reflexivity.
  Defined.

  Definition unpack_opt (x : target_digits) : digits :=
    Eval cbv [proj1_sig unpack_opt_sig] in proj1_sig (unpack_opt_sig x).

  Definition unpack_correct (x : target_digits) :
    unpack_opt x = unpack target_widths_nonneg bits_eq x
    := Eval cbv [proj2_sig unpack_opt_sig] in proj2_sig (unpack_opt_sig x).

End Conversion.

Local Hint Resolve lt_1_length_limb_widths int_width_pos B_pos B_compat
  c_reduce1 c_reduce2.

Section Canonicalization.
  Context `{prm : PseudoMersenneBaseParams} {sc : SubtractionCoefficient}
    (* allows caller to precompute k and c *)
    (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_)
    {int_width freeze_input_bound}
    (preconditions : FreezePreconditions freeze_input_bound int_width).
  Local Notation digits := (tuple Z (length limb_widths)).

  Definition carry_full_3_opt_sig
             (us : list Z)
    : { d : list Z | length us = length limb_widths
                 -> d = carry_full (carry_full (carry_full us)) }.
  Proof.
    eexists.
    transitivity (carry_full_opt_cps c_ (carry_full_opt_cps c_ (carry_full_opt c_)) us).
    Focus 2. {
      rewrite !carry_full_opt_cps_correct; try rewrite carry_full_opt_correct; repeat (autorewrite with distr_length; rewrite ?length_carry_full; auto).
    }
    Unfocus.
    reflexivity.
  Defined.

  Definition carry_full_3_opt (us : list Z) : list Z
    := Eval cbv [proj1_sig carry_full_3_opt_sig] in proj1_sig (carry_full_3_opt_sig us).

  Definition carry_full_3_opt_correct us
    : length us = length limb_widths
      -> carry_full_3_opt us = carry_full (carry_full (carry_full us))
    := proj2_sig (carry_full_3_opt_sig us).

  Lemma ge_modulus'_cps : forall {A} (f : Z -> A) (us : list Z) i b,
    f (ge_modulus' id us b i) = ge_modulus' f us b i.
  Proof.
    induction i; intros; simpl; cbv [Let_In cmovl cmovne]; break_if; try reflexivity;
      apply IHi.
  Qed.

  Definition ge_modulus_opt_sig (us : list Z) :
    { a : Z | a = ge_modulus us}.
  Proof.
    eexists.
    cbv [ge_modulus ge_modulus'].
    change length with length_opt.
    change nth_default with @nth_default_opt.
    change minus with minus_opt.
    reflexivity.
  Defined.

  Definition ge_modulus_opt us : Z
    := Eval cbv [proj1_sig ge_modulus_opt_sig] in proj1_sig (ge_modulus_opt_sig us).

  Definition ge_modulus_opt_correct us :
    ge_modulus_opt us= ge_modulus us
    := Eval cbv [proj2_sig ge_modulus_opt_sig] in proj2_sig (ge_modulus_opt_sig us).

  Definition conditional_subtract_modulus_opt_sig (f : list Z):
    { g | g = conditional_subtract_modulus int_width f (ge_modulus f) }.
  Proof.
    eexists.
    cbv [conditional_subtract_modulus].
    let LHS := match goal with |- ?LHS = ?RHS => LHS end in
    let RHS := match goal with |- ?LHS = ?RHS => RHS end in
    let RHSf := match (eval pattern (neg int_width (ge_modulus f)) in RHS) with ?RHSf _ => RHSf end in
    change (LHS = Let_In (neg int_width (ge_modulus f)) RHSf).
    cbv [ge_modulus].
    rewrite ge_modulus'_cps.
    cbv beta iota delta [ge_modulus ge_modulus'].
    change length with length_opt.
    change nth_default with @nth_default_opt.
    change @Pow2Base.base_from_limb_widths with base_from_limb_widths_opt.
    change minus with minus_opt.
    reflexivity.
  Defined.

  Definition conditional_subtract_modulus_opt f : list Z
    := Eval cbv [proj1_sig conditional_subtract_modulus_opt_sig] in proj1_sig (conditional_subtract_modulus_opt_sig f).

  Definition conditional_subtract_modulus_opt_correct f
    : conditional_subtract_modulus_opt f = conditional_subtract_modulus int_width f (ge_modulus f)
    := Eval cbv [proj2_sig conditional_subtract_modulus_opt_sig] in proj2_sig (conditional_subtract_modulus_opt_sig f).

  Definition freeze_opt_sig (us : list Z) :
    { b : list Z | length us = length limb_widths
                   -> b = ModularBaseSystemList.freeze int_width us }.
  Proof.
    eexists.
    cbv [ModularBaseSystemList.freeze].
    rewrite <-conditional_subtract_modulus_opt_correct.
    intros.
    rewrite <-carry_full_3_opt_correct by auto.
    let LHS := match goal with |- ?LHS = ?RHS => LHS end in
    let RHS := match goal with |- ?LHS = ?RHS => RHS end in
    let RHSf := match (eval pattern (carry_full_3_opt us) in RHS) with ?RHSf _ => RHSf end in
    change (LHS = Let_In (carry_full_3_opt us) RHSf).
    reflexivity.
  Defined.

  Definition freeze_opt (us : list Z) : list Z
    := Eval cbv beta iota delta [proj1_sig freeze_opt_sig] in proj1_sig (freeze_opt_sig us).

  Definition freeze_opt_correct us
    : length us = length limb_widths
      -> freeze_opt us = ModularBaseSystemList.freeze int_width us
    := proj2_sig (freeze_opt_sig us).

End Canonicalization.

Section SquareRoots.
  Context `{prm : PseudoMersenneBaseParams}.
  Context {cc : CarryChain limb_widths}.
  Local Notation digits := (tuple Z (length limb_widths)).
          (* allows caller to precompute k and c *)
  Context (k_ c_ : Z) (k_subst : k = k_) (c_subst : c = c_)
          (one_ : digits) (one_subst : one = one_).

  (* TODO : where should this lemma go? Alternatively, is there a standard-library
     tactic/lemma for this? *)
  Lemma if_equiv : forall {A} (eqA : A -> A -> Prop) (x0 x1 : bool) y0 y1 z0 z1,
    x0 = x1 -> eqA y0 y1 -> eqA z0 z1 ->
    eqA (if x0 then y0 else z0) (if x1 then y1 else z1).
  Proof.
    intros; repeat break_if; congruence.
  Qed.

  Section SquareRoot3mod4.
  Context {ec : ExponentiationChain (modulus / 4 + 1)}.

  Definition sqrt_3mod4_opt_sig (us : digits) :
    { vs : digits | eq vs (sqrt_3mod4 chain chain_correct us)}.
  Proof.
    eexists; cbv [sqrt_3mod4].
    apply @pow_opt_correct; eassumption.
  Defined.

  Definition sqrt_3mod4_opt us := Eval cbv [proj1_sig sqrt_3mod4_opt_sig] in
    proj1_sig (sqrt_3mod4_opt_sig us).

  Definition sqrt_3mod4_opt_correct us
    : eq (sqrt_3mod4_opt us) (sqrt_3mod4 chain chain_correct us)
    := Eval cbv [proj2_sig sqrt_3mod4_opt_sig] in proj2_sig (sqrt_3mod4_opt_sig us).

  End SquareRoot3mod4.

  Section SquareRoot5mod8.
  Context {ec : ExponentiationChain (modulus / 8 + 1)}.
  Context (sqrt_m1 : digits) (sqrt_m1_correct : rep (mul sqrt_m1 sqrt_m1) (F.opp 1%F)).
  Context {int_width freeze_input_bound}
          (preconditions : FreezePreconditions freeze_input_bound int_width).

  Definition sqrt_5mod8_opt_sig (powx powx_squared us : digits) :
    { vs : digits |
      eq vs (sqrt_5mod8 int_width powx powx_squared chain chain_correct sqrt_m1 us)}.
  Proof.
    cbv [sqrt_5mod8].
    match goal with
      |- appcontext[(if ?P then ?t else mul ?a ?b)] =>
      assert (eq (carry_mul_opt k_ c_ a b) (mul a b))
        by (rewrite carry_mul_opt_correct by auto;
           cbv [eq]; rewrite carry_mul_rep, mul_rep; reflexivity)
    end.
    let RHS := match goal with |- {vs | eq vs ?RHS} => RHS end in
    let RHSf := match (eval pattern powx in RHS) with ?RHSf _ => RHSf end in
    change ({vs | eq vs (Let_In powx RHSf)}).
    match goal with
    | H : eq (?g powx) (?f powx)
    |- {vs | eq vs (Let_In powx (fun x => if ?P then x else ?f x))} =>
      exists (Let_In powx (fun x => if P then x else g x))
    end.
    break_if; try reflexivity.
    cbv [Let_In].
    auto.
  Defined.

  Definition sqrt_5mod8_opt powx powx_squared us := Eval cbv [proj1_sig sqrt_5mod8_opt_sig] in
    proj1_sig (sqrt_5mod8_opt_sig powx powx_squared us).

  Definition sqrt_5mod8_opt_correct powx powx_squared us
    : eq (sqrt_5mod8_opt powx powx_squared us) (ModularBaseSystem.sqrt_5mod8 int_width _ _ chain chain_correct sqrt_m1 us)
    := Eval cbv [proj2_sig sqrt_5mod8_opt_sig] in proj2_sig (sqrt_5mod8_opt_sig powx powx_squared us).

  End SquareRoot5mod8.

End SquareRoots.


Require Import Logic.lib.EnsemblesProperties.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.

Local Open Scope logic_base.

Section ContextProperty.

Context {L: Language}
        {minL: MinimumLanguage L}
        {Gamma: Derivable L}
        {fwSC: FiniteWitnessedSequentCalculus L Gamma}.

Lemma can_derive_finite_witnessed: forall x,
  finite_witnessed (can_derive x).
Proof.
  intros; hnf; intros.
  apply derivable_finite_witnessed; auto.
Qed.

Lemma cannot_derive_finite_captured: forall x,
  finite_captured (cannot_derive x).
Proof.
  intros.
  apply (not_finite_witnessed_finite_captured _ (can_derive_finite_witnessed x)).
Qed.

End ContextProperty.


Require Import equiv.

Lemma type_guarantees_applicability :
  forall (theta : assignment) gamma b,
  is_equiv_rel gamma ->
    theta |= gamma -> gamma |= b <-> exists d, (theta , d) |= b.
Proof.
  intros theta gamma b gamma_equiv;
  intros theta_gamma.
  destruct gamma_equiv as [gref [gsym gtran]].
  split; intros gamma_b.
  - destruct (b_is_empty_or_not b) as [b_empty | [i1 bi1]].
    + destruct (outside_data_exists theta) as [dd dd_neq].
      exists dd.
      unfold models. unfold assignmentD_models_guard.
      intros i0.
      split; intros H'.
      * apply dd_neq in H'. contradiction.
      * apply b_empty in H'. contradiction.
    + apply gamma_b in bi1.
      exists (theta i1).
      unfold models. unfold assignmentD_models_guard.
      intros i0.
      split; intros H'.
      * apply bi1. apply theta_gamma. auto.
      * apply theta_gamma. apply gsym. apply bi1. auto.
  - destruct gamma_b as [d theta_d_b].
    unfold models. unfold rel_models_guard.
    intros i1 bi1 j1.
    split; intros H.
    + apply theta_gamma.
      apply theta_d_b in bi1. rewrite bi1.
      apply theta_d_b in H. rewrite H. reflexivity.
    + apply theta_d_b in bi1.
      apply theta_d_b. rewrite <- bi1.
      apply theta_gamma.
      apply gsym. auto.
Qed.

Lemma type_uniqueness :
  forall (theta : assignment) gamma gamma',
  is_equiv_rel gamma ->
  is_equiv_rel gamma' ->
    theta |= gamma /\ theta |= gamma' -> gamma = gamma'.
Proof.
  intros theta gamma gamma';
  intros gamma_equiv gamma'_equiv.
  unfold models; unfold assignment_models_rel.
  intros [[gsimpl tg] [g'simpl tg']].
  apply rel_extensionality.
  intros x y.
  split; intros Hg.
  - case x, y.
    + apply tg'. apply tg in Hg. assumption.
    + apply (gsimpl (X i) (X' i0)) in Hg. discriminate.
    + apply (gsimpl (X' i) (X i0)) in Hg. discriminate.
    + apply (gsimpl (X' i) (X' i0)) in Hg.
      case Hg.
      destruct gamma'_equiv as [g'ref _].
      apply g'ref.
  - case x, y.
    + apply tg. apply tg' in Hg. assumption.
    + apply (g'simpl (X i) (X' i0)) in Hg. discriminate.
    + apply (g'simpl (X' i) (X i0)) in Hg. discriminate.
    + apply (g'simpl (X' i) (X' i0)) in Hg.
      case Hg.
      destruct gamma_equiv as [gref _].
      apply gref.
Qed.

Lemma updater_must_exist :
  forall (theta : assignment) gamma b,
    is_equiv_rel gamma -> theta |= gamma -> gamma |= b ->
    exists d : D, (theta, d) |= b.
Proof.
  intros theta gamma b;
  intros [_ [ga_sym _]] th_ga ga_b.
  destruct (b_is_empty_or_not b) as [b_empty | [i bi]].
  - destruct (outside_data_exists theta) as [d d_notin].
    exists d.
    unfold models; unfold assignmentD_models_guard.
    intros i.
    split; intros H.
  + elim (d_notin i); exact H.
  + elim (b_empty i); exact H.
  - exists (theta i).
    unfold models; unfold assignmentD_models_guard.
    intros j.
    split; intros H.
  + apply th_ga in H.
    apply ga_sym in H.
    apply ga_b in H.
  * exact H.
  * exact bi.
  + apply th_ga.
    apply ga_b.
  * exact H.
  * exact bi.
Qed.

(* trivial *)

Lemma equiv_rel_refl :
  forall phi,
  is_equiv_rel phi -> forall x, phi x x.
Proof.
  intros phi phi_equiv x.
  destruct phi_equiv as [phi_refl _].
  unfold is_reflexive in phi_refl.
  apply phi_refl.
Qed.

(* former / lat *)

Lemma elim_former :
  forall phi i j,
  former phi (X i) (X j) = phi (X i) (X j).
Proof.
  intros phi i j.
  unfold former.
  reflexivity.
Qed.

Lemma elim_lat :
  forall phi i j,
  lat phi (X i) (X j) = phi (X' i) (X' j).
Proof.
  intros phi i j.
  unfold lat.
  reflexivity.
Qed.

Lemma former_is_simpl_rel :
  forall phi, is_simpl_rel (former phi).
Proof.
  intros phi.
  unfold is_simpl_rel; unfold former.
  intros x y.
  case x, y.
  - apply I.
  - split; intros H; assumption.
  - split; intros H; assumption.
  - split; intros H; assumption.
Qed.

Lemma lat_phi_is_equiv_rel :
  forall (phi : Rel), is_equiv_rel phi -> is_equiv_rel (lat phi).
Proof.
  intros phi phi_equiv.
  destruct phi_equiv as [phi_refl [phi_sym phi_tran]].
  unfold is_equiv_rel.
  repeat split.
  - unfold is_reflexive.
    intros x.
    unfold lat.
    case x; try auto.
  - unfold is_symmetric.
    unfold lat.
    intros x y H.
    case x, y; try auto.
  - unfold is_transitive.
    unfold lat.
    intros x y z [H1 H2].
    case x, y, z; try discriminate; try auto.
  + apply (phi_tran _ (X' i0) _).
    auto.
  + rewrite H1; exact H2.
Qed.

Lemma lat_phi_is_simpl_rel :
  forall (phi : Rel), is_simpl_rel (lat phi).
Proof.
  intros phi.
  unfold is_simpl_rel; unfold lat.
  intros x y.
  case x, y; try reflexivity.
Qed.

Lemma gamma_lat_phi :
  forall (gamma phi : Rel) (theta theta' : assignment),
    is_simpl_rel gamma ->
    (theta', theta) |= phi ->
    theta |= gamma <-> gamma = lat phi.
Proof.
  intros gamma phi theta theta';
  intros ga_simpl theta_phi.
  split.
{
  intros th_ga.
  apply rel_extensionality.
  intros x y.
  split; intros H.
  - unfold lat.
    case x, y.
  + apply theta_phi; apply th_ga; exact H.
  + apply (ga_simpl (X i) (X' i0)); exact H.
  + apply (ga_simpl (X' i) (X i0)); exact H.
  + apply (ga_simpl (X' i) (X' i0)); exact H.
  - case x, y.
  + unfold lat in H.
    apply th_ga; apply theta_phi; exact H.
  + unfold lat in H.
    apply (ga_simpl (X i) (X' i0)); exact H.
  + unfold lat in H.
    apply (ga_simpl (X' i) (X i0)); exact H.
  + unfold lat in H.
    apply (ga_simpl (X' i) (X' i0)); exact H.
}
{
  intros ga_latphi.
  unfold models; unfold assignment_models_rel.
  split; try auto.
  intros i j.
  rewrite ga_latphi.
  unfold lat.
  split; intros H.
  - apply theta_phi; exact H.
  - apply theta_phi; exact H.
}
Qed.

Lemma lat_eq_lat_afterL :
  forall phi j,
    lat phi = lat (afterL phi j).
Proof.
  intros phi j.
  apply rel_extensionality.
  unfold lat.
  case x, y; try reflexivity.
Qed.

Lemma gamma_lat_rel_between :
  forall (gamma : Rel) (theta theta' : assignment),
    is_simpl_rel gamma ->
    theta |= gamma ->
      gamma = lat (rel_between theta' theta).
Proof.
  intros gamma theta theta';
  intros ga_simpl th_ga.
  apply rel_extensionality.
  unfold lat; unfold rel_between.
  case x, y.
  - split; intros H; apply th_ga; exact H.
  - split; intros H;
    apply (ga_simpl (X i) (X' i0)); exact H.
  - split; intros H;
    apply (ga_simpl (X' i) (X i0)); exact H.
  - split; intros H;
    apply (ga_simpl (X' i) (X' i0)); exact H.
Qed.

(* rel_between *)

Lemma assignments_model_rel_between :
  forall theta theta',
  (theta, theta') |= rel_between theta theta'.
Proof.
  intros theta theta'.
  unfold models; unfold two_assignments_model_rel.
  unfold rel_between.
  intros i j.
  repeat split; auto.
Qed.

(* classical logic *)

Definition classic := forall P : Prop, ~ ~ P -> P.

Lemma excluded_middle :
  classic -> forall P : Prop, P \/ ~P.
Proof.
  intros Classic P.
  apply Classic.
  intros npnp.
  apply npnp; right; intros p.
  apply npnp; left; exact p.
Qed.

Lemma contrapositive :
  classic ->
  forall P Q : Prop, (~ P -> ~ Q) -> Q -> P.
Proof.
  intros Classic.
  intros P Q npnq q.
  apply Classic.
  intros np.
  apply npnq. assumption. assumption.
Qed.

Lemma not_exists_iff_forall_not :
  forall T : Type,
  forall P : T -> Prop,
    ~ (exists x, P x) <-> forall x, ~ P x.
Proof.
  intros T P.
  split; intros H.
- intros x px.
  apply H.
  exists x; exact px.
- intros [x px].
  apply (H x); exact px.
Qed.

Lemma phi_ji_or_not :
  classic ->
  forall (phi : Rel) (i : nat),
    (exists j, phi (X j) (X' i)) \/ forall j, ~ phi (X j) (X' i).
Proof.
  intros Classic phi i.
  assert (H: ~(exists j, phi (X j) (X' i)) <-> forall j, ~phi (X j) (X' i)).
  { apply (not_exists_iff_forall_not _ (fun j => phi (X j) (X' i))). }
  rewrite <- H.
  apply excluded_middle.
  apply Classic.
Qed.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import List.

Lemma map_in :
 forall (A B : Set) (f : A -> B) (b : B) (xs : list A),
 In b (map f xs) -> ex (fun a : A => b = f a /\ In a xs).
intros A B f b xs; elim xs; simpl in |- *; auto.
intros H'; elim H'; auto.
intros a l H' H'0; elim H'0;
 [ intros H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
exists a; split; auto.
elim H'; [ intros a0 E; elim E; intros H'2 H'3; clear E H' | clear H' ]; auto.
exists a0; split; auto.
Qed.

Lemma map_app :
 forall (A B : Set) (f : A -> B) (l1 l2 : list A),
 map f (l1 ++ l2) = map f l1 ++ map f l2.
intros A B f l1; elim l1; simpl in |- *; auto with datatypes.
intros a l H' l2; rewrite H'; auto.
Qed.

Lemma map_rev :
 forall (A B : Set) (f : A -> B) (l : list A), map f (rev l) = rev (map f l).
intros A B f l; elim l; simpl in |- *; auto.
intros a l0 H'; rewrite <- H'; simpl in |- *; auto.
apply trans_equal with (y := map f (rev l0) ++ map f (a :: nil)); auto.
apply map_app; auto.
Qed.

Lemma rev_in : forall (A : Set) (a : A) (l : list A), In a (rev l) -> In a l.
intros A a l; elim l; simpl in |- *; auto.
intros a0 l0 H' H'0.
case (in_app_or _ _ _ H'0); simpl in |- *; intros H'1; auto.
elim H'1; auto.
intros H'2; elim H'2.
Qed.

Lemma in_rev : forall (A : Set) (a : A) (l : list A), In a l -> In a (rev l).
intros A a l H'.
apply rev_in with (A := A); auto.
rewrite (rev_involutive l); auto.
Qed.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import List.
Require Import DataRuntime.
Require Import NRA.
Require Import NRAEq.
Require Import NRAExt.
Require Import NRAExtEq.
Require Import NRARewrite.
Require Import String.

Section NRAExtRewrite.
  Local Open Scope nra_scope.
  Local Open Scope nraext_scope.
  Local Open Scope string.

  Context {fruntime:foreign_runtime}.

  (* Equivalences for the algebra operators are based on equivalence for
     all input x *)

  (* An attempt at proving some of the relational algebra's algebraic
     equivalences. *)

  (* Pulls equivalences from core algebra *)

  Lemma pull_nra_opt (p1 p2:nraext) :
    (nra_of_nraext p1) ≡ₐ (nra_of_nraext p2) ->
    p1 ≡ₓ p2.
  Proof.
    unfold nra_eq, nraext_eq; intros.
    unfold nraext_eval.
    rewrite H; trivial.
  Qed.

  (* P1 ∧ P2 == P2 ∧ P1 *)

  Lemma eand_comm (p1 p2: nraext) :
    p2 ∧ p1 ≡ₓ p1 ∧ p2.
  Proof.
    apply pull_nra_opt.
    apply and_comm.
  Qed.

  (* (P1 ⋃ P2) ⋃ P3 == P1 ⋃ (P2 ⋃ P3) *)

  Lemma eunion_assoc (p1 p2 p3: nraext):
    (p1 ⋃ p2) ⋃ p3 ≡ₓ p1 ⋃ (p2 ⋃ p3).
  Proof.
    apply pull_nra_opt.
    apply union_assoc.
  Qed.

  (* σ⟨ P ⟩(P1 ⋃ P2) == σ⟨ P ⟩(P1) ⋃ σ⟨ P ⟩(P2) *)

  Lemma eunion_select_distr (p p1 p2: nraext) :
    σ⟨ p ⟩(p1 ⋃ p2) ≡ₓ σ⟨ p ⟩(p1) ⋃ σ⟨ p ⟩(p2).
  Proof.
    apply pull_nra_opt.
    apply union_select_distr.
  Qed.

  (* χ⟨ P1 ⟩( { P2 } ) ≡ { P1 ◯ P2 } *)

  Lemma emap_singleton (p1 p2:nraext) :
    χ⟨ p1 ⟩( ‵{| p2 |} ) ≡ₓ ‵{| p1 ◯ p2 |}.
  Proof.
    apply pull_nra_opt.
    apply map_singleton.
  Qed.

  (* [ a : ID ] ◯ P ≡ [ a : P ] *)

  Lemma ecompose_rec_id s p:
    ‵[| (s, ID) |] ◯ p ≡ₓ ‵[| (s, p) |].
  Proof.
    apply pull_nra_opt.
    apply compose_rec_id.
  Qed.

  Lemma eflatten_map_coll p1 p2 :
    ♯flatten(χ⟨ ‵{| p1 |} ⟩( p2 )) ≡ₓ χ⟨ p1 ⟩( p2 ).
  Proof.
    apply pull_nra_opt.
    apply flatten_map_coll.
  Qed.

  (* Specific to extended nraebra *)

  (*
     a1, a2, a3 are distinct field names
     ===================================================================
     μ[s1][s2]( { [ s3 : P1; s1 : { P2 } ] } ) ≡ₓ { [ s3 : P1; s2 : P2 ] }
   *)

  Lemma eunnest_singleton s1 s2 s3 p1 p2 :
    s1 <> s2 /\ s2 <> s3 /\ s3 <> s1 ->
    μ[s1 ][ s2 ]( ‵{|‵[| (s3, p1)|] ⊕ ‵[| (s1, ‵{|p2|})|]|})
     ≡ₓ ‵{|‵[| (s3, p1)|] ⊕ ‵[| (s2, p2)|]|}.
  Proof.
    intros.
    apply pull_nra_opt.
    apply unnest_singleton; assumption.
  Qed.

  (* χ⟨ { ID } ⟩( P ) ≡ { { P } }*)

  Lemma emap_into_singleton p :
    χ⟨ ‵{| ID |} ⟩(‵{| p |}) ≡ₓ ‵{|‵{| p |}|}.
  Proof.
    apply pull_nra_opt.
    apply map_into_singleton.
  Qed.

  (* ♯flatten( χ⟨ { { P1 } } ⟩( P2 ) ) ≡ χ⟨ { P1 } ⟩( P2 ) *)

  Lemma eflatten_over_map_into_singleton p1 p2 :
    ♯flatten( χ⟨ ‵{|‵{| p1 |}|} ⟩( p2 ) ) ≡ₓ χ⟨ ‵{| p1 |} ⟩( p2 ).
  Proof.
    apply pull_nra_opt.
    apply flatten_over_map_into_singleton.
  Qed.

  (* Join intro *)

  Lemma join_intro p1 p2 p3 :
    σ⟨ p1 ⟩( p2 × p3 ) ≡ₓ ⋈⟨ p1 ⟩(p2, p3).
  Proof.
    apply pull_nra_opt.
    simpl; unfold join.
    unfold nra_eq; intros ? ? _.
    reflexivity.
  Qed.

  (*****************)
  (* Rules Section *)
  (*****************)

  (* Composite rewrites, useful for rules optimization *)

  Lemma emap_singleton_rec s1 s2 :
    χ⟨‵[| (s1, ID) |] ⟩( ‵{|(ID) · s2 |}) ≡ₓ ‵{|‵[| (s1, (ID) · s2) |] |}.
  Proof.
    apply pull_nra_opt.
    apply map_singleton_rec.
  Qed.

  (* χ⟨ ID.a ⟩( { P } ) ≡ { P.a } *)

  Lemma emap_dot_singleton s p :
    χ⟨ (ID)·s ⟩( ‵{| p |} ) ≡ₓ ‵{| p·s |}.
  Proof.
    apply pull_nra_opt.
    apply map_dot_singleton.
  Qed.

  (*
     μ[a1][PDATA]( { [ PBIND : p1; a1 : {p2} ] } ) ≡ₓ { [ PBIND : p1; PDATA : p2 ] }
   *)

  Lemma eunnest_singleton_context p1 p2 :
    μ["a1"]["PDATA"]( ‵{|‵[| ("PBIND", p1)|] ⊕ ‵[| ("a1", ‵{|p2|})|]|})
     ≡ₓ ‵{|‵[| ("PBIND", p1)|] ⊕ ‵[| ("PDATA", p2)|]|}.
  Proof.
    apply eunnest_singleton.
    split; try congruence.
    split; try congruence.
  Qed.

  (* χ⟨ [ PBIND : ID.PBIND; PDATA : ID.PDATA.WORLD ].PDATA ⟩({ p })
     ≡ { [ PBIND : p.PBIND; PDATA: p.PDATA.WORLD ].PDATA } *)

  Lemma esubstitute_in_bindings (p:nraext) :
    χ⟨ (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PDATA"·"WORLD") |])·"PDATA" ⟩( ‵{| p |} )
     ≡ₓ ‵{|(‵[| ("PBIND", p·"PBIND") |] ⊕ ‵[| ("PDATA", p·"PDATA"·"WORLD") |])·"PDATA" |}.
  Proof.
    apply pull_nra_opt.
    apply substitute_in_bindings.
  Qed.

  (* [ PBIND : ID.PBIND; PDATA : ID.PBIND ].PDATA ≡ₐ ID.PBIND *)

  Lemma edot_from_duplicate_bind_r :
    (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PBIND") |])·"PDATA" ≡ₓ ID·"PBIND".
  Proof.
    apply pull_nra_opt.
    apply dot_from_duplicate_bind_r.
  Qed.

  (* [ PBIND : ID.PBIND; PDATA : ID.PBIND ].PDATA ≡ₐ ID.PBIND *)

  Lemma edot_from_duplicate_bind_l :
    (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PBIND") |])·"PBIND" ≡ₓ ID·"PBIND".
  Proof.
    apply pull_nra_opt.
    apply dot_from_duplicate_bind_l.
  Qed.

  (* [ PBIND : ID·PBIND; PDATA : ID·PBIND·WORLD ]·PDATA ≡ ID·PBIND·WORLD *)

  Lemma edot_dot_from_duplicate_bind :
    (‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PBIND"·"WORLD") |])·"PDATA"
     ≡ₓ ID·"PBIND"·"WORLD".
  Proof.
    apply pull_nra_opt.
    apply dot_dot_from_duplicate_bind.
  Qed.

  (*   [ PBIND : ID.PBIND;
         a1 : χ⟨ [ PBIND : ID.PBIND; PDATA : ID.PDATA.e ].PDATA ⟩ (
                 { [ PBIND : ID.PBIND; PDATA : ID.PBIND ] }
                 ) ]
     ≡ₐ [ PBIND : ID.PBIND; a1 : { ID.PBIND.e } ].
   *)

  Lemma ebig_nested_bind_simplify_one :
    ‵[| ("PBIND", ID·"PBIND") |]
     ⊕ ‵[| ("a1",
            χ⟨(‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID·"PDATA"·"e") |])·"PDATA"
             ⟩( ‵{|‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("PDATA", ID· "PBIND") |] |}))|]
     ≡ₓ ‵[| ("PBIND", ID·"PBIND") |] ⊕ ‵[| ("a1", ‵{| ID·"PBIND"·"e" |}) |].
  Proof.
    apply pull_nra_opt.
    apply big_nested_bind_simplify_one.
  Qed.

End NRAExtRewrite.


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents :

            Precategory HSET of hSets

	    HSET is a category

************************************************************)

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.
Require Import Foundations.Proof_of_Extensionality.funextfun.

Require Import RezkCompletion.auxiliary_lemmas_HoTT.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.HLevel_n_is_of_hlevel_Sn.

Require Import RezkCompletion.pathnotations.
Import RezkCompletion.pathnotations.PathNotations.

Local Notation "a --> b" := (precategory_morphisms a b)(at level 50).

(** * Precategory of hSets *)

Lemma isaset_set_fun_space (A B : hSet) : isaset (A -> B).
Proof.
  change isaset with (isofhlevel 2).
  apply impred.
  apply (fun _ => (pr2 B)).
Qed.

Definition hset_fun_space (A B : hSet) : hSet :=
  hSetpair _ (isaset_set_fun_space A B).

Definition hset_precategory_ob_mor : precategory_ob_mor :=
  tpair (fun ob : UU => ob -> ob -> hSet) hSet
        (fun A B : hSet => hset_fun_space A B).

Definition hset_precategory_data : precategory_data :=
  precategory_data_pair hset_precategory_ob_mor (fun (A:hSet) (x : A) => x)
     (fun (A B C : hSet) (f : A -> B) (g : B -> C) (x : A) => g (f x)).

Lemma is_precategory_hset_precategory_data :
  is_precategory hset_precategory_data.
Proof.
  repeat split; simpl.
  intros a b f.
  apply funextfunax; intros;
  apply idpath.
  intros;
  apply funextfunax; intros;
  apply idpath.
Qed.

Definition hset_precategory : precategory :=
  tpair _ _ is_precategory_hset_precategory_data.

Notation HSET := hset_precategory.

(*
  Canonical Structure hset_precategory. :-)
*)

(** * The precategory of hSets is a category. *)

(** ** Equivalence between isomorphisms and weak equivalences
       of two hsets.
*)

(** Given an iso, we construct a weak equivalence.
   This is basically unpacking and packing again.
*)

Lemma hset_iso_is_equiv (A B : ob HSET)
   (f : iso A B) : isweq (pr1 f).
Proof.

  destruct f as [f fax]; simpl in *.
  apply (gradth _ (pr1 fax)).
  destruct fax as [g [eta eps]]; simpl in *.
  unfold compose, identity in *;
  simpl in *.
  intro x.
  apply (toforallpaths _ _ _ eta).
  destruct fax as [g [eta eps]]; simpl in *.
  unfold compose, identity in *;
  simpl in *.
  intro x.
  apply (toforallpaths _ _ _ eps).
Defined.

Lemma hset_iso_equiv (A B : ob HSET) : iso A B -> weq (pr1 A) (pr1 B).
Proof.
  intro f.
  exists (pr1 f).
  apply hset_iso_is_equiv.
Defined.

(** Given a weak equivalence, we construct an iso.
    Again mostly unwrapping and packing.
*)

Lemma hset_equiv_is_iso (A B : hSet)
      (f : weq (pr1 A) (pr1 B)) :
           is_isomorphism (C:=HSET) (pr1 f).
Proof.
  exists (invmap f).
  split; simpl.
  apply funextfunax; intro x; simpl in *.
  unfold compose, identity; simpl.
  apply homotinvweqweq.
  apply funextfunax; intro x; simpl in *.
  unfold compose, identity; simpl.
  apply homotweqinvweq.
Defined.

Lemma hset_equiv_iso (A B : ob HSET) : weq (pr1 A) (pr1 B) -> iso A B.
Proof.
  intro f.
  simpl in *.
  exists (pr1 f).
  apply hset_equiv_is_iso.
Defined.

(** Both maps defined above are weak equivalences. *)

Lemma hset_iso_equiv_is_equiv (A B : ob HSET) : isweq (hset_iso_equiv A B).
Proof.
  apply (gradth _ (hset_equiv_iso A B)).
  intro; apply eq_iso; reflexivity.
  intro; apply total2_paths_hProp.
    intro; apply isapropisweq.
    reflexivity.
Qed.

Definition hset_iso_equiv_weq (A B : ob HSET) : weq (iso A B) (weq (pr1 A) (pr1 B)).
Proof.
  exists (hset_iso_equiv A B).
  apply hset_iso_equiv_is_equiv.
Defined.

Lemma hset_equiv_iso_is_equiv (A B : ob HSET) : isweq (hset_equiv_iso A B).
Proof.
  apply (gradth _ (hset_iso_equiv A B)).
  intro f.
  apply total2_paths_hProp.
    apply isapropisweq.
    reflexivity.
  intro; apply eq_iso.
  reflexivity.
Qed.

Definition hset_equiv_iso_weq (A B : ob HSET) :
  weq (weq (pr1 A) (pr1 B))(iso A B).
Proof.
  exists (hset_equiv_iso A B).
  apply hset_equiv_iso_is_equiv.
Defined.

(** ** HSET is a category. *)

Definition univalenceweq (X X' : UU) : weq (X == X') (weq X X') :=
   tpair _ _ (univalenceaxiom X X').

Definition hset_id_iso_weq (A B : ob HSET) :
  weq (A == B) (iso A B) :=
  weqcomp (UA_for_HLevels 2 A B) (hset_equiv_iso_weq A B).

(** The map [precat_paths_to_iso]
    for which we need to show [isweq] is actually
    equal to the carrier of the weak equivalence we
    constructed above.
    We use this fact to show that that [precat_paths_to_iso]
    is an equivalence.
*)

Lemma hset_id_iso_weq_is (A B : ob HSET):
    @idtoiso _ A B == pr1 (hset_id_iso_weq A B).
Proof.
  apply funextfunax.
  intro p; elim p.
  apply eq_iso; simpl.
  apply funextfun;
  intro x;
  destruct A.
  apply idpath.
Defined.

Lemma is_weq_precat_paths_to_iso_hset (A B : ob HSET):
   isweq (@idtoiso _ A B).
Proof.
  rewrite hset_id_iso_weq_is.
  apply (pr2 (hset_id_iso_weq A B)).
Defined.

Lemma is_category_HSET : is_category HSET.
Proof.
  unfold is_category.
  apply is_weq_precat_paths_to_iso_hset.
Defined.


Require Import Coq.Classes.Morphisms Coq.Setoids.Setoid.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Util.GlobalSettings.
Require Import Crypto.Util.Notations.

Definition compose {A B} {C : B -> Type} (g : forall b : B, C b) (f : A -> B) (x : A)
  := g (f x).
Global Arguments compose {A B C} g f x / .

Infix "'o'" := compose : function_scope.
Infix "∘" := compose : function_scope.

Typeclasses Opaque compose.

Global Instance Proper_compose {A B C}
      {RA RB RC}
  : Proper ((RB ==> RC) ==> (RA ==> RB) ==> RA ==> RC) (@compose A B (fun _ => C)).
Proof. cbv in *; eauto. Qed.

Global Instance Proper_compose_app {A B C} (g : B -> C) (f : A -> B)
      {RA RB RC}
      {Hg : Proper (RB ==> RC) g}
      {Hf : Proper (RA ==> RB) f}
  : Proper (RA ==> RC) (g ∘ f).
Proof. cbv in *; eauto. Qed.

Ltac Proper_compose_hint :=
  lazymatch goal with
  | [ |- Proper _ (fun x => ?g (?f x)) ]
    => simple eapply (@Proper_compose_app _ _ _ g f)
  end.

(*Global Hint Extern 2 (Proper _ (fun x => ?g (?f x))) => simple eapply (@Proper_compose_app _ _ _ g f) : typeclass_instances.*)