Set Implicit Arguments.

Require Import StringSet.
Import StringSet.
Require Import StringSetFacts.

Section TopSection.

  Require Import GetLocalVars.
  Require Import FreeVars.

  Lemma get_local_vars_cardinal : forall s1 s2 argvars retvar, Subset (free_vars s1) (free_vars s2) -> length (get_local_vars s1 argvars retvar) <= length (get_local_vars s2 argvars retvar).
    intros.
    unfold get_local_vars.
    repeat rewrite <- StringSet.cardinal_1.
    eapply subset_cardinal.
    eapply diff_s_m.
    eapply add_s_m; eauto.
    unfold Basics.flip.
    eapply subset_refl.
  Qed.

  Require Import String.
  Require Import List.
  Require Import GeneralTactics2.
  Require Import SetoidListFacts.

  Lemma get_local_vars_subset : forall stmt argvars retvar, Subset (free_vars stmt) (of_list (argvars ++ get_local_vars stmt argvars retvar)).
    unfold get_local_vars.
    unfold Subset; intros.
    eapply of_list_spec.
    destruct (List.In_dec string_dec a argvars).
    eapply in_or_app; eauto.
    eapply in_or_app; right.
    eapply InA_eq_In_iff.
    eapply elements_iff.
    eapply diff_iff.
    split.
    eapply add_iff; eauto.
    not_not.
    eapply of_list_spec; eauto.
  Qed.

End TopSection.


(** ** Essential Incompleteness of Q *)

From Undecidability.Shared Require Import Dec.
From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.

From FOL Require Import FullSyntax Arithmetics.

From FOL.Incompleteness Require Import Axiomatisations utils fol_utils qdec bin_qdec sigma1 epf epf_mu formal_systems abstract_incompleteness ctq.
From FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia String List.
Import ListNotations.

(* * Incompleteness of first-order logic *)

(* first-order logic with an enumerable theory is a formal system *)
Section fol_fs.
  Existing Instance PA_funcs_signature.
  Existing Instance PA_preds_signature.
  Hypothesis (p : peirce).

  Definition fol_fs (T : theory) (Tenum : enumerable T) (Tconsis : ~T ⊢T ⊥) : FS form (fun φ => ¬φ).
  Proof.
    apply mkFS with (fprv := fun φ => T ⊢T φ).
    - apply enumerable_semi_decidable.
      + apply form_discrete.
      + unshelve eapply tprv_enumerable.
        * apply enumerable_PA_funcs.
        * apply enumerable_PA_preds.
        * assumption.
    - intros φ [T1 [HT1 H1]] [T2 [HT2 H2]]. apply Tconsis. exists (T1 ++ T2). split.
      + intros ψ [?|?]%in_app_or; auto.
      + eapply IE.
        * eapply Weak; first apply H2.
          apply incl_appr, incl_refl.
        * eapply Weak; first apply H1.
          apply incl_appl, incl_refl.
  Defined.
End fol_fs.

Section fol.
  Existing Instance PA_funcs_signature.
  Existing Instance PA_preds_signature.

  (* ** Q is essentially incomplete and essentially undecidable *)

  (* Any theory that strongly separates two recursively inseparable predicates is incompelte *)
  Section incomplete_strong_repr.
    Hypothesis (p : peirce).

    Variable theta : nat -> nat -\ bool.
    Hypothesis theta_universal : is_universal theta.

    Variable T : theory.
    Hypothesis Tenum : enumerable T.
    Hypothesis Tconsis : ~T ⊢T ⊥.

    Variable T' : theory.
    Hypothesis T'_T : T' ⊑ T.
    Hypothesis T'enum : enumerable T'.

    Variable r : nat -> form.
    Hypothesis Hrepr :
      (forall c, theta c c ▷ true -> T' ⊢T r c) /\
      (forall c, theta c c ▷ false -> T' ⊢T ¬r c).

    Lemma fol_undecidable_strong_repr : ~decidable (fun s => T ⊢T s).
    Proof.
      assert (~T' ⊢T ⊥) as T'consis.
      { contradict Tconsis. now eapply WeakT. }
      eapply (insep_essential_undecidability) with (theta := theta) (fs := fol_fs Tenum Tconsis) (fs' := fol_fs T'enum T'consis).
      - assumption.
      - unfold extension. cbn. intros φ Hφ. now eapply WeakT.
      - exact Hrepr.
    Qed.

    Lemma fol_incomplete_strong_repr : exists n, ~T ⊢T r n /\ ~T ⊢T ¬r n.
    Proof.
      assert (~T' ⊢T ⊥) as T'consis.
      { contradict Tconsis. now eapply WeakT. }
      apply (insep_essential_incompleteness) with (theta := theta) (fs := fol_fs Tenum Tconsis) (fs' := fol_fs T'enum T'consis).
      - assumption.
      - unfold extension. cbn. intros φ Hφ. now eapply WeakT.
      - assumption.
    Qed.

  End incomplete_strong_repr.

  (* Q is essentially incomplete and essentially undecidable *)
  Section Q_incomplete.
    (* Hypothesis mu_universal : is_universal theta_mu. *)

    Hypothesis (p : peirce).
    Hypothesis ctq : @CTQ p.

    Variable T : theory.
    Hypothesis T_Q : list_theory Qeq ⊑ T.
    Hypothesis Tenum : enumerable T.
    Hypothesis Tconsis : ~@tprv _ _ _ p T ⊥.

    Theorem Q_undecidable : ~decidable (@tprv _ _ _ p T).
    Proof.
      assert (exists theta : nat -> nat -\ bool, is_universal theta) as [theta theta_universal].
      { apply epf_nat_bool, ctq_epfn, ctq. }
      assert (forall c, theta c c ▷ true -> theta c c ▷ false -> False) as Hdisj.
      { intros c Ht Hf. enough (true = false) by discriminate. eapply part_functional; eassumption. }

      edestruct (ctq_strong_sepr ctq Hdisj) as (ψ & Hb & HΣ & Hψ1 & Hψ2).
      1-2: apply theta_self_return_semi_decidable.
      eapply (@fol_undecidable_strong_repr p theta theta_universal T Tenum Tconsis (list_theory Qeq) T_Q (list_theory_enumerable Qeq)).
      instantiate (1 := fun c => ψ[(num c)..]).
      split; intros c H.
      - exists Qeq. eauto.
      - exists Qeq. eauto.
    Qed.

    Theorem Q_incomplete : exists φ, bounded 0 φ /\ Σ1 φ /\ ~@tprv _ _ _ p T φ /\ ~@tprv _ _ _ p T (¬φ).
    Proof.
      assert (exists theta : nat -> nat -\ bool, is_universal theta) as [theta theta_universal].
      { apply epf_nat_bool, ctq_epfn, ctq. }
      assert (forall c, theta c c ▷ true -> theta c c ▷ false -> False) as Hdisj.
      { intros c Ht Hf. enough (true = false) by discriminate. eapply part_functional; eassumption. }

      edestruct (ctq_strong_sepr ctq Hdisj) as (ψ & Hb & HΣ & Hψ1 & Hψ2).
      1-2: apply theta_self_return_semi_decidable.
      edestruct (@fol_incomplete_strong_repr p theta theta_universal T Tenum Tconsis (list_theory Qeq) T_Q (list_theory_enumerable Qeq)).
      { instantiate (1 := fun c => ψ[(num c)..]).
        split; intros c H.
        - exists Qeq. eauto.
        - exists Qeq. eauto. }
      cbn in H. exists ψ[(num x)..].
      repeat apply conj.
      - eapply subst_bounded_max; last eassumption. intros [|n] Hn; last lia. apply num_bound.
      - now apply Σ1_subst.
      - apply H.
      - apply H.
    Qed.

  End Q_incomplete.

End fol.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


(* Copyright (c) 2022, choukh <choukyuhei@gmail.com> *)

Require Import GOO.Ordinal.Ord.
Require Import GOO.Ordinal.WellFormed.
Require Import GOO.Ordinal.Operation.
Require Import GOO.Ordinal.Recursion.
Require Import GOO.Ordinal.Arithmetic.
Require Import GOO.Ordinal.Tetration.
Require Import GOO.Ordinal.Iteration.

Local Open Scope 序数域.
Local Open Scope 序数算术域.

Definition ε := (幂运算 ω)′.

Lemma ε为序数嵌入 : 序数嵌入 ε.
Proof. apply 不动点枚举为序数嵌入. apply 幂运算为序数嵌入. auto. Qed.

Lemma ε数为不动点 : ∀ α, ω ^ (ε α) ≃ ε α.
Proof. apply 不动点枚举枚举之. apply 幂运算为序数嵌入. auto. Qed.

Theorem ε_零 : ε [0] ≃ ω ^^ᴸ ω.
Proof with auto.
  split; constructor.
  - induction n; simpl.
    + constructor.
    + rewrite <- 左迭代在ω后继处不递增, 左迭代后继次... apply 幂运算_弱保序_右...
  - induction n; simpl.
    + constructor. intros n. apply 弱序_极限_介入 with 2. simpl. rewrite 零次幂, 一次幂...
    + rewrite <- ε数为不动点. apply 幂运算_弱保序_右...
Qed.

Theorem ε_后继_ω塔 : ∀ α, ε α⁺ ≃ (ω ^^ᵀ ω) (ε α)⁺.
Proof.
  intros. unfold ε, ω. rewrite 不动点枚举_后继, 顶迭代极限次.
  rewrite 无穷迭代弱等于无穷递归. unfold ω. reflexivity.
Qed.

Theorem ε_极限 : ∀ f, ε (lim f) ≃ lim (λ n, ε (f n)).
Proof. easy. Qed.

Lemma 以ω为底的幂运算在零处强放大 : 零处强放大 (幂运算 ω).
Proof. rewrite 零次幂. simpl. easy. Qed.

Lemma 以ω为底的幂运算在后继处强放大 : 良构后继处强放大 (幂运算 ω).
Proof with auto.
  intros α WFα. destruct (良构对零排中 α)...
  - rewrite H. apply 小于即后继小于等于. rewrite 一次幂.
    apply 小于即后继小于等于. apply 有限序数后继...
  - rewrite 后继次幂, <- 加一. apply 强弱传递 with (α * ω).
    + apply 弱强传递 with (α * [2]).
      * rewrite 乘二. apply 加法_弱保序_右. simpl. apply 小于即后继小于等于...
      * apply 乘法_强保序_右...
    + apply 乘法_弱保序_左. apply 幂运算_弱放大_左...
Qed.

Theorem ε保良构 : 保良构 ε.
Proof with auto.
  intros. apply 不动点枚举保良构...
  - apply 幂运算为序数嵌入...
  - apply 以ω为底的幂运算在零处强放大.
  - apply 以ω为底的幂运算在后继处强放大.
  - apply 幂运算保良构...
Qed.

Lemma ε在零处强放大 : 零处强放大 ε.
Proof. apply 不动点枚举在零处强放大. apply 以ω为底的幂运算在零处强放大. Qed.

Lemma ε在良构后继处强放大 : 良构后继处强放大 ε.
Proof.
  apply 不动点枚举在良构后继处强放大. apply 幂运算为序数嵌入. auto.
  apply 以ω为底的幂运算在后继处强放大.
Qed.

Lemma ε数大于一 : ∀ α, [1] < ε α.
Proof.
  intros. apply 强弱传递 with (ε [0]).
  - apply 小于即后继小于等于. rewrite ε_零. apply 弱序_极限_介入 with 0. simpl.
    apply 弱序_极限_介入 with 2. reflexivity.
  - apply ε为序数嵌入. constructor.
Qed.
Local Hint Immediate ε数大于一 : core.

(* ε'顶ω塔 := 以ε数的后继为顶的ω塔 *)

Fact ε'顶ω塔0层 : ∀ α, (ω ^^ᵀ [0]) (ε α)⁺ ≃ (ε α)⁺.
Proof. easy. Qed.

Fact ε'顶ω塔1层 : ∀ α, (ω ^^ᵀ [1]) (ε α)⁺ ≃ ε α * ω.
Proof.
  intros. rewrite 顶迭代一次, 后继次幂.
  apply 乘法_改写_左. apply ε数为不动点.
Qed.

Fact ε'顶ω塔2层 : ∀ α, (ω ^^ᵀ [2]) (ε α)⁺ ≃ ε α ^ ω.
Proof.
  intros. simpl. rewrite 顶迭代后继次, (幂运算_改写_右 (ε α * ω)), 指数积运算律.
  apply 幂运算_改写_左, ε数为不动点. auto. apply ε'顶ω塔1层.
Qed.

Fact ε'顶ω塔3层 : ∀ α, (ω ^^ᵀ [3]) (ε α)⁺ ≃ ε α ^ (ε α ^ ω).
Proof with auto.
  intros. simpl. rewrite 顶迭代后继次, (幂运算_改写_右 (ε α ^ ω))... 2: apply ε'顶ω塔2层.
  rewrite (幂运算_改写_右 (ε α * ε α ^ ω))...
  rewrite 指数积运算律. apply 幂运算_改写_左. apply ε数为不动点.
  rewrite (幂运算_改写_右 ([1] + ω)) at 1...
  rewrite 指数和运算律. apply 乘法_改写_左. rewrite 一次幂. reflexivity.
  rewrite 一加ω弱等于ω. reflexivity.
Qed.

Lemma ε'顶ω塔n'层等于ω顶ε塔n层 : ∀ α n, 良构 α → (ω ^^ᵀ [S (S n)]) (ε α)⁺ ≃ (ε α ^^ᵀ [S n]) ω.
Proof with auto.
  intros * WF. induction n.
  - rewrite ε'顶ω塔2层, 顶迭代一次. reflexivity.
  - simpl. do 4 rewrite 顶迭代后继次.
    simpl in IHn. do 2 rewrite 顶迭代后继次 in IHn.
    rewrite (@幂运算_改写_右 (ε α))... 2: symmetry; apply IHn... clear IHn.
    rewrite (@幂运算_改写_左 (ε α)). 2: symmetry; apply ε数为不动点.
    rewrite <- 指数积运算律. apply 幂运算_改写_右...
    rewrite (@乘法_改写_左 (ε α)). 2: symmetry; apply ε数为不动点.
    rewrite <- 指数和运算律. apply 幂运算_改写_右...
    rewrite (@加法_改写_左 (ε α)). 2: symmetry; apply ε数为不动点.
    rewrite ω幂对加法的吸收律. reflexivity.
    + induction n. simpl. apply ε保良构...
      simpl. rewrite 顶迭代后继次. apply 幂运算保良构...
    + induction n. rewrite 顶迭代零次... simpl. rewrite 顶迭代后继次...
      apply 强弱传递 with ((ω ^^ᵀ [n]) (ε α)⁺)... apply 幂运算_弱放大_左...
Qed.

Lemma ε'顶ω塔极限等于ω顶ε塔极限 : ∀ α, 良构 α → (ω ^^ᵀ ω) (ε α)⁺ ≃ (ε α ^^ᵀ ω) ω.
Proof with auto.
  intros. unfold ω at 2 3. rewrite 顶迭代极限次, 顶迭代极限次.
  rewrite 序列极限与起始无关, 序列极限与起始无关.
  2: { rewrite 顶迭代一次. simpl. rewrite 顶迭代后继次, 顶迭代一次.
    apply 幂运算_弱保序_右... apply 幂运算_弱放大_左... }
  2: { rewrite 顶迭代零次, 顶迭代一次. apply 幂运算_弱放大_左... }
  rewrite (序列极限与起始无关 (λ n, (ε α ^^ᵀ [n]) ω)).
  2: { rewrite 顶迭代零次, 顶迭代一次. apply 幂运算_弱放大_左... }
  split; constructor; intros n.
  - rewrite ε'顶ω塔n'层等于ω顶ε塔n层... apply 弱序_极限_介入 with n. reflexivity.
  - rewrite <- ε'顶ω塔n'层等于ω顶ε塔n层... apply 弱序_极限_介入 with n. reflexivity.
Qed.

Theorem ε_后继_ε塔 : ∀ α, 良构 α → ε α⁺ ≃ (ε α ^^ᴸ ω).
Proof with auto.
  intros. rewrite ε_后继_ω塔, ε'顶ω塔极限等于ω顶ε塔极限, 无穷顶迭代等于左迭代... reflexivity.
  apply 小于即后继小于等于. rewrite <- ε数为不动点... apply 小于即后继小于等于. apply 幂运算_强放大_右...
Qed.

Definition ζ := ε′.

Fact ζ为序数嵌入 : 序数嵌入 ζ.
Proof. apply 不动点枚举为序数嵌入. apply ε为序数嵌入. Qed.

Fact ζ_零 : ζ [0] = Itω ε [0].
Proof. easy. Qed.

Fact ζ_后继 : ∀ α, ζ α⁺ = Itω ε (ζ α)⁺.
Proof. easy. Qed.

Fact ζ_极限 : ∀ f, ζ (lim f) ≃ lim (λ n, ζ (f n)).
Proof. easy. Qed.

Fact ζ保良构 : 保良构 ζ.
Proof with auto.
  intros. apply 不动点枚举保良构_递进...
  - apply 幂运算为序数嵌入...
  - rewrite 零次幂. simpl...
  - apply 以ω为底的幂运算在后继处强放大.
  - apply ε保良构.
Qed.

Definition η := ζ′.

Fact η为序数嵌入 : 序数嵌入 η.
Proof. apply 不动点枚举为序数嵌入. apply ζ为序数嵌入. Qed.

Fact η_零 : η [0] = Itω ζ [0].
Proof. easy. Qed.

Fact η_后继 : ∀ α, η α⁺ = Itω ζ (η α)⁺.
Proof. easy. Qed.

Fact η_极限 : ∀ f, η (lim f) ≃ lim (λ n, η (f n)).
Proof. easy. Qed.

Fact η保良构 : 保良构 η.
Proof with auto.
  intros. apply 不动点枚举保良构_递进...
  - apply ε为序数嵌入.
  - apply ε在零处强放大.
  - apply ε在良构后继处强放大.
  - apply ζ保良构.
Qed.


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

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

Print Assumptions mul.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Require Import Tactics.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.

Require Import Axioms.

Section object.

Variable obj : Type.

Fixpoint dots (i : nat) (n : nat) (s : sub) : @sub obj :=
  match n with
  | 0 => s
  | S n' =>
      dots i n' (dot (var (i + n')) s)
  end.

Fixpoint unlift i : @sub obj :=
  match i with
  | 0 => id
  | S i' => dot arb (unlift i')
  end.

Fixpoint dotsgen (f : nat -> term obj) (n : nat) (s : sub) : sub :=
  match n with
  | 0 => s
  | S n' =>
      dotsgen f n' (dot (f n') s)
  end.

Lemma dotsgen_succ :
  forall f j s,
    dotsgen f (S j) s = dot (f 0) (dotsgen (fun i => f (S i)) j s).
Proof.
intros f j.
revert f.
induct j.

(* 0 *)
{
intros f s.
cbn.
auto.
}

(* S *)
{
intros j IH f s.
cbn.
rewrite <- IH.
cbn.
reflexivity.
}
Qed.

Lemma dots_dotsgen :
  forall i n s,
    dots i n s = dotsgen (fun j => var (i+j)) n s.
Proof.
intros i n.
revert i.
induct n.

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

(* S *)
{
intros n IH i s.
cbn.
apply IH.
}
Qed.

Lemma unlift_dotsgen :
  forall k,
    unlift k = dotsgen (fun _ => arb) k id.
Proof.
intros k.
induct k.

(* 0 *)
{
cbn.
reflexivity.
}

(* S *)
{
intros k IH.
cbn [unlift].
rewrite -> dotsgen_succ.
f_equal.
apply IH.
}
Qed.

(* Dotsgen lemmas *)

Lemma split_dotsgen :
  forall f j k s,
    dotsgen f (j + k) s = dotsgen f j (dotsgen (fun i => f (j+i)) k s).
Proof.
intros f j k s.
revert f.
induct j.

(* 0 *)
{
intro f.
cbn.
auto.
}

(* S *)
{
intros j IH f.
cbn [Nat.add].
rewrite -> !dotsgen_succ.
f_equal.
apply IH.
}
Qed.

Lemma dotsgen_equal :
  forall f f' j j' s s',
    j = j'
    -> (forall i, i < j -> f i = f' i)
    -> s = s'
    -> dotsgen f j s = dotsgen f' j' s'.
Proof.
intros f f' j j' s s' Heqj Heq Heqs.
subst j' s'.
revert f f' Heq.
induct j.

(* 0 *)
{
intros f f' _.
reflexivity.
}

(* S *)
{
intros j IH f f' Heq.
rewrite -> !dotsgen_succ.
f_equal.
  {
  apply Heq.
  omega.
  }

  {
  apply IH.
  intros i Hi.
  apply Heq.
  omega.
  }
}
Qed.

Lemma dotsgen_eqsub :
  forall f f' j j' s s',
    j = j'
    -> (forall i, i < j -> f i = f' i)
    -> eqsub s s'
    -> eqsub (dotsgen f j s) (dotsgen f' j' s').
Proof.
intros f f' j j' s s' Heqj Heq Heqs.
subst j'.
revert f f' Heq.
induct j.

(* 0 *)
{
intros f f' _.
cbn.
auto.
}

(* S *)
{
intros j IH f f' Heq.
rewrite -> !dotsgen_succ.
rewrite -> Heq; [| omega].
apply eqsub_dotv.
apply IH.
intros i Hi.
apply Heq.
omega.
}
Qed.

Lemma compose_sh_dotsgen_le :
  forall j f k s,
    j <= k
    -> compose (sh j) (dotsgen f k s) = dotsgen (fun i => f (j+i)) (k-j) s.
Proof.
intros j f k s Hjk.
revert f k Hjk.
induct j.

(* 0 *)
{
intros f k _.
rewrite -> compose_id_left.
f_equal.
omega.
}

(* S *)
{
intros j IH f k Hjk.
destruct k as [| k]; [omega |].
rewrite -> dotsgen_succ.
simpsub.
rewrite -> IH; [| omega].
auto.
}
Qed.

Lemma compose_sh_dotsgen_ge :
  forall j f k s,
    j >= k
    -> compose (sh j) (dotsgen f k s) = compose (sh (j-k)) s.
Proof.
intros j f k s Hjk.
revert j f Hjk.
induct k.

(* 0 *)
{
intros j f _.
cbn [dotsgen].
do 2 f_equal.
omega.
}

(* S *)
{
intros k IH j f Hjk.
rewrite -> dotsgen_succ.
destruct j as [| j]; [omega |].
simpsub.
rewrite -> IH; [| omega].
auto.
}
Qed.

Lemma compose_dotsgen :
  forall f j s s',
    compose (dotsgen f j s) s' = dotsgen (fun i => subst s' (f i)) j (compose s s').
Proof.
intros f j s s'.
revert f.
induct j.

(* 0 *)
{
intros f.
cbn.
reflexivity.
}

(* S *)
{
intros j IH f.
rewrite -> !dotsgen_succ.
simpsub.
f_equal.
apply IH.
}
Qed.

Lemma project_dotsgen_lt :
  forall i f j s,
    i < j
    -> project (dotsgen f j s) i = f i.
Proof.
intros i f j s Hij.
revert f j Hij.
induct i.

(* 0 *)
{
intros f j Hij.
destruct j as [| j]; [omega |].
rewrite -> dotsgen_succ.
simpsub.
reflexivity.
}

(* S *)
{
intros i IH f j Hij.
destruct j as [| j]; [omega |].
rewrite -> dotsgen_succ.
simpsub.
apply IH.
omega.
}
Qed.

Lemma project_dotsgen_ge :
  forall i f j s,
    i >= j
    -> project (dotsgen f j s) i = project s (i-j).
Proof.
intros i f j s Hij.
revert f i Hij.
induct j.

(* 0 *)
{
intros f i _.
cbn.
f_equal.
omega.
}

(* S *)
{
intros j IH f i Hij.
destruct i as [| i]; [omega |].
rewrite -> dotsgen_succ.
simpsub.
apply IH.
omega.
}
Qed.

(* Dots corollaries *)

(* eaiser to prove directly *)
Lemma dots_succ :
  forall i j s,
    dots i (S j) s = dot (var i) (dots (S i) j s).
Proof.
intros i j.
revert i.
induct j.

(* 0 *)
{
intros i s.
cbn.
f_equal.
f_equal.
omega.
}

(* S *)
{
intros j IH i s.
cbn.
rewrite <- IH.
cbn.
repeat f_equal.
omega.
}
Qed.

Lemma project_dots_lt :
  forall i j k s,
    i < k
    -> project (dots j k s) i = var (i+j).
Proof.
intros i j k s Hik.
rewrite -> dots_dotsgen.
rewrite -> project_dotsgen_lt; auto.
f_equal.
omega.
Qed.

Lemma project_dots_ge :
  forall i j k s,
    i >= k
    -> project (dots j k s) i = project s (i-k).
Proof.
intros i j k s Hik.
rewrite -> dots_dotsgen.
rewrite -> project_dotsgen_ge; auto.
Qed.

Lemma compose_dots_sh :
  forall i j s k,
    compose (dots i j s) (sh k) = dots (i + k) j (compose s (sh k)).
Proof.
intros i j s k.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
f_equal.
fextensionality 1.
intro x.
simpsub.
f_equal.
omega.
Qed.

Lemma compose_dots_sh_sh :
  forall i j l k,
    compose (dots i j (sh l)) (sh k) = dots (k + i) j (sh (k + l)).
Proof.
intros i j l k.
rewrite -> compose_dots_sh.
rewrite -> compose_sh_sh.
f_equal; [omega |].
f_equal.
omega.
Qed.

Lemma compose_sh_dots_le :
  forall i j k s,
    i <= k
    -> compose (sh i) (dots j k s) = dots (i+j) (k-i) s.
Proof.
intros i j k s Hik.
rewrite -> !dots_dotsgen.
rewrite -> compose_sh_dotsgen_le; auto.
f_equal.
fextensionality 1.
intro x.
f_equal.
omega.
Qed.

Lemma compose_sh_dots_eq :
  forall j k s,
    compose (sh k) (dots j k s) = s.
Proof.
intros j k s.
rewrite -> compose_sh_dots_le; auto.
rewrite -> Nat.sub_diag.
reflexivity.
Qed.

Lemma compose_sh_dots_ge :
  forall i j k s,
    i >= k
    -> compose (sh i) (dots j k s) = compose (sh (i - k)) s.
Proof.
intros i j k s Hik.
replace i with (i - k + k) at 1 by omega.
rewrite <- compose_sh_sh.
rewrite -> compose_assoc.
rewrite -> compose_sh_dots_eq.
reflexivity.
Qed.

Lemma split_dots :
  forall i j k s,
    dots i (j + k) s = dots i j (dots (i+j) k s).
Proof.
intros i j k s.
rewrite -> !dots_dotsgen.
rewrite -> split_dotsgen.
do 2 f_equal.
fextensionality 1.
intro x.
f_equal.
omega.
Qed.

Lemma compose_dots_le :
  forall i j k l s s',
    i + j <= l
    -> compose (dots i j s) (dots k l s') = dots (i+k) j (compose s (dots k l s')).
Proof.
intros i j k l s s' Hle.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
apply dotsgen_equal; auto.
intros x Hx.
simpsub.
rewrite -> project_dotsgen_lt; [| omega].
f_equal.
omega.
Qed.

Lemma compose_dots_0_eq :
  forall j k s s',
    compose (dots 0 k s) (dots j k s') = dots j k (compose s (dots j k s')).
Proof.
intros j k s s'.
apply compose_dots_le.
auto.
Qed.

Lemma compose_dots_ge :
  forall i j k l s m,
    i >= l
    -> compose (dots i j s) (dots k l (sh m)) = dots (i-l+m) j (compose s (dots k l (sh m))).
Proof.
intros i j k l s m H.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
apply dotsgen_equal; auto.
intros x Hx.
simpsub.
rewrite -> project_dotsgen_ge; [| omega].
simpsub.
f_equal.
omega.
Qed.

Lemma compose_dots_stable :
  forall j k s s',
    (forall i, j <= i -> project s' i = var i)
    -> compose (dots j k s) s' = dots j k (compose s s').
Proof.
intros j k s s' Hstable.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
apply dotsgen_equal; auto.
intros i Hi.
simpsub.
apply Hstable.
omega.
Qed.

(* Under corollaries *)

Lemma under_dots :
  forall i s,
    under i s = dots 0 i (compose s (sh i)).
Proof.
intros i.
induct i.

(* 0 *)
{
intro s.
cbn.
rewrite -> compose_id_right.
auto.
}

(* S *)
{
intros i IH s.
rewrite -> under_succ.
unfold varx.
rewrite -> dots_succ.
f_equal.
rewrite -> IH.
rewrite -> compose_dots_sh.
simpsub.
repeat f_equal.
omega.
}
Qed.

Lemma under_dotsgen :
  forall i s,
    under i s = dotsgen var i (compose s (sh i)).
Proof.
intros i s.
rewrite -> under_dots.
apply dots_dotsgen.
Qed.

Lemma eqsub_dots_id :
  forall k,
    eqsub (dots 0 k (sh k)) id.
Proof.
intros k.
eapply eqsub_trans.
2:{
  apply (eqsub_under_id _ k).
  }
rewrite -> under_dots.
simpsub.
reflexivity.
Qed.

Lemma subst1_dots :
  forall i s m,
    compose (dots 1 i s) (dot m id) = dots 0 i (compose s (dot m id)).
Proof.
intros i s m.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
apply dotsgen_equal; auto.
intros x _.
simpsub.
auto.
Qed.

Lemma subst1_dots_under :
  forall i j m n,
    subst1
      (subst (sh i) m)
      (subst (dots 1 i (dot (var 0) (sh (S (j + i))))) n)
    =
    subst (under i (dot m (sh j))) n.
Proof.
intros i j m n.
rewrite -> dots_dotsgen.
rewrite -> under_dotsgen.
simpsub.
f_equal.
rewrite -> compose_dotsgen.
simpsub.
apply dotsgen_equal; auto.
intros x _.
simpsub.
auto.
Qed.

(* Unlift corollaries *)

Lemma compose_sh_unlift_ge :
  forall i j,
    i >= j
    -> compose (sh i) (unlift j) = sh (i - j).
Proof.
intros i j H.
rewrite -> unlift_dotsgen.
rewrite -> compose_sh_dotsgen_ge; auto.
simpsub.
f_equal.
omega.
Qed.

Lemma compose_sh_unlift :
  forall k,
    compose (sh k) (unlift k) = id.
Proof.
intros k.
rewrite -> unlift_dotsgen.
rewrite -> compose_sh_dotsgen_ge; auto.
replace (k - k) with 0 by omega.
auto.
Qed.

Lemma compose_sh_unlift_x :
  forall i j s,
    i >= j
    -> compose (sh i) (compose (unlift j) s) = compose (sh (i - j)) s.
Proof.
intros i j s H.
rewrite <- compose_assoc.
rewrite -> compose_sh_unlift_ge; auto.
Qed.

Lemma project_unlift_lt :
  forall i j,
    i < j
    -> project (unlift j) i = arb.
Proof.
intros i j H.
rewrite -> unlift_dotsgen.
rewrite -> project_dotsgen_lt; auto.
Qed.

Lemma project_unlift_ge :
  forall i j,
    i >= j
    -> project (unlift j) i = var (i-j).
Proof.
intros i j H.
rewrite -> unlift_dotsgen.
rewrite -> project_dotsgen_ge; auto.
simpsub.
auto.
Qed.

(* Dots/Unlift corollaries *)

Lemma compose_dots_unlift_ge :
  forall i j s k,
    i >= k
    -> compose (dots i j s) (unlift k) = dots (i-k) j (compose s (unlift k)).
Proof.
intros i j s k Hik.
rewrite -> !dots_dotsgen.
rewrite -> compose_dotsgen.
apply dotsgen_equal; auto.
intros x Hx.
simpsub.
rewrite -> project_unlift_ge; [| omega].
f_equal.
omega.
Qed.

Lemma compose_dots_unlift_exact :
  forall j k,
    j <= k
    -> compose (dots 0 j (sh k)) (unlift j) = compose (unlift j) (sh (k-j)).
Proof.
intros j k Hjk.
rewrite -> dots_dotsgen.
rewrite -> unlift_dotsgen.
rewrite -> !compose_dotsgen.
apply dotsgen_equal; auto.
  {
  intros x Hx.
  cbn [Nat.add].
  simpsub.
  rewrite -> project_dotsgen_lt; auto.
  }

  {
  rewrite -> compose_sh_dotsgen_ge; auto.
  simpsub.
  f_equal.
  omega.
  }
Qed.

End object.

Arguments dots {obj} i n s.
Arguments unlift {obj} i.
Arguments dotsgen {obj} f n s.


(* Partly taken from Containers library and the StdLib FSetWeakList.v *)

Require Import List SetoidPermutation SetoidList.
Require Import Bool.
Require Import SetoidDec.
Require Pactole.Util.Coqlib.
Require Import Pactole.Util.FSets.FSetInterface.

Set Implicit Arguments.
Open Scope signature_scope.

(** *  Operations  **)

Definition set_ (A : Type) `{EqDec A} := list A.

Section ListOperations.
  Variable elt : Type.
  Context `{EqDec elt}.
  Notation t := (@set_ elt _ _).

  (** **  Operations on raw lists  **)

(*  Definition empty : set := nil. *)
  Definition list_is_empty (s : t) : bool := if s then true else false.

  Fixpoint list_mem (x : elt) (s : t) {struct s} : bool :=
    match s with
    | nil => false
    | y :: l => if x == y then true else list_mem x l
    end.

  Definition list_add (x : elt) (s : t) : t :=
    if list_mem x s then s else x :: s.

  Definition list_singleton (x : elt) : t := x :: nil.

  Fixpoint list_remove (x : elt) (s : t) {struct s} : t :=
    match s with
    | nil => nil
    | y :: l => if x == y then l else y :: list_remove x l
    end.

  Definition list_fold {B : Type} (f : elt -> B -> B) : t -> B -> B :=
    fold_left (flip f).

  Definition list_union (s : t) : t -> t := list_fold list_add s.

  Definition list_inter (s s': t) : t :=
    list_fold (fun x s => if list_mem x s' then list_add x s else s) s nil.

  Definition list_diff (s s' : t) : t := list_fold list_remove s' s.

  Definition list_subset (s s' : t) : bool := list_is_empty (list_diff s s').

  Definition list_equal (s s' : t) : bool := andb (list_subset s s') (list_subset s' s).

  Fixpoint list_filter (f : elt -> bool) (s : t) : t :=
    match s with
    | nil => nil
    | x :: l => if f x then x :: list_filter f l else list_filter f l
    end.

  Fixpoint list_for_all (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => true
    | x :: l => if f x then list_for_all f l else false
    end.

  Fixpoint list_exists_ (f : elt -> bool) (s : t) : bool :=
    match s with
    | nil => false
    | x :: l => if f x then true else list_exists_ f l
    end.

  Fixpoint list_partition (f : elt -> bool) (s : t) : t * t :=
    match s with
    | nil => (nil, nil)
    | x :: l =>
      let (s1, s2) := list_partition f l in
      if f x then (x :: s1, s2) else (s1, x :: s2)
    end.

  Definition list_choose (s : t) : option elt :=
    match s with
    | nil => None
    | x::_ => Some x
    end.

  (** **  Preservation of the [NoDupA] property  **)

  Lemma t_add_lemma : forall x (s : t),
    NoDupA equiv s -> NoDupA equiv (list_add x s).
  Proof using .
  intros x s Hs. induction s as [| y l].
  + constructor; trivial; []. intro Habs. inversion Habs.
  + specialize (IHl ltac:(now inversion_clear Hs)).
    unfold list_add in *. simpl in *.
    destruct (x == y) as [| Hxy]; [| destruct (list_mem x l)]; try apply Hs; [].
    constructor; trivial; [].
    inversion_clear Hs. inversion_clear IHl.
    intro Habs. inversion_clear Habs; contradiction.
  Qed.

  Notation set elt := (sig (@NoDupA elt equiv)).

  Definition t_add (x : elt) (s : set elt) : set elt :=
    exist _ (list_add x (proj1_sig s)) (t_add_lemma _ (proj2_sig s)).

  Lemma list_remove_aux : forall (m : t) x y,
    InA equiv y (list_remove x m) -> InA equiv y m.
  Proof using .
  intros m x y Hy. simpl. induction m as [| z l].
  - inversion_clear Hy.
  - simpl in *. destruct (x == z); auto.
    inversion_clear Hy; now left + (right; apply IHl).
  Qed.

  Lemma t_remove_lemma : forall k (s : t),
    NoDupA equiv s -> NoDupA equiv (list_remove k s).
  Proof using .
  intros x s Hs. induction s as [| y l].
  + now constructor.
  + simpl. destruct (x == y) as [Hxy | Hxy].
    - inversion_clear Hs. auto.
    - constructor; inversion_clear Hs.
      -- intro Habs. apply H0. eauto using list_remove_aux.
      -- auto.
  Qed.

  Definition t_remove (x : elt) (s : set elt) : set elt :=
    exist _ (list_remove x (proj1_sig s)) (t_remove_lemma _ (proj2_sig s)).

  Lemma t_union_lemma : forall s1 s2,
    NoDupA equiv s1 -> NoDupA equiv s2 -> NoDupA equiv (list_union s1 s2).
  Proof using .
  intros s1 s2 Hs1. unfold list_union, list_fold, flip.
  revert s2. induction s1; simpl; intros s2 Hs2.
  + assumption.
  + inversion_clear Hs1. apply IHs1; auto using t_add_lemma.
  Qed.

  Definition t_union (s1 s2 : set elt) : set elt :=
    exist _ (list_union (proj1_sig s1) (proj1_sig s2)) (t_union_lemma (proj2_sig s1) (proj2_sig s2)).

  Lemma t_inter_lemma : forall s1 s2,
    NoDupA equiv s1 -> NoDupA equiv (list_inter s1 s2).
  Proof using .
  intros s1 s2 Hs1. unfold list_inter, list_fold, flip.
  generalize (NoDupA_nil equiv). generalize (@nil elt) as acc.
  induction s1 as [| e1 s1]; simpl; intros acc Hacc.
  + assumption.
  + inversion_clear Hs1. apply IHs1; trivial; [].
    destruct (list_mem e1 s2); auto using t_add_lemma.
  Qed.

  Definition t_inter (s1 s2 : set elt) : set elt :=
    exist _ (list_inter (proj1_sig s1) (proj1_sig s2)) (t_inter_lemma (proj1_sig s2) (proj2_sig s1)).

  Lemma t_diff_lemma : forall s1 s2,
    NoDupA equiv s1 -> NoDupA equiv (list_diff s1 s2).
  Proof using .
  intros s1 s2. unfold list_diff, list_fold, flip.
  revert s1. induction s2 as [| e2 s2]; simpl; intros s1 Hs1.
  + assumption.
  + now apply IHs2, t_remove_lemma.
  Qed.

  Definition t_diff (s1 s2 : set elt) : set elt :=
    exist _ (list_diff (proj1_sig s1) (proj1_sig s2)) (t_diff_lemma (proj1_sig s2) (proj2_sig s1)).

  Lemma list_filter_incl : forall f s, inclA equiv (list_filter f s) s.
  Proof using .
  intros f s. induction s as [| e s]; simpl.
  + reflexivity.
  + destruct (f e).
    - intros x Hin. inversion_clear Hin; (now left) || now right; apply IHs.
    - etransitivity; eauto; []. intros x Hin. now right.
  Qed.

  Lemma t_filter_lemma : forall (f : elt -> bool) (s : @set_ elt _ _),
    NoDupA equiv s -> NoDupA equiv (list_filter f s).
  Proof using .
  intros f s Hs. induction Hs as [| e s He Hs IHs]; simpl.
  + constructor.
  + destruct (f e); trivial; [].
    constructor; trivial; [].
    intro Habs. apply He. eapply list_filter_incl, Habs.
  Qed.

  Definition t_filter f (s : set elt) : set elt :=
    exist _ (list_filter f (proj1_sig s)) (t_filter_lemma f (proj2_sig s)).

  Lemma list_partition_fst_incl : forall f s, inclA equiv (fst (list_partition f s)) s.
  Proof using .
  intros f s. induction s as [| e s]; simpl.
  + reflexivity.
  + destruct (list_partition f s) as [s1 s2], (f e); simpl.
    - intros x Hin. inversion_clear Hin; (now left) || now right; apply IHs.
    - etransitivity; eauto; []. intros x Hin. now right.
  Qed.

  Lemma t_partition_lemma_fst : forall (f : elt -> bool) (s : @set_ elt _ _),
    NoDupA equiv s -> NoDupA equiv (fst (list_partition f s)).
  Proof using .
  intros f s Hs. induction Hs as [| e s He Hs IHs]; simpl.
  + constructor.
  + destruct (list_partition f s) as [s1 s2] eqn:Hfs, (f e); simpl in *.
    - constructor; trivial; [].
      intro Hin. apply He. eapply list_partition_fst_incl. now rewrite Hfs.
    - assumption.
  Qed.

  Lemma list_partition_snd_incl : forall f s, inclA equiv (snd (list_partition f s)) s.
  Proof using .
  intros f s. induction s as [| e s]; simpl.
  + reflexivity.
  + destruct (list_partition f s) as [s1 s2], (f e); simpl.
    - etransitivity; eauto; []. intros x Hin. now right.
    - intros x Hin. inversion_clear Hin; (now left) || now right; apply IHs.
  Qed.

  Lemma t_partition_lemma_snd : forall (f : elt -> bool) (s : @set_ elt _ _),
    NoDupA equiv s -> NoDupA equiv (snd (list_partition f s)).
  Proof using .
  intros f s Hs. induction Hs as [| e s He Hs IHs]; simpl.
  + constructor.
  + destruct (list_partition f s) as [s1 s2] eqn:Hfs, (f e); simpl in *.
    - assumption.
    - constructor; trivial; [].
      intro Hin. apply He. eapply list_partition_snd_incl. now rewrite Hfs.
  Qed.

  Definition t_partition f (s : set elt) : set elt * set elt :=
    (exist _ (fst (list_partition f (proj1_sig s))) (t_partition_lemma_fst f (proj2_sig s)),
     exist _ (snd (list_partition f (proj1_sig s))) (t_partition_lemma_snd f (proj2_sig s))).

End ListOperations.

(*  Notation In := (@InA elt equiv).
  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
  Definition Subset s s' := forall a : elt, In a s -> In a s'.
  Definition Empty s := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop) (s : set) := exists x, In x s /\ P x. *)

(*
Lemma list_add_3 : forall (m : t elt) x y e e',
  x =/= y -> InA (equiv@@1) (y, e) (list_add x e' m) -> InA (equiv@@1) (y, e) m.
Proof.
intros m x y e e' Hxy Hy. simpl. induction m as [| [z p] l].
+ inversion_clear Hy; try inversion H0. now elim Hxy.
+ simpl in *. destruct (equiv_dec x z).
  - right. inversion_clear Hy; trivial. now elim Hxy.
  - inversion_clear Hy; now left + (right; apply IHl).
Qed.*)

(** **  Map between sets (not currently incorporated to the signature)  **)
Section SetMap.

  Variable elt : Type.
  Context `{EqDec elt}.
  Notation set elt := (sig (@NoDupA elt equiv)).

  Definition list_map {elt' : Type} `{EqDec elt'}
                      (f : elt -> elt') (s : @set_ elt _ _) : @set_ elt' _ _ :=
    list_fold (fun x acc => list_add (f x) acc) s nil.

  Lemma t_map_lemma {elt'} `{EqDec elt'} : forall (f : elt -> elt') (s : @set_ elt _ _),
    NoDupA equiv s -> NoDupA equiv (list_map f s).
  Proof using .
  intros f s Hs. unfold list_map, list_fold, list_add, flip.
  generalize (@NoDupA_nil elt' equiv).
  generalize (@nil elt') as acc.
  induction Hs as [| y l Hy Hs IHs]; simpl; intros acc Hacc.
  * assumption.
  * apply IHs.
    destruct (list_mem (f y) acc) eqn:Htest.
    + assumption.
    + constructor; trivial; [].
      intro Hin. induction acc.
      - inversion Hin.
      - simpl in *. destruct (f y == a) as [Heq | Heq]; try discriminate; [].
        inversion_clear Hacc. inversion_clear Hin; auto.
  Qed.

  Definition t_map {elt'} `{EqDec elt'} (f : elt -> elt') (s : set elt) : set elt' :=
    exist _ (list_map f (proj1_sig s)) (t_map_lemma f (proj2_sig s)).

End SetMap.

(*
Arguments empty {_%type_scope} {_} {_}.
Arguments In  {_%type_scope} {_} {_} {_} _ _%list_scope.
Arguments is_empty {_%type_scope} {_} {_} _%list_scope.
Arguments mem {_%type_scope} {_} {_}  _ _%set_scope.
Arguments add {_%type_scope} {_} {_} _%set_scope.
Arguments remove {_%type_scope} {_} {_} _ _%set_scope.
Arguments union {_%type_scope} {_} {_} _%set_scope _%set_scope.
Arguments inter {_%type_scope} {_} {_} _%set_scope _%set_scope.
Arguments diff {_%type_scope} {_} {_} _%set_scope _%set_scope.
Arguments equal {_%type_scope} {_} {_} _%set_scope _%set_scope.
Arguments subset {_%type_scope} {_} {_} _%set_scope _%set_scope.
Arguments fold {elt%type_scope} {_%type_scope} {_} _ _%set_scope _.
Arguments map {elt%type_scope} {_%type_scope} {_} {_} {_} _ _%set_scope.
Arguments for_all {_%type_scope} {_} _ _%set_scope.
Arguments exists_ {_%type_scope} {_} _ _%set_scope.
Arguments filter {_%type_scope} {_} _ _%set_scope.
Arguments partition {_%type_scope} {_} _ _%set_scope.
Arguments cardinal {_%type_scope} {_} _%set_scope.
Arguments elements {_%type_scope} {_} _%set_scope.
Arguments choose {_%type_scope} {_} _%set_scope.
*)
(** The full set of operations. *)
Instance SetList elt `{EqDec elt} : FSet := {|
  set := sig (@NoDupA elt equiv);
  In := fun x s => InA equiv x (proj1_sig s);
  empty := exist _ nil (NoDupA_nil equiv);
  is_empty := fun s => match proj1_sig s with nil => true | cons _ _ => false end;
  mem := fun x s => list_mem x (proj1_sig s);
  add := @t_add _ _ _;
  singleton := fun x => t_add x (exist _ nil (NoDupA_nil equiv));
  remove := @t_remove _ _ _;
  union := @t_union _ _ _;
  inter := @t_inter _ _ _;
  diff := @t_diff _ _ _;
  equal := fun s s' => @list_equal _ _ _ (proj1_sig s) (proj1_sig s');
  subset := fun s s' => @list_subset _ _ _ (proj1_sig s) (proj1_sig s');
(*   map := t_map _ _; *)
  fold := fun A f s => @list_fold _ _ _ A f (proj1_sig s);
  for_all := fun f s => List.forallb f (proj1_sig s);
  exists_ := fun f s => List.existsb f (proj1_sig s);
  filter := @t_filter _ _ _;
  partition := @t_partition _ _ _;
  cardinal := fun s => @length _ (proj1_sig s);
  elements := fun s => (proj1_sig s);
  choose := fun s => list_choose (proj1_sig s) |}.

(* Typeclasses Opaque set. *)

(** **  Proofs of the specifications  **)
(*
Instance MapListFacts_MapsTo key `{EqDec key} : FMapSpecs_MapsTo (MapList _).
Proof.
split. intros elt [m Hm] x y e Hxy Hx. simpl in *.
induction m; inversion_clear Hx.
- left. simpl in *. now rewrite <- Hxy.
- right. inversion_clear Hm. now apply IHm.
Qed.

Instance MapListFacts_mem key `{EqDec key} : FMapSpecs_mem (MapList _).
Proof. split.
* intros elt [m Hm] x [e Hin]. simpl in *. induction m as [| [y n] l]; inversion_clear Hin.
  + simpl. destruct (equiv_dec x y) as [Hxy | Hxy]; trivial. elim Hxy. now destruct H0.
  + simpl. destruct (equiv_dec x y) as [Hxy | Hxy]; trivial. inversion_clear Hm. auto.
* intros elt [m Hm] x Hmem. unfold In. simpl in *. induction m as [| [y n] l]; simpl in Hmem.
  + discriminate.
  + destruct (equiv_dec x y) as [Hxy | Hxy].
    - exists n. left. now split.
    - inversion_clear Hm. apply IHl in Hmem; trivial; []. destruct Hmem as [e ?]. exists e. now right.
Qed.

Instance MapListFacts_empty key `{EqDec key} : FMapSpecs_empty (MapList _).
Proof. split. intros elt x e Hin. inversion Hin. Qed.

Instance MapListFacts_is_empty key `{EqDec key} : FMapSpecs_is_empty (MapList _).
Proof. split.
* intros elt [m Hm] Hm'. destruct m as [| [x n] l]; trivial.
  elim Hm' with x n. now left.
* intros elt [m Hm] Hm'. destruct m as [| [x n] l]; try discriminate.
  intros x n Hin. inversion Hin.
Qed.
*)

Local Transparent
  In empty is_empty mem add singleton remove
  union inter diff equal subset fold
  for_all exists_ filter partition cardinal elements choose.

Instance SetListFacts_In elt `{EqDec elt} : FSetSpecs_In SetList.
Proof using . split. simpl. intros s x y Heq. now rewrite Heq. Qed.

Local Lemma mem_aux elt `{EqDec elt} : forall x l, list_mem x l = true <-> InA equiv x l.
Proof using .
intros x l. induction l as [| e l]; simpl.
* rewrite InA_nil. intuition.
* destruct (x == e).
  + intuition.
  + rewrite IHl. split; intro Hin.
    - now right.
    - inversion_clear Hin; assumption || contradiction.
Qed.

Instance SetListFacts_mem elt `{EqDec elt} : FSetSpecs_mem SetList.
Proof using . split.
* intros [s Hs] x Hin. simpl in *. now rewrite mem_aux.
* intros [s Hs] x Hin. simpl in *. now rewrite mem_aux in Hin.
Qed.

Instance SetLIst_Facts_empty elt `{EqDec elt} : FSetSpecs_empty SetList.
Proof using . split. intros x Hin; simpl in *. now rewrite InA_nil in Hin. Qed.

Instance SetListFacts_is_empty elt `{EqDec elt} : FSetSpecs_is_empty SetList.
Proof using . split.
* intros [[| e s] Hs] Hempty; simpl in *.
  + reflexivity.
  + specialize (Hempty e ltac:(now left)). tauto.
* intros [[| e s] Hs] Hempty; simpl in *.
  + intros x Hin. rewrite <- InA_nil. apply Hin.
  + discriminate.
Qed.

Local Lemma add_aux elt `{EqDec elt} : forall x e l,
  InA equiv x (list_add e l) <-> x == e \/ InA equiv x l.
Proof using .
intros x e l. unfold list_add.
destruct (list_mem e l) eqn:Hmem.
+ split; intro Hin.
  - now right.
  - destruct Hin as [Hin | Hin]; trivial; [].
    rewrite mem_aux in Hmem. now rewrite Hin.
+ split; intro Hin.
  - inversion_clear Hin; tauto.
  - destruct Hin; now left + right.
Qed.

Instance SetListFacts_add elt `{EqDec elt} : FSetSpecs_add SetList.
Proof using . split.
* intros [s Hs] x y Heq. simpl. rewrite add_aux. now left.
* intros [s Hs] x y Hin. simpl in *. rewrite add_aux. now right.
* intros s x e Hneq Hin. simpl in *. rewrite add_aux in Hin.
  destruct Hin; intuition.
Qed.

Local Lemma remove_aux elt `{EqDec elt} : forall x e l, NoDupA equiv l ->
  InA equiv x (list_remove e l) <-> InA equiv x l /\ x =/= e.
Proof using .
intros x e l Hnodup. induction l as [| e' l]; simpl.
* rewrite InA_nil. tauto.
* destruct (e == e') as [Heq | Hneq]; repeat rewrite InA_cons.
  + split; intro Hin.
    - split; try (now right); [].
      intro Habs. inversion_clear Hnodup.
      rewrite Habs, Heq in *. contradiction.
    - rewrite Heq in Hin. intuition.
  + inversion_clear Hnodup. rewrite IHl; trivial; [].
    split; intro Hin.
    - destruct Hin as [Hin | [Hin ?]]; split; try tauto; [].
      rewrite Hin. intro. now apply Hneq.
    - destruct Hin as [[] ?]; now left + right.
Qed.

Instance SetListFacts_remove elt `{EqDec elt} : FSetSpecs_remove SetList.
Proof using . split.
* intros [s Hs] x y Heq. simpl. symmetry in Heq. now rewrite remove_aux.
* intros [s Hs] x y Hxy Hin. simpl in *. now rewrite remove_aux.
* intros [s Hs] x y Hin. simpl in *. now rewrite remove_aux in Hin.
Qed.

Instance SetListFacts_singleton elt `{EqDec elt} : FSetSpecs_singleton SetList.
Proof using . split.
* intros x y Hin. simpl in *. unfold list_add in Hin.
  destruct (list_mem x nil); now inversion_clear Hin.
* intros x y Heq. simpl. rewrite <- Heq.
  unfold list_add. simpl. now left.
Qed.

Local Lemma union_aux elt `{EqDec elt} : forall s1 s2 x,
  InA equiv x s2 -> InA equiv x (fold_left (fun s y => list_add y s) s1 s2).
Proof using .
intros s1. induction s1 as [| e1 s1]; simpl; intros s2 x Hin.
+ assumption.
+ apply IHs1; eauto using t_add_lemma; [].
  unfold list_add. now destruct (list_mem e1 s2); try right.
Qed.

Instance SetListFacts_union elt `{EqDec elt} : FSetSpecs_union SetList.
Proof using . split.
* intros [s1 Hs1] [s2 Hs2]. simpl.
  unfold list_union, list_fold, flip.
  revert s2 Hs2. induction s1 as [| e1 s1]; simpl; intros s2 Hs2 x Hin.
  + now right.
  + inversion_clear Hs1.
    apply IHs1 in Hin; auto using t_add_lemma; [].
    destruct Hin as [Hin | Hin].
    - now left; right.
    - unfold list_add in Hin. destruct (list_mem e1 s2); try (now right); [].
      inversion_clear Hin; (now do 2 left) || now right.
* intros [s1 Hs1] [s2 Hs2] x Hin. simpl in *.
  unfold list_union, list_fold, flip.
  revert s2 Hs2. induction s1 as [| e1 s1]; simpl; intros s2 Hs2.
  + now rewrite InA_nil in Hin.
  + inversion_clear Hs1.
    inversion_clear Hin.
    - match goal with H : _ == _ |- _ => rewrite H end. apply union_aux.
      unfold list_add. destruct (list_mem e1 s2) eqn:Hmem; try (now left); [].
      change (e1 ∈ (exist _ s2 Hs2))%set. now apply mem_2.
    - apply IHs1; auto using t_add_lemma.
* intros [s1 Hs1] [s2 Hs2]. simpl in *.
  unfold list_union, list_fold, flip.
  apply union_aux.
Qed.

Lemma inter_aux elt `{EqDec elt} : forall (f : elt -> bool), Proper (equiv ==> equiv) f ->
  forall l1 l x,
  InA equiv x (fold_left (fun s y => if f y then list_add y s else s) l1 l)
  <-> InA equiv x l1 /\ f x = true \/ InA equiv x l.
Proof using .
intros f Hf l1. induction l1 as [| e1 l1]; simpl; intros l x.
* rewrite InA_nil. tauto.
* rewrite IHl1.
  split; intros [[Hin Hfx] | Hin].
  + left. split; trivial; []. now right.
  + destruct (f e1) eqn:Hfe; try tauto; [].
    rewrite add_aux in Hin. destruct Hin as [Hin | ?]; try tauto; [].
    rewrite Hin. left. now split; try left.
  + inversion_clear Hin.
    - Preliminary.revert_one equiv. intro Heq. rewrite Heq in *.
      rewrite Hfx. right. rewrite add_aux. now left.
    - tauto.
  + right. destruct (f e1); trivial; []. rewrite add_aux. now right.
Qed.

Local Lemma mem_compat elt `{EqDec elt} :
  forall l, Proper (equiv ==> equiv) (fun y => list_mem y l).
Proof using .
intros l x y Heq. induction l as [| e l]; simpl; trivial; [].
destruct (x == e), (y == e).
- reflexivity.
- rewrite Heq in *. contradiction.
- rewrite Heq in *. contradiction.
- apply IHl.
Qed.

Instance SetListFacts_inter elt `{EqDec elt} : FSetSpecs_inter SetList.
Proof using . split.
* intros [s1 Hs1] [s2 Hs2] x. simpl.
  unfold list_inter, list_fold, flip. rewrite inter_aux.
  + rewrite InA_nil. tauto.
  + apply mem_compat.
* intros [s1 Hs1] [s2 Hs2] x. simpl.
  unfold list_inter, list_fold, flip. rewrite inter_aux.
  + rewrite InA_nil, mem_aux. tauto.
  + apply mem_compat.
* intros [s1 Hs1] [s2 Hs2] x. simpl.
  unfold list_inter, list_fold, flip. rewrite inter_aux.
  + rewrite InA_nil, mem_aux. tauto.
  + apply mem_compat.
Qed.

Lemma diff_aux elt `{EqDec elt} : forall l1 l2 x, NoDupA equiv l1 ->
  InA equiv x (fold_left (fun s y => list_remove y s) l2 l1)
  <-> InA equiv x l1 /\ ~InA equiv x l2.
Proof using .
intros l1 l2 x. revert l1. induction l2 as [| e2 l2]; simpl; intros l1 Hnodup.
* rewrite InA_nil. tauto.
* rewrite IHl2.
  + rewrite remove_aux, InA_cons; trivial; []. intuition.
  + now apply t_remove_lemma.
Qed.

Instance SetListFacts_diff elt `{EqDec elt} : FSetSpecs_diff SetList.
Proof using .
split;
intros [s1 Hs1] [s2 Hs2] x; simpl;
unfold list_diff, list_fold, flip; now rewrite diff_aux.
Qed.

Instance SetListFacts_subset elt `{EqDec elt} : FSetSpecs_subset SetList.
Proof using . split.
* intros s1 s2 Hle. simpl. unfold list_subset.
  change (is_empty (diff s1 s2) = true).
  apply is_empty_1. intros x Hin.
  assert (Hin1 := diff_1 Hin). assert (Hin2 := diff_2 Hin).
  apply Hin2. apply Hle. apply Hin1.
* intros s1 s2 Hle. simpl in Hle. unfold list_subset in Hle.
  change (is_empty (diff s1 s2) = true) in Hle.
  apply is_empty_2 in Hle. intros x Hin. specialize (Hle x).
  destruct (mem x s2) eqn:Hmem.
  + now apply mem_2.
  + elim Hle. apply diff_3; trivial; [].
    intro Habs. apply mem_1 in Habs. congruence.
Qed.

Instance SetListFacts_equal elt `{EqDec elt} : FSetSpecs_equal SetList.
Proof using . split.
* intros s1 s2 Heq. simpl.
  change (subset s1 s2 && subset s2 s1 = true).
  rewrite andb_true_iff. split.
  + apply subset_1. intros x Hin. rewrite <- (Heq x). apply Hin.
  + apply subset_1. intros x Hin. rewrite (Heq x). apply Hin.
* intros s1 s2 Heq x. simpl in Heq.
  change (subset s1 s2 && subset s2 s1 = true) in Heq.
  rewrite andb_true_iff in Heq. destruct Heq as [Hle1 Hle2].
  split; now apply subset_2.
Qed.

Instance SetListFacts_cardinal elt `{EqDec elt} : FSetSpecs_cardinal SetList.
Proof using . split. reflexivity. Qed.

Instance SetListFacts_fold elt `{EqDec elt} : FSetSpecs_fold SetList.
Proof using . split. reflexivity. Qed.

Instance SetListFacts_filter elt `{EqDec elt} : FSetSpecs_filter SetList.
Proof using . split.
* intros [s Hs] x f Hf Hin.
  induction s as [| e s]; simpl in *.
  + assumption.
  + inversion_clear Hs.
    destruct (f e).
    - inversion_clear Hin; now constructor; auto.
    - right. auto.
* intros [s Hs] x f Hf Hin.
  induction s as [| e s]; simpl in *.
  + rewrite InA_nil in *. tauto.
  + inversion_clear Hs.
    destruct (f e) eqn:Hfe.
    - inversion_clear Hin; auto; [].
      Preliminary.revert_one equiv. intro Heq. now rewrite Heq.
    - auto.
* intros [s Hs] x f Hf Hin Hfx.
  induction s as [| e s]; simpl in *.
  + assumption.
  + inversion_clear Hs.
    destruct (f e) eqn:Hfe.
    - inversion_clear Hin; auto.
    - inversion_clear Hin; auto; [].
      cut (true = false); try discriminate; [].
      rewrite <- Hfe, <- Hfx. now apply Hf.
Qed.

Instance SetListFacts_for_all elt `{EqDec elt} : FSetSpecs_for_all SetList.
Proof using . split.
* intros [s Hs] f Hf Hall. unfold For_all in Hall. simpl in *.
  rewrite forallb_forall. intros x Hin. apply Hall. apply In_InA; Preliminary.autoclass.
* intros [s Hs] f Hf Hall x Hin. simpl in *.
  rewrite forallb_forall in Hall.
  rewrite InA_alt in Hin. destruct Hin as [y [Heq Hin]].
  rewrite Heq. auto.
Qed.

Instance SetListFacts_exists elt `{EqDec elt} : FSetSpecs_exists SetList.
Proof using . split.
* intros [s Hs] f Hf [x [Hin Hfx]]. simpl in *. rewrite existsb_exists.
  rewrite InA_alt in Hin. destruct Hin as [y [Heq Hin]].
  rewrite Heq in Hfx. eauto.
* intros [s Hs] f Hf Hex. simpl in *. rewrite existsb_exists in Hex.
  destruct Hex as [x [Hin Hfx]]. exists x. simpl. split; trivial; []. apply In_InA; Preliminary.autoclass.
Qed.

Instance SetListFacts_partition elt `{EqDec elt} : FSetSpecs_partition SetList.
Proof using . split.
* intros [s Hs] f Hf x. simpl. induction s as [| e s]; simpl.
  + reflexivity.
  + destruct (list_partition f s) as [s1 s2]; simpl in *.
    destruct (f e) eqn:Hfe; simpl.
    - inversion_clear Hs. specialize (IHs ltac:(assumption)).
      split; intro Hin; inversion_clear Hin; auto;
      (progress rewrite IHs in * || rewrite <- IHs in *); auto.
    - apply IHs. now inversion_clear Hs.
* intros [s Hs] f Hf x. simpl. induction s as [| e s]; simpl.
  + reflexivity.
  + destruct (list_partition f s) as [s1 s2]; simpl in *.
    destruct (f e) eqn:Hfe; simpl.
    - apply IHs. now inversion_clear Hs.
    - inversion_clear Hs. specialize (IHs ltac:(assumption)).
      split; intro Hin; inversion_clear Hin; auto;
      (progress rewrite IHs in * || rewrite <- IHs in *); auto.
Qed.

Instance SetListFacts_elements elt `{EqDec elt} : FSetSpecs_elements SetList.
Proof using . split.
* simpl. auto.
* simpl. auto.
* intros [s Hs]. simpl. assumption.
Qed.

Instance SetListFacts_choose elt `{EqDec elt} : FSetSpecs_choose SetList.
Proof using . split.
* intros [[| e s] Hs] x Hin; simpl in *.
  + discriminate.
  + inversion_clear Hin. now left.
* intros [[| e s] Hs] x Hin; simpl in *.
  + rewrite InA_nil. tauto.
  + discriminate.
Qed.

(** The full set of specifications. *)
Instance SetListFacts elt `{EqDec elt} : FSetSpecs SetList.
Proof using . split; auto with typeclass_instances. Qed.


Require Import ExtLib.Structures.Monads.
Require Import BinPos.

Set Implicit Arguments.
Set Strict Implicit.

Inductive FixResult (T : Type) :=
| Term : T -> FixResult T
| Diverge : FixResult T.

Arguments Diverge {_}.
Arguments Term {_} _.

(** The GFix monad is like monad fix except that
 ** it encapsulates the "gas" that is used as the measure
 **)
Section gfix.
  (** This is essentially ReaderT (optionT m)) **)
  Inductive GFix (T : Type) : Type := mkGFix
  { runGFix : N -> FixResult T }.

  Global Instance MonadFix_GFix : MonadFix GFix :=
  { mfix := fun T U f v => mkGFix (fun n : N =>
    match n with
      | N0 => Diverge
      | Npos g =>
        let F := fix rec (acc : T -> FixResult U) (gas : positive) (x : T)
          : FixResult U :=
          match gas return FixResult U with
            | xI p =>
              runGFix (f (fun x => mkGFix (fun n => rec (fun x => rec acc p x) p x)) x) n
            | xO p =>
              rec (fun x => rec acc p x) p x
            | xH => runGFix (f (fun x => mkGFix (fun _ => acc x)) x) n
          end
        in F (fun x => runGFix (f (fun _ => mkGFix (fun _ => Diverge)) x) n) g v
      end)
  }.

  Global Instance Monad_GFix : Monad GFix :=
  { ret := fun _ v => mkGFix (fun _ => Term v)
  ; bind := fun _ _ c1 c2 =>
    mkGFix (fun gas =>
      match runGFix c1 gas with
        | Diverge => Diverge
        | Term v => runGFix (c2 v) gas
      end)
  }.

End gfix.

(** Demo
Require Import ExtLib.Data.Monads.IdentityMonad.
Definition foo : nat -> GFix ident nat :=
  mfix (fun recur n =>
    match n with
      | 0 => ret 0
      | S n => recur n
    end).

Eval compute in runGFix (foo 10) 100000000000000000000000.
**)


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

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

Print Assumptions freeze.


(**
Biadjunction when adding a 2-cell to the algebra structure
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Transformations.Examples.Unitality.
Require Import UniMath.Bicategories.Transformations.Examples.Associativity.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation.
Require Import UniMath.Bicategories.DisplayedBicats.DispModification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders.
Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction.

Require Import signature.hit_signature.
Require Import prelude.all.
Require Import algebra.one_types_polynomials.
Require Import algebra.groupoid_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.groupoid_endpoints.
Require Import algebra.one_types_homotopies.
Require Import algebra.groupoid_homotopies.
Require Import biadjunctions.all.
Require Import hit_biadjunction.path_groupoid_commute.
Require Import hit_biadjunction.gquot_commute.
Require Import hit_biadjunction.gquot_natural.
Require Import hit_biadjunction.hit_prealgebra_biadj.
Require Import hit_biadjunction.hit_path_algebra_biadj.

Local Open Scope cat.

(** Necessary operation *)
Definition poly_act_morphism_to_path
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
  : x = y → poly_act_morphism P G x y.
Proof.
  induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - exact (λ p, p).
  - exact (λ p, pr1 (@idtoiso G _ _ p)).
  - induction x as [x | x], y as [y | y].
    + exact (λ p, IHP₁ x y (ii1_injectivity _ _ p)).
    + exact (λ p, fromempty (negpathsii1ii2 _ _ p)).
    + exact (λ p, fromempty (negpathsii2ii1 _ _ p)).
    + exact (λ p, IHP₂ x y (ii2_injectivity _ _ p)).
  - exact (λ p, IHP₁ _ _ (maponpaths pr1 p) ,, IHP₂ _ _ (maponpaths dirprod_pr2 p)).
Defined.

(** Lemmata *)
Definition poly_act_morphism_to_path_idpath
           {P : poly_code}
           {X : groupoid}
           (x : poly_act P X)
  : poly_act_morphism_to_path (idpath x) = poly_act_identity x.
Proof.
  induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - apply idpath.
  - induction x as [x | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (pathsdirprod (IHP₁ (pr1 x)) (IHP₂ (pr2 x))).
Qed.

Definition poly_act_compose_poly_act_morphism_to_path
           {P : poly_code}
           {X : groupoid}
           {x y z : poly_act P X}
           (p : x = y) (q : y = z)
  : poly_act_compose
      (poly_act_morphism_to_path p)
      (poly_act_morphism_to_path q)
    =
    poly_act_morphism_to_path (p @ q).
Proof.
  induction p ; induction q.
  simpl.
  etrans.
  {
    apply maponpaths.
    apply poly_act_morphism_to_path_idpath.
  }
  apply poly_act_id_right.
Qed.

Definition ii1_injectivity_maponpaths_inl
           {A B : UU}
           {x y : A}
           (p : x = y)
  : @ii1_injectivity A B x y (maponpaths inl p) = p.
Proof.
  induction p.
  apply idpath.
Defined.

Definition ii2_injectivity_maponpaths_inr
           {A B : UU}
           {x y : B}
           (p : x = y)
  : @ii2_injectivity A B x y (maponpaths inr p) = p.
Proof.
  induction p.
  apply idpath.
Defined.

Definition poly_act_morphism_to_path_path_groupoid
           {X : one_type}
           {x y : poly_act I (one_type_to_groupoid X)}
           (g : x = y)
  : poly_act_morphism_to_path g = g.
Proof.
  induction g.
  apply idpath.
Qed.

Definition poly_act_morphism_to_path_poly_act_groupoid
           {P : poly_code}
           {X : one_type}
           {x y : poly_act P (one_type_to_groupoid X)}
           (g : poly_act_morphism P (one_type_to_groupoid X) x y)
  : poly_act_morphism_to_path (poly_act_groupoid_to_path g) = g.
Proof.
  induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂ ].
  - apply idpath.
  - induction g.
    apply idpath.
  - induction x as [x | x], y as [y |y].
    + refine (_ @ IHP₁ _ _ g).
      simpl.
      etrans.
      {
        apply maponpaths.
        apply ii1_injectivity_maponpaths_inl.
      }
      apply idpath.
    + exact (fromempty g).
    + exact (fromempty g).
    + refine (_ @ IHP₂ _ _ g).
      simpl.
      etrans.
      {
        apply maponpaths.
        apply ii2_injectivity_maponpaths_inr.
      }
      apply idpath.
  - simpl.
    etrans.
    {
      do 2 apply maponpaths.
      apply maponpaths_pr2_pathsdirprod.
    }
    etrans.
    {
      apply maponpaths_2 ; apply maponpaths.
      apply maponpaths_pr1_pathsdirprod.
    }
    exact (pathsdirprod (IHP₁ _ _ (pr1 g)) (IHP₂ _ _ (pr2 g))).
Qed.

Definition path_groupoid_path_arg
           {Σ : hit_signature}
           {X : hit_path_algebra_one_types Σ}
           {P Q : poly_code}
           {l r : endpoint (point_constr Σ) P Q}
           {z : poly_act P (pr11 X : one_type)}
           (p : pr1 (sem_endpoint_grpd
                       l
                       (pr1 (hit_path_algebra_biadjunction Σ X)))
                       z
                -->
                pr1 (sem_endpoint_grpd
                       r
                       (pr1 (hit_path_algebra_biadjunction Σ X)))
                       z)
  : sem_endpoint_one_types l (pr1 X) z
    =
    sem_endpoint_one_types r (pr1 X) z.
Proof.
  refine (!(path_groupoid_endpoint _ _) @ _ @ path_groupoid_endpoint _ _).
  apply poly_act_groupoid_to_path.
  exact p.
Defined.

(* NEEDS TO BE CHANGED *)

Definition poly_path_groupoid_poly_act_morphism_to_path
           {A P Q : poly_code}
           {X : one_type}
           {a₁ a₂ : poly_act P (path_groupoid X : groupoid)}
           (c : poly_act A X → X)
           (e : endpoint A P Q)
           (w : a₁ = a₂)
  : sem_endpoint_grpd_data_functor_morphism
      e
      (prealg_path_groupoid_map A X c)
      (poly_act_morphism_to_path w)
    =
    poly_act_morphism_to_path
      (maponpaths
         (sem_endpoint_UU e _)
         w).
Proof.
  induction w.
  etrans.
  {
    apply maponpaths.
    exact (poly_act_morphism_to_path_idpath _).
  }
  simpl.
  etrans.
  {
    exact (functor_id
             (sem_endpoint_grpd e (path_groupoid X ,, prealg_path_groupoid_map A X c))
             a₁).
  }
  exact (!(poly_act_morphism_to_path_idpath (sem_endpoint_UU e _ a₁))).
Qed.

(*
Definition poly_path_groupoid_poly_act_morphism_to_path
           {P : poly_code}
           {X : one_type}
           {a₁ a₂ : poly_act P (path_groupoid X : groupoid)}
           (w : a₁ = a₂)
  : # ((poly_path_groupoid P) X : _ ⟶ _) (poly_act_morphism_to_path w)
    =
    maponpaths (pr1 ((poly_path_groupoid P) X)) w.
Proof.
  induction w.
  etrans.
  {
    apply maponpaths.
    exact (poly_act_morphism_to_path_idpath _).
  }
  exact (functor_id (poly_path_groupoid P X) _).
Qed.
 *)

Definition poly_act_morphism_to_path_inv
           {P : poly_code}
           {G : groupoid}
           {x y : poly_act P G}
           (p : x = y)
  : poly_act_morphism_to_path (! p)
    =
    poly_act_inverse (poly_act_morphism_to_path p).
Proof.
  induction p.
  induction P as [ A | | P₁ IHP₁ P₂ IHP₂ | P₁ IHP₁ P₂ IHP₂].
  - apply idpath.
  - simpl.
    refine (_ @ id_left _).
    rewrite (z_iso_inv_after_z_iso (id₁ x ,, _)).
    apply idpath.
  - induction x as [x  | x].
    + exact (IHP₁ x).
    + exact (IHP₂ x).
  - exact (pathsdirprod (IHP₁ (pr1 x)) (IHP₂ (pr2 x))).
Qed.

Definition sem_homot_endpoint_grpd_one_type
           (Σ : hit_signature)
           {X : hit_path_algebra_one_types Σ}
           {Q TR T : poly_code}
           {al ar : endpoint (point_constr Σ) Q TR}
           {l r : endpoint (point_constr Σ) Q T}
           (h : homot_endpoint
                  (path_left Σ) (path_right Σ)
                  al ar l r)
           (z : poly_act Q (pr11 X : one_type))
           (p : pr1 (sem_endpoint_grpd
                       al
                       (pr1 ((hit_path_algebra_biadjunction Σ) X)))
                    z
                -->
                pr1 (sem_endpoint_grpd
                       ar
                       (pr1 (hit_path_algebra_biadjunction Σ X)))
                    z)
  : sem_homot_endpoint_grpd
      h
      (pr1 ((hit_path_algebra_biadjunction Σ) X))
      (pr2 ((hit_path_algebra_biadjunction Σ) X))
      z
      p
    =
    poly_act_morphism_to_path
      (path_groupoid_endpoint
         l z
       @ sem_homot_endpoint_one_types
           h
           (pr1 X)
           (pr2 X)
           z
           (path_groupoid_path_arg p)
       @ !(path_groupoid_endpoint r z)).
Proof.
  induction h as [T e | T e₁ e₂ h IHh | T e₁ e₂ e₃ h₁ IHh₁ h₂ IHh₂
                  | T₁ T₂ e₁ e₂ e₃
                  | R₁ R₂ T e₁ e₂ e₃ | T e | T e
                  | P R e₁ e₂ | P R e₁ e₂
                  | T₁ T₂ e₁ e₂ e₃ e₄ h₁ IHh₁ h₂ IHh₂
                  | P₁ P₂ P₃ e₁ e₂ e₃
                  | W w T e
                  | j e | ].

  - refine (!_).
    etrans.
    {
      apply maponpaths.
      apply pathsinv0r.
    }
    exact (poly_act_morphism_to_path_idpath _).
  - refine (maponpaths _ IHh
            @ !(poly_act_morphism_to_path_inv
                  (path_groupoid_endpoint e₁ z
                   @ sem_homot_endpoint_one_types
                       h (pr1 X) (pr2 X) z
                       (path_groupoid_path_arg p)
                   @ ! path_groupoid_endpoint e₂ z))
              @ maponpaths poly_act_morphism_to_path _).
    etrans.
    {
      apply pathscomp_inv.
    }
    refine (_ @ !(path_assoc _ _ _)).
    apply maponpaths_2.
    etrans.
    {
      apply pathscomp_inv.
    }
    apply maponpaths_2.
    apply pathsinv0inv0.
  - refine (maponpaths (λ z, poly_act_compose z _) IHh₁ @ _).
    refine (maponpaths (λ z, poly_act_compose _ z) IHh₂ @ _).
    etrans.
    {
      apply poly_act_compose_poly_act_morphism_to_path.
    }
    apply maponpaths.
    refine (!(path_assoc _ _ _) @ _).
    apply maponpaths.
    refine (!(path_assoc _ _ _) @ _).
    refine (_ @ path_assoc _ _ _).
    apply maponpaths.
    do 2 refine (path_assoc _ _ _ @ _).
    apply maponpaths_2.
    refine (_ @ pathscomp0lid _).
    apply maponpaths_2.
    apply pathsinv0l.
  - simpl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply pathscomp_inv.
        }
        apply maponpaths_2.
        exact (!(maponpathsinv0 (sem_endpoint_UU e₃ (pr21 X)) _)).
      }
      do 2 refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply (maponpathscomp0 (sem_endpoint_UU e₃ (pr21 X))).
      }
      refine (!_).
      apply (maponpathscomp0 (sem_endpoint_UU e₃ (pr21 X))).
    }
    refine (!_).
    etrans.
    {
      apply maponpaths.
      exact IHh.
    }
    clear IHh.
    etrans.
    {
      apply poly_path_groupoid_poly_act_morphism_to_path.
    }
    apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      etrans.
      {
        apply maponpathscomp0.
      }
      apply maponpaths_2.
      apply maponpathscomp0.
    }
    etrans.
    {
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        exact (!(path_assoc _ _ _)).
      }
      apply maponpaths_2.
      apply path_assoc.
    }
    etrans.
    {
      pose (homotsec_natural'
              (λ z, path_groupoid_endpoint e₃ z)
              (path_groupoid_endpoint e₁ z))
        as q.
      cbn in q.
      do 2 apply maponpaths_2.
      exact (!q).
    }
    do 2 refine (!(path_assoc _ _ _) @ _).
    refine (!_).
    etrans.
    {
      apply maponpathscomp0.
    }
    apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      pose (homotsec_natural'
              (λ z, !(path_groupoid_endpoint e₃ z))
              (!(path_groupoid_endpoint e₂ z)))
        as q.
      cbn in q.
      exact q.
    }
    do 2 refine (path_assoc _ _ _ @ _).
    refine (!_).
    etrans.
    {
      apply maponpathscomp0.
    }
    apply maponpaths_2.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (!_).
      apply (homotsec_natural'
               (λ z, path_groupoid_endpoint e₃ z)
               (sem_homot_endpoint_one_types h (pr1 X) (pr2 X) z (path_groupoid_path_arg p))).
    }
    refine (!(path_assoc _ _ _) @ _).
    etrans.
    {
      apply maponpaths.
      apply pathsinv0r.
    }
    apply pathscomp0rid.
  - refine (!_).
    etrans.
    {
      apply maponpaths.
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply pathscomp_inv.
      }
      etrans.
      {
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply maponpathscomp0.
          }
          apply pathscomp_inv.
        }
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths.
          apply maponpathscomp.
        }
        apply pathsinv0r.
      }
      apply maponpaths_2.
      apply pathscomp0lid.
    }
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        refine (path_assoc _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply pathsinv0r.
        }
        apply pathscomp0lid.
      }
      apply pathsinv0r.
    }
    exact (poly_act_morphism_to_path_idpath _).
  - refine (!_).
    etrans.
    {
      refine (maponpaths (poly_act_morphism_to_path) _).
      etrans.
      {
        apply maponpaths_2.
        apply pathscomp0rid.
      }
      apply pathsinv0r.
    }
    exact (poly_act_morphism_to_path_idpath _).
  - refine (!_).
    etrans.
    {
      refine (maponpaths (poly_act_morphism_to_path) _).
      etrans.
      {
        refine (maponpaths (λ z, z @ _) _).
        apply maponpathsidfun.
      }
      apply pathsinv0r.
    }
    exact (poly_act_morphism_to_path_idpath _).
  - simpl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_pr1_pathsdirprod.
      }
      apply pathsinv0r.
    }
    apply poly_act_morphism_to_path_idpath.
  - simpl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_pr2_pathsdirprod.
      }
      apply pathsinv0r.
    }
    apply poly_act_morphism_to_path_idpath.
  - refine (pathsdirprod (IHh₁ @ !_) (IHh₂ @ !_)).
    + apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      apply maponpaths_pr1_pathsdirprod.
    + apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        apply pathsdirprod_concat.
      }
      apply maponpaths_pr2_pathsdirprod.
  - simpl.
    apply pathsdirprod.
    + refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              apply maponpaths_prod_path.
            }
            apply pathsdirprod_concat.
          }
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        apply maponpaths_pr1_pathsdirprod.
      }
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply poly_act_morphism_to_path_idpath.
    + refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            etrans.
            {
              apply maponpaths.
              apply maponpaths_prod_path.
            }
            apply pathsdirprod_concat.
          }
          etrans.
          {
            apply maponpaths.
            apply pathsdirprod_inv.
          }
          apply pathsdirprod_concat.
        }
        apply maponpaths_pr2_pathsdirprod.
      }
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply poly_act_morphism_to_path_idpath.
  - simpl.
    refine (!_).
    etrans.
    {
      apply pathscomp0rid.
    }
    apply maponpaths_for_constant_function.
  - refine (!_).
    etrans.
    {
      apply poly_act_morphism_to_path_path_groupoid.
    }
    pose (homotsec_natural
            (pr2 X j)
            (path_groupoid_endpoint e z))
      as h.
    etrans.
    {
      apply maponpaths.
      apply maponpaths_2.
      exact h.
    }
    clear h.
    etrans.
    {
      simpl.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        refine (!_).
        apply maponpathscomp0.
      }
      apply maponpaths.
      apply pathsinv0r.
    }
    etrans.
    {
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      refine (!(path_assoc _ _ _) @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        apply pathscomp_inv.
      }
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply (maponpathsinv0 (sem_endpoint_UU (path_right Σ j) (pr21 X))).
      }
      etrans.
      {
        refine (!_).
        apply (maponpathscomp0 (sem_endpoint_UU (path_right Σ j) (pr21 X))).
      }
      apply maponpaths.
      apply pathsinv0r.
    }
    apply idpath.
    (*
  - refine (!_).
    etrans.
    {
      apply poly_act_morphism_to_path_path_groupoid.
    }
    simpl.
    etrans.
    {
      apply maponpaths_2.
      exact (!(maponpathscomp0 (pr21 X) _ _)).
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply pathscomp_inv.
        }
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (maponpathsinv0 (pr21 X)).
        }
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply (maponpathsinv0 (pr21 X)).
        }
        exact (!(maponpathscomp0 (pr21 X) _ _)).
      }
      exact (!(maponpathscomp0 (pr21 X) _ _)).
    }
    etrans.
    {
      exact (!(maponpathscomp0 (pr21 X) _ _)).
    }
    apply maponpaths.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      exact IHh.
    }
    clear IHh.
    etrans.
    {
      exact (poly_path_groupoid_poly_act_morphism_to_path _).
    }
    refine (!_).
    etrans.
    {
      refine (path_assoc _ _ _ @ _).
      apply maponpaths_2.
      refine (!(path_assoc _ _ _) @ _).
      pose (homotsec_natural'
              (λ z, (poly_path_groupoid_is_id z))
              (path_groupoid_endpoint el z
               @ sem_homot_endpoint_one_types
                   h
                   (pr1 X) (pr2 X)
                   z
                   (path_groupoid_path_arg p)))
        as q.
      etrans.
      {
        apply maponpaths.
        exact (!(maponpathsidfun _)).
      }
      exact (!q).
    }
    refine (!(path_assoc _ _ _) @ _).
    etrans.
    {
      apply maponpaths.
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        pose (homotsec_natural'
                (λ z, (poly_path_groupoid_is_id z))
                (!(path_groupoid_endpoint er z)))
          as q.
        etrans.
        {
          apply maponpaths.
          exact (!(maponpathsidfun _)).
        }
        exact (!q).
      }
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    }
    etrans.
    {
      refine (!_).
      apply maponpathscomp0.
    }
    etrans.
    {
      apply maponpaths.
      refine (!_).
      apply path_assoc.
    }
    apply idpath.
     *)
  - refine (!_).
    etrans.
    {
      refine (maponpaths (poly_act_morphism_to_path) _).
      simpl.
      unfold path_groupoid_path_arg.
      refine (path_assoc _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        refine (path_assoc _ _ _ @ _).
        apply maponpaths_2.
        apply pathsinv0r.
      }
      refine (!(path_assoc _ _ _) @ _).
      refine (pathscomp0lid _ @ _).
      refine (!(path_assoc _ _ _) @ _).
      etrans.
      {
        apply maponpaths.
        apply pathsinv0r.
      }
      apply pathscomp0rid.
    }
    exact (poly_act_morphism_to_path_poly_act_groupoid _).
Qed.

Definition path_groupoid_is_hit_algebra
           (Σ : hit_signature)
           (X : hit_path_algebra_one_types Σ)
  : is_hit_algebra_one_types Σ X
    →
    is_hit_algebra_grpd Σ (hit_path_algebra_biadjunction Σ X).
Proof.
  intros HX i z p.
  specialize (HX i z (path_groupoid_path_arg p)).
  refine (sem_homot_endpoint_grpd_one_type _ _ _ _
          @ _
          @ !(sem_homot_endpoint_grpd_one_type _ _ _ _)).
  rewrite HX.
  apply idpath.
Qed.


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

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

Print Assumptions freeze.


Add LoadPath "somePath".

Require Export BES.

(*----------consistent consequences----------*)

Definition consistent_environment_rhs (E:BES)(R:propVar_relation)(x y:propVar) :=
  forall theta:environment, consistent_environment theta R ->
    [[rhs E x]]theta -> [[rhs E y]]theta.

Definition consistent_consequence (E:BES)(R:propVar_relation) : Prop :=
forall x y:propVar, R x y ->
  (rank E x=rank E y)
/\
  (bnd E x -> bnd E y -> consistent_environment_rhs E R x y).

Notation "'cc' E R" := (consistent_consequence E R)(at level 200).

Definition cc_max (E:BES)(x:propVar)(y:propVar):Prop :=
  exists R:propVar_relation, consistent_consequence E R /\ relates_bound R (flatten_genBES E) (flatten_genBES E) /\ R x y.

Notation "E |- x <, y" := (cc_max E x y)(at level 50).

Lemma cc_max_consistent_environment_has_cc: forall E:BES, forall theta:environment,
consistent_environment theta (cc_max E) ->
  forall x y:propVar, (E |- x <, y) ->
    exists R:propVar_relation,
      consistent_consequence E R /\ R x y /\ consistent_environment theta R.
Proof.
intros.
destruct H0 as [R H0].
destruct H0.
destruct H1.
exists R.
split;auto.
split;auto.
intro;intros.
apply (H x0);auto.
exists R.
split;auto.
Qed.

Lemma cc_max_is_cc : forall E:BES, consistent_consequence E (cc_max E).
Proof.
intros;intro;intros.
destruct H as [R H].
destruct H.
destruct H0.
destruct (H x y);auto.
split;auto.
intros;intro;intros.
specialize (cc_max_consistent_environment_has_cc E theta H6 x y).
intro.
assert (cc_max E x y).
  exists R;auto.
specialize (H8 H9).
destruct H9 as [R' H9].
destruct H9;destruct H10.
destruct (H9 x y);auto.
apply (H13 H4 H5);auto.
intro;intros.
apply (H6 x0);auto.
exists R';auto.
Qed.