Definition wtf (n : nat) : nat :=
  (match n with
       0 => (fun H : n = 0 => 0)
     | S n' => (fun H : n = S n' => 0)
   end) (eq_refl n).


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

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

Print Assumptions sub.


Require Import VerdiRaft.Raft.

Section NextIndexSafety.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition nextIndex_safety (net : network) : Prop :=
    forall h h',
      type (nwState net h) = Leader ->
      pred (getNextIndex (nwState net h) h') <= maxIndex (log (nwState net h)).

  Class nextIndex_safety_interface : Prop :=
    {
      nextIndex_safety_invariant :
        forall net,
          raft_intermediate_reachable net ->
          nextIndex_safety net
    }.
End NextIndexSafety.


Definition cong_eq :=
fun (A1 A2 : Type) (u1 v1 : A1) (u2 v2 : A2) (pA : A1 ≅ A2) (pu : u1 ≅ u2) (pv : v1 ≅ v2) =>
match pA with
| @heqPair _ _ _ _ pT pA0 =>
    let pA1 : transport eq_refl A1 = A2 :=
      Logic.eq_ind pT (fun pT0 : Type = Type => transport pT0 A1 = A2) pA0 eq_refl (K pT) in
    match pA1 in (_ = y) return (forall u3 v3 : y, u1 ≅ u3 -> v1 ≅ v3 -> (u1 = v1) ≅ (u3 = v3)) with
    | eq_refl =>
        fun (u3 v3 : A1) (pu0 : u1 ≅ u3) (pv0 : v1 ≅ v3) =>
        match pu0 with
        | @heqPair _ _ _ _ pA2 pu1 =>
            let pu2 : transport eq_refl u1 = u3 :=
              Logic.eq_ind pA2 (fun pA3 : A1 = A1 => transport pA3 u1 = u3) pu1 eq_refl (K pA2) in
            match pu2 in (_ = y) return ((u1 = v1) ≅ (y = v3)) with
            | eq_refl =>
                match pv0 with
                | @heqPair _ _ _ _ pA3 pv1 =>
                    let pv2 : transport eq_refl v1 = v3 :=
                      Logic.eq_ind pA3 (fun pA4 : A1 = A1 => transport pA4 v1 = v3) pv1 eq_refl
                        (K pA3) in
                    match pv2 in (_ = y) return ((u1 = v1) ≅ (u1 = y)) with
                    | eq_refl => heq_refl (u1 = v1)
                    end
                end
            end
        end
    end u2 v2 pu pv
end
     : forall (A1 A2 : Type) (u1 v1 : A1) (u2 v2 : A2),
       A1 ≅ A2 -> u1 ≅ u2 -> v1 ≅ v2 -> (u1 = v1) ≅ (u2 = v2).


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__8__2.
Require Export lemma__8__3.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__doublereverse.
Require Export lemma__equalanglessymmetric.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray5.
Require Export lemma__raystrict.
Require Export logic.
Definition lemma__equaltorightisright : forall A B C a b c, (euclidean__defs.Per A B C) -> ((euclidean__defs.CongA a b c A B C) -> (euclidean__defs.Per a b c)).
Proof.
intro A.
intro B.
intro C.
intro a.
intro b.
intro c.
intro H.
intro H0.
assert (* Cut *) (euclidean__defs.CongA A B C a b c) as H1.
- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric a b c A B C H0).
- assert (exists E F e f, (euclidean__defs.Out B A E) /\ ((euclidean__defs.Out B C F) /\ ((euclidean__defs.Out b a e) /\ ((euclidean__defs.Out b c f) /\ ((euclidean__axioms.Cong B E b e) /\ ((euclidean__axioms.Cong B F b f) /\ ((euclidean__axioms.Cong E F e f) /\ (euclidean__axioms.nCol A B C)))))))) as H2 by exact H1.
destruct H2 as [E H3].
destruct H3 as [F H4].
destruct H4 as [e H5].
destruct H5 as [f H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
assert (* Cut *) (euclidean__defs.Per A B F) as H21.
-- apply (@lemma__8__3.lemma__8__3 A B C F H H9).
-- assert (* Cut *) (euclidean__defs.Per F B A) as H22.
--- apply (@lemma__8__2.lemma__8__2 A B F H21).
--- assert (* Cut *) (euclidean__defs.Per F B E) as H23.
---- apply (@lemma__8__3.lemma__8__3 F B A E H22 H7).
---- assert (* Cut *) (euclidean__defs.Per E B F) as H24.
----- apply (@lemma__8__2.lemma__8__2 F B E H23).
----- assert (* Cut *) (euclidean__axioms.neq B E) as H25.
------ apply (@lemma__raystrict.lemma__raystrict B A E H7).
------ assert (* Cut *) (euclidean__axioms.neq E B) as H26.
------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B E H25).
------- assert (exists W, (euclidean__axioms.BetS E B W) /\ ((euclidean__axioms.Cong E B W B) /\ ((euclidean__axioms.Cong E F W F) /\ (euclidean__axioms.neq B F)))) as H27 by exact H24.
destruct H27 as [W H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
assert (* Cut *) (euclidean__axioms.neq b e) as H35.
-------- apply (@euclidean__axioms.axiom__nocollapse B E b e H25 H15).
-------- assert (* Cut *) (euclidean__axioms.neq e b) as H36.
--------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric b e H35).
--------- assert (* Cut *) (exists w, (euclidean__axioms.BetS e b w) /\ (euclidean__axioms.Cong b w e b)) as H37.
---------- apply (@lemma__extension.lemma__extension e b e b H36 H36).
---------- destruct H37 as [w H38].
destruct H38 as [H39 H40].
assert (* Cut *) (euclidean__axioms.Cong e b E B) as H41.
----------- assert (* Cut *) ((euclidean__axioms.Cong e b E B) /\ (euclidean__axioms.Cong E B e b)) as H41.
------------ apply (@lemma__doublereverse.lemma__doublereverse B E b e H15).
------------ destruct H41 as [H42 H43].
exact H42.
----------- assert (* Cut *) (euclidean__axioms.Cong b w E B) as H42.
------------ apply (@lemma__congruencetransitive.lemma__congruencetransitive b w e b E B H40 H41).
------------ assert (* Cut *) (euclidean__axioms.Cong E B B W) as H43.
------------- assert (* Cut *) ((euclidean__axioms.Cong B E B W) /\ ((euclidean__axioms.Cong B E W B) /\ (euclidean__axioms.Cong E B B W))) as H43.
-------------- apply (@lemma__congruenceflip.lemma__congruenceflip E B W B H31).
-------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
exact H47.
------------- assert (* Cut *) (euclidean__axioms.Cong b w B W) as H44.
-------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive b w E B B W H42 H43).
-------------- assert (* Cut *) (euclidean__axioms.Cong b f B F) as H45.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric b B F f H17).
--------------- assert (* Cut *) (euclidean__axioms.Cong e f E F) as H46.
---------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric e E F f H19).
---------------- assert (* Cut *) (euclidean__axioms.Cong e w E W) as H47.
----------------- apply (@euclidean__axioms.cn__sumofparts e b w E B W H41 H44 H39 H29).
----------------- assert (* Cut *) (euclidean__axioms.Cong f w F W) as H48.
------------------ apply (@euclidean__axioms.axiom__5__line e b w f E B W F H44 H46 H45 H39 H29 H41).
------------------ assert (* Cut *) (euclidean__axioms.Cong e b B W) as H49.
------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e b E B B W H41 H43).
------------------- assert (* Cut *) (euclidean__axioms.Cong B W b w) as H50.
-------------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B b w W H44).
-------------------- assert (* Cut *) (euclidean__axioms.Cong e b b w) as H51.
--------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e b B W b w H49 H50).
--------------------- assert (* Cut *) (euclidean__axioms.Cong e b w b) as H52.
---------------------- assert (* Cut *) ((euclidean__axioms.Cong b e w b) /\ ((euclidean__axioms.Cong b e b w) /\ (euclidean__axioms.Cong e b w b))) as H52.
----------------------- apply (@lemma__congruenceflip.lemma__congruenceflip e b b w H51).
----------------------- destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H56.
---------------------- assert (* Cut *) (euclidean__axioms.Cong e f W F) as H53.
----------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e f E F W F H46 H33).
----------------------- assert (* Cut *) (euclidean__axioms.Cong W F w f) as H54.
------------------------ assert (* Cut *) ((euclidean__axioms.Cong W F w f) /\ (euclidean__axioms.Cong w f W F)) as H54.
------------------------- apply (@lemma__doublereverse.lemma__doublereverse f w F W H48).
------------------------- destruct H54 as [H55 H56].
exact H55.
------------------------ assert (* Cut *) (euclidean__axioms.Cong e f w f) as H55.
------------------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e f W F w f H53 H54).
------------------------- assert (* Cut *) (euclidean__axioms.neq b f) as H56.
-------------------------- apply (@lemma__raystrict.lemma__raystrict b c f H13).
-------------------------- assert (* Cut *) (euclidean__defs.Per e b f) as H57.
--------------------------- exists w.
split.
---------------------------- exact H39.
---------------------------- split.
----------------------------- exact H52.
----------------------------- split.
------------------------------ exact H55.
------------------------------ exact H56.
--------------------------- assert (* Cut *) (euclidean__defs.Out b f c) as H58.
---------------------------- apply (@lemma__ray5.lemma__ray5 b c f H13).
---------------------------- assert (* Cut *) (euclidean__defs.Per e b c) as H59.
----------------------------- apply (@lemma__8__3.lemma__8__3 e b f c H57 H58).
----------------------------- assert (* Cut *) (euclidean__defs.Per c b e) as H60.
------------------------------ apply (@lemma__8__2.lemma__8__2 e b c H59).
------------------------------ assert (* Cut *) (euclidean__defs.Out b e a) as H61.
------------------------------- apply (@lemma__ray5.lemma__ray5 b a e H11).
------------------------------- assert (* Cut *) (euclidean__defs.Per c b a) as H62.
-------------------------------- apply (@lemma__8__3.lemma__8__3 c b e a H60 H61).
-------------------------------- assert (* Cut *) (euclidean__defs.Per a b c) as H63.
--------------------------------- apply (@lemma__8__2.lemma__8__2 c b a H62).
--------------------------------- exact H63.
Qed.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import Bvector.
(* Require Export BigNumPrelude. *)
Require Import Int31 Cyclic31.
Require Export Int63Native.
Require Export Int63Op.
Require Import Psatz.

Local Open Scope Z_scope.

(* Taken from BigNumPrelude *)

 Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p.
 Proof.
  intros p x Hle;destruct (Z_le_gt_dec 0 p).
  apply  Zdiv_le_lower_bound;auto with zarith.
  replace (2^p) with 0.
  destruct x;compute;intro;discriminate.
  destruct p;trivial;discriminate.
 Qed.

 Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y.
 Proof.
  intros p x y H;destruct (Z_le_gt_dec 0 p).
  apply Zdiv_lt_upper_bound;auto with zarith.
  apply Z.lt_le_trans with y;auto with zarith.
  rewrite <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;auto with zarith.
  assert (0 < 2^p);auto with zarith.
  replace (2^p) with 0.
  destruct x;change (0<y);auto with zarith.
  destruct p;trivial;discriminate.
 Qed.

(* Int63Axioms *)

Definition wB := (2^(Z_of_nat size)).

Notation "[| x |]" := (to_Z x)  (at level 0, x at level 99) : int63_scope.

Notation "[+| c |]" :=
   (interp_carry 1 wB to_Z c)  (at level 0, c at level 99) : int63_scope.

Notation "[-| c |]" :=
   (interp_carry (-1) wB to_Z c)  (at level 0, c at level 99) : int63_scope.

Notation "[|| x ||]" :=
   (zn2z_to_Z wB to_Z x)  (at level 0, x at level 99) : int63_scope.

Local Open Scope int63_scope.
Local Open Scope Z_scope.

(* Bijection : int63 <-> Bvector size *)

Theorem to_Z_inj : forall x y, [|x|] = [|y|] -> x = y.
Proof Ring31.Int31_canonic.

Theorem of_to_Z : forall x, of_Z ([|x|]) = x.
Proof. exact phi_inv_phi. Qed.

(* Comparisons *)
Theorem eqb_refl x : (x == x)%int = true.
Proof. now rewrite Ring31.eqb31_eq. Qed.

Theorem ltb_spec x y : (x < y)%int = true <-> [|x|] < [|y|].
Proof.
  unfold ltb. rewrite spec_compare, <- Z.compare_lt_iff.
  change (phi x ?= phi y) with ([|x|] ?= [|y|]).
  case ([|x|] ?= [|y|]); intuition; discriminate.
Qed.

Theorem leb_spec x y : (x <= y)%int = true <-> [|x|] <= [|y|].
Proof.
  unfold leb. rewrite spec_compare, <- Z.compare_le_iff.
  change (phi x ?= phi y) with ([|x|] ?= [|y|]).
  case ([|x|] ?= [|y|]); intuition; discriminate.
Qed.

(** Specification of logical operations *)
Lemma lsl_spec_alt p :
  forall x, [| addmuldiv31_alt p x 0 |] = ([|x|] * 2^(Z.of_nat p)) mod wB.
Proof.
  induction p as [ |p IHp]; simpl; intro x.
  - rewrite Z.mul_1_r. symmetry. apply Zmod_small. apply phi_bounded.
  - rewrite IHp, phi_twice, Zmult_mod_idemp_l, Z.double_spec,
            Z.mul_comm, Z.mul_assoc, Z.mul_comm,
            Z.pow_pos_fold, Zpos_P_of_succ_nat, <- Z.add_1_r, Z.pow_add_r.
    * reflexivity.
    * apply Zle_0_nat.
    * exact Z.le_0_1.
Qed.

Theorem lsl_spec x p : [| x << p |] = ([|x|] * 2^[|p|]) mod wB.
Proof.
  unfold lsl.
  rewrite addmuldiv31_equiv, lsl_spec_alt, Nat2Z.inj_abs_nat, Z.abs_eq.
  - reflexivity.
  - now destruct (phi_bounded p).
Qed.

Lemma div_greater (p x:int) (H:Z.of_nat Int31.size <= [|p|]) : [|x|] / 2 ^ [|p|] = 0.
Proof.
  apply Z.div_small. destruct (phi_bounded x) as [H1 H2]. split; auto.
  apply (Z.lt_le_trans _ _ _ H2). apply Z.pow_le_mono_r; auto.
  exact Z.lt_0_2.
Qed.

Theorem lsr_spec x p : [|x >> p|] = [|x|] / 2 ^ [|p|].
Proof.
  unfold lsr. case_eq (p < 31%int31)%int; intro Heq.
  - assert (H : [|31%int31 - p|] = 31 - [|p|]).
    * rewrite spec_sub. rewrite Zmod_small; auto.
      split.
      + rewrite ltb_spec in Heq. assert (forall x y, x < y -> 0 <= y - x) by (intros;lia); auto.
      + assert (H:forall x y z, 0 <= y /\ x < z -> x - y < z) by (intros;lia).
        apply H. destruct (phi_bounded p). destruct (phi_bounded (31%int31)). split; auto.
    * rewrite spec_add_mul_div.
      + rewrite Z.add_0_l. change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. replace (31 - (31 - [|p|])) with [|p|] by ring. apply Zmod_small. split.
        ++ apply div_le_0. now destruct (phi_bounded x).
        ++ apply div_lt. apply phi_bounded.
      + change (phi (31%int31 - p)) with [|31%int31 - p|]. rewrite H. assert (forall x y, 0 <= y -> x - y <= x) by (intros;lia). apply H0. now destruct (phi_bounded p).
  - rewrite div_greater; auto.
    destruct (Z.le_gt_cases [|31%int31|] [|p|]); auto.
    rewrite <- ltb_spec in H. rewrite H in Heq. discriminate.
Qed.

Lemma bit_testbit x i : bit x i = Z.testbit [|x|] [|i|].
Admitted.
(* Proof. *)
(*   case_eq [|i|]. *)
(*   - simpl. change 0 with [|0|]. intro Heq. apply Ring31.Int31_canonic in Heq. subst i. *)
(*     unfold bit.  *)

Lemma Z_pos_xO_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~0 < 2 ^ (i+1).
Proof. rewrite Pos2Z.inj_xO, Z.pow_add_r; auto using Z.le_0_1; lia. Qed.

Lemma Z_pos_xI_pow i x (Hi:0 <= i) : Z.pos x < 2 ^ i <-> Z.pos x~1 < 2 ^ (i+1).
Proof. rewrite Pos2Z.inj_xI, Z.pow_add_r; auto using Z.le_0_1; lia. Qed.

Lemma pow_nonneg i (Hi : 1 <= 2 ^ i) : 0 <= i.
Proof.
  destruct (Z.le_gt_cases 0 i); auto.
  rewrite (Z.pow_neg_r _ _ H) in Hi. lia.
Qed.

Lemma pow_pos i (Hi : 1 < 2 ^ i) : 0 < i.
Proof.
  destruct (Z.lt_trichotomy 0 i) as [H|[H|H]]; auto.
  - subst i. lia.
  - rewrite (Z.pow_neg_r _ _ H) in Hi. lia.
Qed.

Lemma pos_land_bounded : forall x y i,
  Z.pos x < 2 ^ i -> Z.pos y < 2 ^ i -> Z.of_N (Pos.land x y) < 2 ^ i.
Proof.
  induction x as [x IHx|x IHx| ]; intros [y|y| ] i; auto.
  - simpl. intro H.
    assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia).
    generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xI_pow; auto. intros H1 H2.
    assert (H3:=IHx _ _ H1 H2).
    unfold Pos.Nsucc_double. case_eq (Pos.land x y).
    * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia.
    * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xI_pow; auto.
      replace (i - 1 + 1) with i by ring. clear. lia.
  - simpl. intro H.
    assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~1)); auto; lia).
    generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2.
    assert (H3:=IHx _ _ H1 H2).
    unfold Pos.Ndouble. case_eq (Pos.land x y).
    * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia.
    * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto.
      replace (i - 1 + 1) with i by ring. clear. lia.
  - simpl. intro H.
    assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia).
    generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- Z_pos_xI_pow, <- Z_pos_xO_pow; auto. intros H1 H2.
    assert (H3:=IHx _ _ H1 H2).
    unfold Pos.Ndouble. case_eq (Pos.land x y).
    * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia.
    * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto.
      replace (i - 1 + 1) with i by ring. clear. lia.
  - simpl. intro H.
    assert (H4:0 <= i - 1) by (assert (H4:0 < i); try lia; apply pow_pos; apply (Z.le_lt_trans _ (Z.pos x~0)); auto; lia).
    generalize H. replace i with ((i-1)+1) at 1 2 by ring. rewrite <- !Z_pos_xO_pow; auto. intros H1 H2.
    assert (H3:=IHx _ _ H1 H2).
    unfold Pos.Ndouble. case_eq (Pos.land x y).
    * intros _. eapply Z.le_lt_trans; [ |exact H]. clear. lia.
    * intros p Hp. revert H3. rewrite Hp, N2Z.inj_pos, Z_pos_xO_pow; auto.
      replace (i - 1 + 1) with i by ring. clear. lia.
  - simpl. intros H _. apply (Z.le_lt_trans _ (Z.pos x~0)); lia.
  - simpl. intros H _. apply (Z.le_lt_trans _ 1); lia.
Qed.

Lemma Z_land_bounded i : forall x y,
  0 <= x < 2 ^ i -> 0 <= y < 2 ^ i -> 0 <= Z.land x y < 2 ^ i.
Proof.
  intros [ |p|p] [ |q|q]; auto.
  - intros [_ H1] [_ H2]. simpl. split.
    * apply N2Z.is_nonneg.
    * now apply pos_land_bounded.
Admitted.

Theorem land_spec x y i : bit (x land y) i = bit x i && bit y i.
Proof.
  rewrite !bit_testbit. change (x land y) with (land31 x y). unfold land31.
  rewrite phi_phi_inv. rewrite Zmod_small.
  - apply Z.land_spec.
  - split.
    * rewrite Z.land_nonneg. left. now destruct (phi_bounded x).
    * now destruct (Z_land_bounded _ _ _ (phi_bounded x) (phi_bounded y)).
Qed.

Axiom lor_spec: forall x y i, bit (x lor y) i = bit x i || bit y i.

Axiom lxor_spec: forall  x y i, bit (x lxor y) i = xorb (bit x i) (bit y i).

(** Specification of basic opetations *)

(* Arithmetic modulo operations *)

(* Remarque : les axiomes seraient plus simple si on utilise of_Z a la place :
   exemple : add_spec : forall x y, of_Z (x + y) = of_Z x + of_Z y. *)

Axiom add_spec : forall x y, [|x + y|] = ([|x|] + [|y|]) mod wB.

Axiom sub_spec : forall x y, [|x - y|] = ([|x|] - [|y|]) mod wB.

Axiom mul_spec : forall x y, [| x * y |]  = [|x|] * [|y|] mod wB.

Axiom mulc_spec : forall x y, [|x|] * [|y|] = [|fst (mulc x y)|] * wB + [|snd (mulc x y)|].

Axiom div_spec : forall x y, [|x / y|] = [|x|] / [|y|].

Axiom mod_spec : forall x y, [|x \% y|] = [|x|] mod [|y|].

(** Iterators *)

Axiom foldi_cont_gt : forall A B f from to cont,
  (to < from)%int = true -> foldi_cont (A:=A) (B:=B) f from to cont = cont.

Axiom foldi_cont_eq : forall A B f from to cont,
  from = to -> foldi_cont (A:=A) (B:=B) f from to cont = f from cont.

Axiom foldi_cont_lt : forall A B f from to cont,
  (from < to)%int = true->
  foldi_cont (A:=A) (B:=B) f from to cont =
  f from (fun a' => foldi_cont f (from + 1%int) to cont a').

Axiom foldi_down_cont_lt : forall A B f from downto cont,
  (from < downto)%int = true -> foldi_down_cont (A:=A) (B:=B) f from downto cont = cont.

Axiom foldi_down_cont_eq : forall A B f from downto cont,
  from = downto -> foldi_down_cont (A:=A) (B:=B) f from downto cont = f from cont.

Axiom foldi_down_cont_gt : forall A B f from downto cont,
  (downto < from)%int = true->
  foldi_down_cont (A:=A) (B:=B) f from downto cont =
  f from (fun a' => foldi_down_cont f (from-1) downto cont a').

(** Print *)

Axiom print_int_spec : forall x, x = print_int x.

(** Axioms on operations which are just short cut *)

Axiom compare_def_spec : forall x y, compare x y = compare_def x y.

Axiom head0_spec  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|head0 x|]) * [|x|] < wB.

Axiom tail0_spec  : forall x, 0 < [|x|] ->
         (exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|tail0 x|]))%Z.

Axiom addc_def_spec : forall x y, (x +c y)%int = addc_def x y.

Axiom addcarryc_def_spec : forall x y, addcarryc x y = addcarryc_def x y.

Axiom subc_def_spec : forall x y, (x -c y)%int = subc_def x y.

Axiom subcarryc_def_spec : forall x y, subcarryc x y = subcarryc_def x y.

Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y.

Axiom diveucl_21_spec :  forall a1 a2 b,
   let (q,r) := diveucl_21 a1 a2 b in
   ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|].

Axiom addmuldiv_def_spec : forall p x y,
  addmuldiv p x y = addmuldiv_def p x y.

(*
   Local Variables:
   coq-load-path: ((rec "../../.." "SMTCoq"))
   End:
*)


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

Benedikt Ahrens, Ralph Matthes

SubstitutionSystems

2015

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

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

Contents :

- Construction of a substitution system from an initial algebra
- Proof that the substitution system constructed from an
  initial algebra is an initial substitution system

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is very close to the homonymous file in the parent directory
basically, the changes in SimplifiedHSS.SubstitutionSystems are propagated

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

Set Kernel Term Sharing.

Require Import UniMath.Foundations.PartD.

Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.yoneda.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.PointedFunctors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.PointedFunctorsComposition.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.CategoryTheory.RightKanExtension.
Require Import UniMath.SubstitutionSystems.GenMendlerIteration.
Require Import UniMath.CategoryTheory.BicatOfCatsElementary.
Require Import UniMath.SubstitutionSystems.Notation.
Local Open Scope subsys.

Local Open Scope cat.

Local Coercion alg_carrier : algebra_ob >-> ob.

Section category_Algebra.

Context  (C : category) (CP : BinCoproducts C).

Local Notation "'EndC'":= ([C, C]) .
Local Notation "'Ptd'" := (category_Ptd C).

Let CPEndC : BinCoproducts EndC := BinCoproducts_functor_precat _ _ CP.
Let EndEndC := [EndC, EndC].
Let CPEndEndC:= BinCoproducts_functor_precat _ _ CPEndC: BinCoproducts EndEndC.

Variable KanExt : ∏ Z : Ptd, GlobalRightKanExtensionExists _ _ (U Z) C.

Variable H : Presignature C C C.
Let θ := theta H.

Definition Const_plus_H (X : EndC) : functor EndC EndC
  := BinCoproduct_of_functors _ _ CPEndC (constant_functor _ _ X) H.
  (* := sum_of_functors CPEndC (constant_functor _ _ X) H. *)

Definition Id_H :  functor [C, C] [C, C]
 := Const_plus_H (functor_identity _ : EndC).

Let Alg : category := FunctorAlg Id_H.

Variable IA : Initial Alg.
Definition SpecializedGMIt (Z : Ptd) (X : EndC)
  :  ∏ (G : functor [C, C] [C, C])
       (ρ : [C, C] ⟦ G X, X ⟧)
       (θ : functor_composite Id_H (ℓ (U Z)) ⟹ functor_composite (ℓ (U Z)) G),
     ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), X ⟧,
            # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h
            =
            θ (` (InitialObject IA)) · # G h · ρ
   :=
  SpecialGenMendlerIteration _ _ IA EndC X _ (KanExt Z) .

Definition θ_in_first_arg (Z: Ptd)
  : functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z
    ⟹
    functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z
  := nat_trans_fix_snd_arg _ _ _ _ _ θ Z.

Definition InitAlg : Alg := InitialObject IA.

Definition ptdInitAlg : Ptd := ptd_from_alg InitAlg.

Local Lemma aux_iso_1_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (functor_composite Id_H (ℓ (U Z)))
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))))
     (λ X : [C, C],
      BinCoproductOfArrows [C, C]
        (CPEndC (functor_composite (U Z) (functor_identity C))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (runitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  intros X X' α.
  apply nat_trans_eq_alt.
  intro c.
  simpl.
  unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
  etrans; [apply BinCoproductOfArrows_comp |].
  etrans.
  2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. }
  apply maponpaths_12.
  - etrans; [ apply id_left |].
    apply pathsinv0.
    apply id_right.
  - rewrite id_right.
    rewrite id_left.
    rewrite (functor_id (H X)).
    apply pathsinv0, id_left.
Qed.

Definition aux_iso_1 (Z : Ptd)
  : EndEndC
    ⟦ functor_composite Id_H (ℓ (U Z)),
      BinCoproductObject
           (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
              (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))⟧.
Proof.
  use tpair.
  - intro X.
    exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (runitor_CAT (U Z))
            (nat_trans_id (θ_source H (X⊗Z):functor C C))).
  - exact (aux_iso_1_is_nat_trans Z).
Defined.

Local Lemma aux_iso_1_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z))) )
     (functor_composite Id_H (ℓ (U Z)))
     (λ X : [C, C],
      BinCoproductOfArrows [C, C]
        (CPEndC (functor_composite (functor_identity C) (U Z))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (lunitor_CAT (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  intros X X' α.
  apply nat_trans_eq_alt.
  intro c; simpl.
  unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
  etrans; [apply BinCoproductOfArrows_comp |].
  etrans.
  2: { eapply pathsinv0. apply BinCoproductOfArrows_comp. }
  apply maponpaths_12.
  - rewrite id_right.
    apply pathsinv0.
    apply id_right.
  - rewrite (functor_id (H X)).
    do 2 rewrite id_left.
    apply id_right.
Qed.

Local Definition aux_iso_1_inv (Z: Ptd)
  : EndEndC
    ⟦ BinCoproductObject
           (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
              (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
      functor_composite Id_H (ℓ (U Z)) ⟧.
Proof.
  use tpair.
  - intro X.
    exact (BinCoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (lunitor_CAT (U Z))
           (nat_trans_id (θ_source H (X⊗Z):functor C C))).
  - exact (aux_iso_1_inv_is_nat_trans Z).
Defined.

(*
Definition G_Thm15 (X : EndC) := coproduct_functor _ _ CPEndC
                       (constant_functor _ _ X)
                       H.
 *)

Local Lemma aux_iso_2_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C](θ_target H) Z))) )
     (functor_composite (ℓ (U Z))
        (Const_plus_H (U Z)))
     (λ X : [C, C],
      nat_trans_id
        (BinCoproductObject (CPEndC (U Z) ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
  intros X X' α.
  rewrite (@id_left EndC).
  rewrite (@id_right EndC).
  apply nat_trans_eq_alt.
  intro c; simpl.
  unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
  apply (maponpaths_12 (BinCoproductOfArrows _ _ _)).
  + apply idpath.
  + unfold functor_fix_snd_arg_mor; simpl.
    revert c.
    apply nat_trans_eq_pointwise.
    apply maponpaths.
    apply nat_trans_eq_alt.
    intro c.
    simpl.
    rewrite (functor_id X).
    apply id_left.
Qed.

Local Definition aux_iso_2_inv (Z : Ptd)
  : EndEndC
    ⟦ BinCoproductObject
         (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
                    (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)),
      functor_composite (ℓ (U Z) )   (Const_plus_H (U Z)) ⟧.
Proof.
  use tpair.
  - intro X.
    exact (nat_trans_id ((@BinCoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) )
             : functor C C)).
  - exact (aux_iso_2_inv_is_nat_trans Z).
Defined.

Definition θ'_Thm15 (Z: Ptd)
  : EndEndC
    ⟦ BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
      BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
            (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧
  := BinCoproductOfArrows
   EndEndC (CPEndEndC _ _) (CPEndEndC _ _)
   (identity (constant_functor EndC _ (U Z): functor_category EndC EndC))
   (θ_in_first_arg Z).

Definition ρ_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : [C, C] ⟦ BinCoproductObject (CPEndC (U Z) (H `InitAlg)), `InitAlg ⟧
  := @BinCoproductArrow
   EndC _ _  (CPEndC (U Z)
   (H (alg_carrier _ InitAlg))) (alg_carrier _ InitAlg) f
   (BinCoproductIn2 (CPEndC _ _) · (alg_map _ InitAlg)).

Definition SpecializedGMIt_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : ∃! h : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), pr1 InitAlg ⟧,
           # (ℓ (U Z)) (alg_map Id_H (InitialObject IA)) · h
           =
           pr1 ((aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z)) (` (InitialObject IA)) ·
           # (Const_plus_H (U Z)) h · ρ_Thm15 Z f
  := SpecializedGMIt Z (pr1 InitAlg) (Const_plus_H (U Z))
     (ρ_Thm15 Z f) (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z).

Definition bracket_Thm15 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
  : [C, C] ⟦ ℓ (U Z) (` (InitialObject IA)), `InitAlg ⟧
  := pr1 (pr1 (SpecializedGMIt_Thm15 Z f)).

Notation "⦃ f ⦄" := (bracket_Thm15 _ f) (at level 0).

(* we prove the individual components for ease of compilation *)
Lemma bracket_Thm15_ok_part1 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧):
 f = # (pr1 (ℓ (U Z))) (η InitAlg) · ⦃f⦄.
Proof.
  apply nat_trans_eq_alt.
  intro c.
  assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))).
  assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ =>
               (((aux_iso_1_inv Z):(_ ⟹ _)) _)· m) h_eq);
  clear h_eq.
  simpl in h_eq'.
  assert (h_eq1' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ =>
               (BinCoproductIn1 (CPEndC _ _))· m) h_eq');
  clear h_eq'.
  assert (h_eq1'_inst := nat_trans_eq_pointwise h_eq1' c);
  clear h_eq1'.
(* match goal right in the beginning in contrast with earlier approach - suggestion by Benedikt *)
  match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         intermediate_path f end.

  - clear h_eq1'_inst.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data ; simpl.
    repeat rewrite <- assoc .
    apply BinCoproductIn1Commutes_right_in_ctx_dir.
    simpl.
    rewrite id_left.
    apply BinCoproductIn1Commutes_right_in_ctx_dir.
    simpl.
    rewrite id_left.
    apply BinCoproductIn1Commutes_right_in_ctx_dir.
    rewrite (@id_left EndC).
    rewrite id_left.
    apply BinCoproductIn1Commutes_right_in_ctx_dir.
    rewrite (@id_left EndC).
    apply BinCoproductIn1Commutes_right_dir.
    apply idpath.
  - rewrite <- h_eq1'_inst.
    clear h_eq1'_inst.
    apply BinCoproductIn1Commutes_left_in_ctx_dir.
    unfold nat_trans_id; simpl.
    rewrite id_left.
    repeat rewrite (id_left EndEndC).
    repeat rewrite (id_left EndC).
    unfold functor_fix_snd_arg_ob.
    repeat rewrite assoc.
(*    apply maponpaths. *)
    apply idpath.
Qed.

Lemma bracket_Thm15_ok_part2 (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧):
 (theta H) ((alg_carrier _  InitAlg) ⊗ Z) ·  # H ⦃f⦄ · τ InitAlg
  =
   # (pr1 (ℓ (U Z))) (τ InitAlg) · ⦃f⦄.
Proof.
  apply nat_trans_eq_alt.
  intro c.
  assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))).
  assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ =>
                  (((aux_iso_1_inv Z):(_⟹_)) _)· m) h_eq);
  clear h_eq.
 (*        simpl in h_eq'. (* until here same as in previous lemma *) *)

  assert (h_eq2' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ =>
                (BinCoproductIn2 (CPEndC _ _))· m) h_eq').
  clear h_eq'.
  assert (h_eq2'_inst := nat_trans_eq_pointwise h_eq2' c).
  clear h_eq2'.
  match goal with |[ H1 : _  = ?f |- _ = _   ] =>
                   intermediate_path f end.
  - clear h_eq2'_inst.
    apply BinCoproductIn2Commutes_right_in_ctx_dir.
    unfold aux_iso_1; simpl.
    rewrite id_right.
    rewrite id_left.
    do 3 rewrite <- assoc.
    apply BinCoproductIn2Commutes_right_in_ctx_dir.
    unfold nat_trans_id; simpl. rewrite id_left.
    apply BinCoproductIn2Commutes_right_in_ctx_dir.
    unfold nat_trans_fix_snd_arg_data.
    apply BinCoproductIn2Commutes_right_in_double_ctx_dir.
    rewrite <- assoc.
    apply maponpaths.
    eapply pathscomp0. 2: apply assoc.
    apply maponpaths.
    apply pathsinv0.
    apply BinCoproductIn2Commutes.

(* alternative with slightly less precise control: *)
(*            do 4 rewrite <- assoc. *)
(*            apply BinCoproductIn2Commutes_right_in_ctx_dir. *)
(*            rewrite id_left. *)
(*            apply BinCoproductIn2Commutes_right_in_ctx_dir. *)
(*            apply BinCoproductIn2Commutes_right_in_ctx_dir. *)
(*            unfold nat_trans_fix_snd_arg_data. *)
(*            rewrite id_left. *)
(*            apply BinCoproductIn2Commutes_right_in_double_ctx_dir. *)
(*            do 2 rewrite <- assoc. *)
(*            apply maponpaths. *)
(*            apply maponpaths. *)
(*            apply pathsinv0. *)
(*            apply BinCoproductIn2Commutes. *)
(* *)

  - rewrite <- h_eq2'_inst. clear h_eq2'_inst.
    apply BinCoproductIn2Commutes_left_in_ctx_dir.
    repeat rewrite id_left.
    apply assoc.
Qed.

Lemma bracket_Thm15_ok (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧):
 bracket_property_parts (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f ⦃f⦄.
Proof.
  split.
  + exact (bracket_Thm15_ok_part1 Z f).
  + exact (bracket_Thm15_ok_part2 Z f).
Qed.

Lemma bracket_Thm15_ok_cor (Z: Ptd)(f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧):
 bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f (bracket_Thm15 Z f).
Proof.
  apply whole_from_parts.
  apply bracket_Thm15_ok.
Qed.

Local Lemma foo' (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧) :
 ∏ t : ∑ h : [C, C] ⟦ functor_composite (U Z) (pr1  InitAlg),
                         pr1 InitAlg ⟧,
       bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h,
   t
   =
   tpair
     (λ h : [C, C]
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
       bracket_property (nat_trans_fix_snd_arg _ _ _ _ _ θ Z) _ f h)
      ⦃f⦄ (bracket_Thm15_ok_cor Z f).
Proof.
  intros [h' h'_eq].
  apply subtypePath.
  - intro.
    unfold bracket_property.
    apply (isaset_nat_trans (homset_property C)).
  - simpl.
    apply parts_from_whole in h'_eq.
(*    destruct h'_eq as [h'_eq1 h'_eq2]. *)
    unfold bracket_Thm15.
    apply path_to_ctr.
    apply nat_trans_eq_alt.
    intro c; simpl.
    unfold coproduct_nat_trans_data.
    repeat rewrite (@id_left EndC).
    rewrite id_right.
    repeat rewrite <- @assoc.
    etrans.
    2: { eapply pathsinv0. apply postcompWithBinCoproductArrow. }
    apply BinCoproductArrowUnique.
    + destruct h'_eq as [h'_eq1 _ ]. (*clear h'_eq2.*)
      simpl.
      rewrite id_left.
      assert (h'_eq1_inst := nat_trans_eq_pointwise h'_eq1 c);
        clear h'_eq1.
      simpl in h'_eq1_inst.
      unfold coproduct_nat_trans_in1_data in h'_eq1_inst; simpl in h'_eq1_inst.
      rewrite <- @assoc in h'_eq1_inst.
      etrans.
      { eapply pathsinv0; exact h'_eq1_inst. }
      clear h'_eq1_inst.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      apply BinCoproductIn1Commutes_right_dir.
      apply idpath.
    + destruct h'_eq as [_ h'_eq2]. (*clear h'_eq2.*)
      assert (h'_eq2_inst := nat_trans_eq_pointwise h'_eq2 c);
        clear h'_eq2.
      simpl in h'_eq2_inst.
      unfold coproduct_nat_trans_in2_data in h'_eq2_inst; simpl in h'_eq2_inst.
      apply pathsinv0 in h'_eq2_inst.
      rewrite <- assoc in h'_eq2_inst.
      etrans; [ exact h'_eq2_inst |]. clear h'_eq2_inst.
      apply BinCoproductIn2Commutes_right_in_ctx_dir.
      apply BinCoproductIn2Commutes_right_in_double_ctx_dir.
      unfold nat_trans_fix_snd_arg_data; simpl.
      do 2 rewrite <- assoc.
      apply maponpaths.
      rewrite <- assoc.
      apply maponpaths.
      apply pathsinv0.
      apply BinCoproductIn2Commutes.
Qed.

Definition bracket_for_InitAlg : bracket θ InitAlg.
Proof.
  intros Z f.
  use tpair.
  - use tpair.
    + exact (bracket_Thm15 Z f).
    + exact (bracket_Thm15_ok_cor Z f).
       (* B: better to prove the whole outside, and apply it here *)
     (* when the first components were not opaque, the following proof
        became extremely slow *)
  - simpl; apply foo'.
Defined.

Definition InitHSS : hss_category CP H.
Proof.
 (*
  red. (* FORBIDDEN, otherwise universe problem when checking the definition *)
  unfold hss_precategory; simpl.
*)
  exists (InitAlg).
  exact bracket_for_InitAlg.
Defined.

Local Definition Ghat : EndEndC := Const_plus_H (pr1 InitAlg).

Definition constant_nat_trans (C' D : category)
   (d d' : D)
   (m : d --> d')
    : [C', D] ⟦constant_functor C' D d, constant_functor C' D d'⟧.
Proof.
  exists (λ _, m).
  abstract (
    intros ? ? ? ;
    intermediate_path m ;
    [
    apply id_left |
    apply pathsinv0 ;
  apply id_right] ).
Defined.

Definition thetahat_0 (Z : Ptd) (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧):
EndEndC
⟦ BinCoproductObject
    (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
       (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)),
BinCoproductObject
  (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
             (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)) ⟧ .
Proof.
  exact (BinCoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _)
                           (constant_nat_trans _ _ _ _ f)
                           (θ_in_first_arg Z)).
Defined.

Local Definition iso1' (Z : Ptd) :  EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
 BinCoproductObject
    (CPEndEndC (constant_functor [C, C] [C, C] (U Z))
               (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_source H) Z)) ⟧.
Proof.
  exact (aux_iso_1 Z).
Defined.

Local Lemma is_nat_trans_iso2' (Z : Ptd) :
   is_nat_trans
     (pr1 (BinCoproductObject
        (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
           (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z))))
     (functor_composite (ℓ (U Z)) Ghat)
     (λ X : [C, C],
      nat_trans_id
        (BinCoproductObject
           (CPEndC
              ((constant_functor [C, C] [C, C] (pr1 InitAlg)) X)
              ((θ_target H) (X ⊗ Z)))
         : functor C C)).
Proof.
  intros X X' α.
  rewrite (@id_left EndC).
  rewrite (@id_right EndC).
  apply nat_trans_eq_alt.
  intro c; simpl.
  unfold coproduct_nat_trans_data, coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
  apply (maponpaths_12 (BinCoproductOfArrows _ _ _)).
  - apply idpath.
  - unfold functor_fix_snd_arg_mor; simpl.
    revert c.
    apply nat_trans_eq_pointwise.
    apply maponpaths.
    apply nat_trans_eq_alt.
    intro c.
    simpl.
    rewrite (functor_id X).
    apply id_left.
Qed.

Local Definition iso2' (Z : Ptd) : EndEndC ⟦
  BinCoproductObject
  (CPEndEndC (constant_functor [C, C] [C, C] (pr1 InitAlg))
             (functor_fix_snd_arg [C, C] Ptd [C, C] (θ_target H) Z)),
  functor_composite (ℓ (U Z)) Ghat ⟧.
Proof.
    use tpair.
  - intro X.
    exact (nat_trans_id ((@BinCoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) )
            : functor C C)).
  - exact (is_nat_trans_iso2' Z).
Defined.

Definition thetahat (Z : Ptd)  (f : [C, C] ⟦ U Z, U (ptd_from_alg InitAlg) ⟧)
           : EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
                     functor_composite (ℓ (U Z)) (Ghat) ⟧.
Proof.
  exact (iso1' Z · thetahat_0 Z f · iso2' Z).
Defined.

Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op").

Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC X.

Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg --> X) :
  functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg))
   ⟹
  functor_composite (functor_opp (ℓ (U Z))) (Yon X) .
Proof.
  use tpair.
  - intro Y.
    intro a.
    exact (a · b).
  - abstract (
    intros ? ? ?; simpl;
    apply funextsec;
    intro;
    unfold yoneda_objects_ob; simpl;
    unfold compose;
    simpl;
    apply nat_trans_eq; [ apply homset_property |];
    simpl; intro; apply assoc').
Defined.

Lemma ishssMor_InitAlg (T' : hss CP H) :
  @ishssMor C CP H
        InitHSS T'
           (InitialArrow IA (pr1 T') : @algebra_mor EndC Id_H InitAlg T' ).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  set (β0 := InitialArrow IA (pr1 T')).
  match goal with | [|- _ · ?b = _ ] => set (β := b) end.
  set ( rhohat := BinCoproductArrow (CPEndC _ _ )  β (tau_from_alg T')
                  :  pr1 Ghat T' --> T').
  set (X:= SpecializedGMIt Z _ Ghat rhohat (thetahat Z f)).
  intermediate_path (pr1 (pr1 X)).
  - set (TT:= fusion_law _ _ IA _ (pr1 InitAlg) T' _ (KanExt Z)).
    set (Psi := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Const_plus_H (U Z)) (ρ_Thm15 Z f)
                             (aux_iso_1 Z · θ'_Thm15 Z · aux_iso_2_inv Z) ).
    set (T2 := TT Psi).
    set (T3 := T2 (ℓ (U Z)) (KanExt Z)).
    set (Psi' := ψ_from_comps _ (Id_H) _ _ (ℓ (U Z)) (Ghat) (rhohat)
                             (iso1' Z · thetahat_0 Z f · iso2' Z) ).
    set (T4 := T3 Psi').
    set (Φ := (Phi_fusion Z T' β)).
    set (T5 := T4 Φ).
    intermediate_path (Φ _ (fbracket InitHSS Z f)).
    + apply idpath.
    + eapply pathscomp0.
      2: { apply T5.
      (* hypothesis of fusion law *)
      apply funextsec. intro t.
      simpl.
      unfold compose. simpl.
      apply nat_trans_eq_alt.
      simpl.
      intro c.
      rewrite id_right.
      rewrite id_right.
      (* should be decomposed into two diagrams *)
      apply BinCoproductArrow_eq_cor.
      * (* first diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply BinCoproductIn1Commutes_left_in_ctx_dir.
        apply BinCoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply BinCoproductIn1Commutes_left_in_ctx_dir.
        apply BinCoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply BinCoproductIn1Commutes_left_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply BinCoproductIn1Commutes_left_in_ctx_dir.
        rewrite <- assoc.
        apply maponpaths.
        apply BinCoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply BinCoproductIn1Commutes_right_dir.
        apply idpath.

      * (* second diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply BinCoproductIn2Commutes_left_in_ctx_dir.
        apply BinCoproductIn2Commutes_right_in_ctx_dir.
        rewrite (@id_left EndC).
        apply BinCoproductIn2Commutes_left_in_ctx_dir.
        apply BinCoproductIn2Commutes_right_in_ctx_dir.
        simpl.
        unfold nat_trans_fix_snd_arg_data.
        repeat rewrite <- assoc.
        apply maponpaths.
        apply BinCoproductIn2Commutes_left_in_ctx_dir.
        apply BinCoproductIn2Commutes_right_in_ctx_dir.
        simpl.
        assert (H_nat_inst := functor_comp H t β).
        assert (H_nat_inst_c := nat_trans_eq_pointwise H_nat_inst c); clear H_nat_inst.
        {
          match goal with |[ H1 : _  = ?f |- _ = _· ?g · ?h  ] =>
             intermediate_path (f·g·h) end.
          + clear H_nat_inst_c.
            simpl.
            repeat rewrite <- assoc.
            apply maponpaths.
            apply BinCoproductIn2Commutes_left_in_ctx_dir.
            simpl.
            unfold coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
            assert (Hyp := τ_part_of_alg_mor _ CP _ _ _ (InitialArrow IA (pr1 T'))).
            assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp.
            simpl in Hyp_c.
            etrans; [ eapply pathsinv0; exact Hyp_c |].
            clear Hyp_c.
            apply maponpaths.
            apply pathsinv0.
            apply BinCoproductIn2Commutes.
          + rewrite <- H_nat_inst_c.
            apply idpath.
        }
      }
      apply cancel_postcomposition.
      apply idpath.
  - apply pathsinv0.
    apply path_to_ctr.
    (* now a lot of serious verification work to be done *)
    apply nat_trans_eq_alt.
    intro c.
    simpl.
    rewrite id_right.
    (* look at type: *)
(*        match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply BinCoproductArrow_eq_cor.
    + repeat rewrite <- assoc.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data,
             coproduct_nat_trans_in2_data,
             coproduct_nat_trans_data.
      rewrite id_left.
      apply BinCoproductIn1Commutes_right_in_ctx_dir.
      simpl.
      repeat rewrite <- assoc.
      etrans.
      2: { apply maponpaths. apply BinCoproductIn1Commutes_right_in_ctx_dir.
           rewrite id_left. apply BinCoproductIn1Commutes_right_dir.
           apply idpath. }
      do 2 rewrite assoc.
      etrans.
      { apply cancel_postcomposition.
        assert (ptd_mor_commutes_inst := ptd_mor_commutes _ (ptd_from_alg_mor _ CP H β0) ((pr1 Z) c)).
        apply ptd_mor_commutes_inst. }
      assert (fbracket_η_inst := fbracket_η T' (f · #U (ptd_from_alg_mor _ CP H β0))).
      assert (fbracket_η_inst_c := nat_trans_eq_pointwise fbracket_η_inst c); clear fbracket_η_inst.
      apply (!fbracket_η_inst_c).
    + (* now the difficult case *)
      repeat rewrite <- assoc.
      apply BinCoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply BinCoproductIn2Commutes_right_in_ctx_dir.
      unfold nat_trans_fix_snd_arg_data.
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.
      etrans.
      2: { apply maponpaths.
           apply BinCoproductIn2Commutes_right_in_ctx_dir.
           rewrite <- assoc.
           apply maponpaths.
           apply BinCoproductIn2Commutes_right_dir.
           apply idpath.
      }
      do 2 rewrite assoc.
      etrans.
      { apply cancel_postcomposition.
        eapply pathsinv0.
        assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ CP H _ _ β0).
        assert (τ_part_of_alg_mor_inst_Zc :=
                  nat_trans_eq_pointwise τ_part_of_alg_mor_inst ((pr1 Z) c));
          clear τ_part_of_alg_mor_inst.
        apply τ_part_of_alg_mor_inst_Zc.
      }
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.
      etrans.
      { apply maponpaths.
        rewrite assoc.
        eapply pathsinv0.
        assert (fbracket_τ_inst := fbracket_τ T' (f · #U (ptd_from_alg_mor _  CP H β0))).
        assert (fbracket_τ_inst_c := nat_trans_eq_pointwise fbracket_τ_inst c); clear fbracket_τ_inst.
        apply fbracket_τ_inst_c.
      }
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply cancel_postcomposition.
      assert (Hyp:
                 ((# (pr1 (ℓ(U Z))) (# H β))·
                 (theta H) ((alg_carrier _  T') ⊗ Z)·
                 # H (fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0)))
                 =
                 θ (tpair (λ _ : functor C C, ptd_obj C) (alg_carrier _ (InitialObject IA)) Z) ·
                 # H (# (pr1 (ℓ(U Z))) β ·
                 fbracket T' _ (f · #U(ptd_from_alg_mor C CP H β0))))).
      2: { assert (Hyp_c := nat_trans_eq_pointwise Hyp c); clear Hyp.
           exact Hyp_c. }
      clear c. clear X. clear rhohat.
      rewrite (functor_comp H).
      rewrite assoc.
      apply cancel_postcomposition.
      fold θ.
      apply nat_trans_eq_alt.
      intro c.
      assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ _ _ H θ _ _ β Z c).
      etrans ; [exact θ_nat_1_pointwise_inst | ].
      clear θ_nat_1_pointwise_inst.
      simpl.
      apply maponpaths.
      rewrite horcomp_id_prewhisker.
      apply idpath.
 Qed.

Definition hss_InitMor : ∏ T' : hss CP H, hssMor InitHSS T'.
Proof.
  intro T'.
  exists (InitialArrow IA (pr1 T')).
  apply ishssMor_InitAlg.
Defined.

Lemma hss_InitMor_unique (T' : hss_category CP H):
  ∏ t : hss_precategory CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'.
Proof.
  intro t.
  apply (invmap (hssMor_eq1 _ _ _ _ _ _ _)).
  apply (@InitialArrowUnique _ IA (pr1 T') (pr1 t)).
Qed.

Lemma isInitial_InitHSS : isInitial (hss_category CP H) InitHSS.
Proof.
  use make_isInitial.
  intro T.
  exists (hss_InitMor T).
  apply hss_InitMor_unique.
Defined.

Lemma InitialHSS : Initial (hss_category CP H).
Proof.
  use (make_Initial InitHSS).
  apply isInitial_InitHSS.
Defined.

End category_Algebra.


(** * Python Language *)
(** This file describes the relevent portion of the Python Language needed for
    this compiler.  In python, expression can either be evaluated on their own or
    assigned to a variable.  Expressions on their own do not change the state of the program.
    An example Python program is:
        field1 = 10
        4 * 10
        field2 = field1 * 4
        field3 = field1 + field2
        field1 + field3
    *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Import imports.

(* DECLARATIONS OF PYTHON TYPES *)

(* Numerical expressions *)
Inductive PyNumExpr : Type :=
  | PyNatLit (n : prog_value) (* Natural number literals *)
  | PyIdNat (s : string) (* ID of a natural number stored in the program state *)
  | PyArrayValue (s : string) (n : nat) (* Natural number stored in a vector *)
  | PyAdd (a1 : PyNumExpr) (a2 : PyNumExpr) (* Adding two natural numbers *)
  | PySub (a1 : PyNumExpr) (a2 : PyNumExpr) (* Subtracting two natural numbers *)
  | PyMulti (a1 : PyNumExpr) (a2 : PyNumExpr) (* Multiplying two natural numbers *)
  .

(* Values that result in a bool *)
Inductive PyBoolExpr : Type :=
  | PyBinTrue (* True *)
  | PyBinFalse (* False *)
  | PyIdBool (s : string) (* ID of a boolean stored in the program state *)
  | PyUnaryOp (b : PyBoolExpr) (* Unary Op on a boolean *)
  | PyLe (a1 : PyNumExpr) (a2 : PyNumExpr) (* Less than op on two natural numbers *)
  | PyEq (a1 : PyNumExpr) (a2 : PyNumExpr) (* Equal op on two natural numbers *)
  | PyNotEq (a1 : PyNumExpr) (a2 : PyNumExpr) (* Not equal op on two natural numbers *)
  | PyAnd (b1 : PyBoolExpr) (b2 : PyBoolExpr) (* And op on two booleans *)
  | PyOr (b1 : PyBoolExpr) (b2 : PyBoolExpr) (* Or op on two booleans *)
  .

(* Expressions from the python language *)
Inductive PyExpr : Type :=
  | Py_Num_Expr (a : PyNumExpr)
  | Py_Bin_Expr (b : PyBoolExpr)
  | Py_Enc_Expr (e : PyExpr).

(* Commands from the Python language *)
Inductive PyCommand : Type :=
  | PyAssign (x : string) (a : PyExpr)
  | PyStat (e : PyExpr)
  | PySeq (c1 c2 : PyCommand).

(* EVALUATIONS OF PYTHON TYPES *)

(* Evaluation of numerical expressions *)
Fixpoint PyEvalNum (st : state) (a : PyNumExpr) : prog_value :=
  match a with
  | PyNatLit l => l
  | PyIdNat s => match st s with
              | pNat n => pNat n
              | _ => pNull
              end
  | PyArrayValue s n => match st s with
                         | pList v => getValueList v n
                         | _ => pNull
                         end
  | PyAdd a1 a2 => pNat (pullOutNat (PyEvalNum st a1) + pullOutNat (PyEvalNum st a2))
  | PySub a1 a2 => pNat (pullOutNat (PyEvalNum st a1) - pullOutNat (PyEvalNum st a2))
  | PyMulti a1 a2 => pNat (pullOutNat (PyEvalNum st a1) * pullOutNat (PyEvalNum st a2))
  end.

(* Evaluation of bool expressions *)
Fixpoint PyEvalBin (st : state) (b : PyBoolExpr) : prog_value :=
  match b with
  | PyBinTrue => pBool true
  | PyBinFalse => pBool false
  | PyIdBool s => match st s with
                 | pBool b => pBool b
                 | _ => pNull
                 end
  | PyUnaryOp b => pBool (negb (pullOutBool (PyEvalBin st b)))
  | PyLe a1 a2 => pBool (leb (pullOutNat (PyEvalNum st a1)) (pullOutNat (PyEvalNum st a2)))
  | PyEq a1 a2 => pBool (Nat.eqb (pullOutNat (PyEvalNum st a1)) (pullOutNat (PyEvalNum st a2)))
  | PyNotEq a1 a2 => pBool (negb (Nat.eqb (pullOutNat (PyEvalNum st a1)) (pullOutNat (PyEvalNum st a2))))
  | PyAnd b1 b2 => pBool (andb (pullOutBool (PyEvalBin st b1)) (pullOutBool (PyEvalBin st b2)))
  | PyOr b1 b2 => pBool (orb (pullOutBool (PyEvalBin st b1)) (pullOutBool (PyEvalBin st b2)))
  end.

(* Evaluation of expressions *)
Fixpoint PyEval (st : state) (a : PyExpr) : prog_value :=
  match a with
  | Py_Num_Expr a => PyEvalNum st a
  | Py_Bin_Expr b => PyEvalBin st b
  | Py_Enc_Expr e => PyEval st e
  end.

(* OPERATIONAL SEMANTICS OF PYTHON COMMANDS *)

(* Execution of commands *)
Inductive PythonProgram : PyCommand -> state -> state -> Prop :=
  | Py_Assign  : forall st a1 n x,
      PyEvalNum st a1 = n ->
      (PyAssign x (Py_Num_Expr (PyNatLit n))) / st \\ st & { x --> n }
  | Py_Stat  : forall st a1 n,
      PyEvalNum st a1 = n ->
      (PyStat (Py_Num_Expr (PyNatLit n))) / st \\ st
  | Py_Seq : forall c1 c2 st st' st'',
      c1 / st \\ st' ->
      c2 / st' \\ st'' ->
      (PySeq c1 c2) / st \\ st''
  where "c1 '/' st '\\' st'" := (PythonProgram c1 st st').


Require Import Coq.Program.Equality.
Require Import Coq.omega.Omega.
Require Import FJ_tactics.
Require Import Coq.Lists.List.
Require Import Containers.
Require Import Functors.
Require Import Polynomial.
Require Import Base.

Section Arith.

  Inductive Arith (a : Set) : Set :=
  | Lit (n : nat)
  | Add (a1 a2 : a).

  (* Global Instance FunctorArith : Functor Arith := *)
  (*   {| fmap := fun a b f e => match e with *)
  (*                             | Lit n => Lit b n *)
  (*                             | Add a1 a2 => Add b (f a1) (f a2) *)
  (*                             end *)
  (*   |}. *)
  (* Proof. *)
  (*   - now destruct a. *)
  (*   - now destruct a. *)
  (* Defined. *)

  (* Inductive AllArith (a : Set) (p : a -> Prop) : Arith a -> Prop := *)
  (* | ALit {n : nat} : AllArith a p (Lit a n) *)
  (* | AAdd {a1 a2 : a} : p a1 -> p a2 -> AllArith a p (Add a a1 a2). *)

  (* Global Instance PFunctorArith : PFunctor Arith := *)
  (*   {| All := AllArith |}. *)
  (* Proof. *)
  (*   intros ? ? ? ? xs; destruct xs; split; inversion 1; now constructor. *)
  (* Defined. *)

  Global Instance Arith_Iso : Iso Arith (K nat :+: Id :*: Id) :=
    {| fromIso := fun A x => match x with
                               | Lit n => inl n
                               | Add x y => inr (x,y)
                             end;
       toIso   := fun A x => match x with
                               | inl n => Lit _ n
                               | inr (x,y) => Add _ x y
                             end
    |}.
  Proof.
    intros; destruct a; reflexivity.
    intros; destruct a as [n|[x y]]; reflexivity.
  Defined.

  Global Instance Arith_Container : Container Arith :=
    ContainerIso Arith_Iso.

  Variable F : Set -> Set.
  Context `{spf_F : SPF F}.
  Let Exp := Fix F.
  Context {Sub_Arith_F : Arith :<: F}.

  (* Constructor + Universal Property. *)
  Definition lit (n : nat) : Exp := inject Arith F (Lit _ n).
  Definition add (m n : Exp) : Exp :=  inject Arith F (Add _ m n).

  (* (* Induction Principles for Arith. *) *)
  (* Definition ind_alg_Arith *)
  (*   (P : Fix F -> Prop) *)
  (*   (Hlit : forall n, P (lit n)) *)
  (*   (Hadd : forall m n, P m -> P n -> P (add m n)) *)
  (*   : PAlgebra (inject Arith F) P := *)
  (*   fun xs Axs => *)
  (*     match Axs in AllArith _ _ xs *)
  (*           return P (inject Arith F xs) with *)
  (*     | ALit n           => Hlit n *)
  (*     | AAdd a1 a2 p1 p2 => Hadd a1 a2 p1 p2 *)
  (*     end. *)

  (* Induction Principles for Arith. *)
  Definition ind_alg_Arith
    (P : Fix F -> Prop)
    (Hlit : forall n, P (lit n))
    (Hadd : forall m n, P m -> P n -> P (add m n))
      : PAlgebra (inject Arith F) P :=
    fun xs => match xs return (All P xs -> P (inject Arith F xs)) with
                | Lit n => fun Axs => Hlit n
                | Add m n => fun Axs => Hadd m n (Axs (inl _ tt)) (Axs (inr _ tt))
                (* | Add m n => fun Axs => Hadd m n (Axs PAdd1) (Axs PAdd2) *)
              end.

End Arith.

Section Depth.

  Definition Arith_depthOf (R : Set) (rec : R -> depthOfR)
    (e : Arith R) : depthOfR :=
    match e with
      | Lit n   => 0
      | Add m n => 1 + max (rec m) (rec n)
    end.

  Global Instance MAlgebra_depthOf_Arith T :
    FAlgebra DepthOfName T depthOfR Arith :=
    {| f_algebra := Arith_depthOf T |}.

End Depth.

Section Size.

  Definition Arith_sizeOf (R : Set) (rec : R -> sizeOfR)
    (e : Arith R) : sizeOfR :=
    match e with
      | Lit n   => 1
      | Add m n => 1 + rec m + rec n
    end.

  Global Instance MAlgebra_sizeOf_Arith T :
    FAlgebra SizeOfName T sizeOfR Arith :=
    {| f_algebra := Arith_sizeOf T |}.

End Size.

Section DepthSize.

  Variable F : Set -> Set.
  Context `{spf_F : SPF F}.
  Context {Sub_Arith_F : Arith :<: F}.
  Context {WF_Sub_Arith_F : WF_Functor _ _ Sub_Arith_F}.

  Context {depthOf_F : forall R, FAlgebra DepthOfName R nat F}.
  Context {WF_depthOf_F : forall R, WF_FAlgebra DepthOfName _ _ Arith F
    (MAlgebra_depthOf_Arith _) (depthOf_F R)}.

  Context {sizeOf_F : forall R, FAlgebra SizeOfName R nat F}.
  Context {WF_sizeOf_F : forall R, WF_FAlgebra SizeOfName _ _ Arith F
    (MAlgebra_sizeOf_Arith _) (sizeOf_F R)}.

  Context {depthSizePAlg : FPAlgebra (DepthSizeP F) in_t}.

  Ltac arithAlgs :=
    repeat
      match goal with
      | |- context[depthOf ?F (inject ?A ?F ?x)] =>
        replace (depthOf F (inject Arith F x)) with
        (f_algebra DepthOfName id (inj (fmap (depthOf F) x)))
          by (unfold inject, depthOf; rewrite fold_computation, wf_functor; auto)
      | |- context[sizeOf ?F (inject ?A ?F ?x)] =>
        replace (sizeOf F (inject Arith F x)) with
        (f_algebra SizeOfName id (inj (fmap (sizeOf F) x)))
          by (unfold inject, sizeOf; rewrite fold_computation, wf_functor; auto)
      end; simpl;
    rewrite ?(@wf_mixin nat nat Arith F _ _ _ (WF_depthOf_F nat)); simpl;
    rewrite ?(@wf_mixin nat nat Arith F _ _ _ (WF_sizeOf_F nat)); simpl.

  Arguments id {A} x /.

  Global Instance Arith_DepthSize : FPAlgebra (DepthSizeP F) (inject Arith F).
  Proof.
    constructor; unfold Algebra; intros.
    apply ind_alg_Arith; unfold DepthSizeP, lit, add; simpl; intros.
    - arithAlgs; omega.
    - arithAlgs.
      destruct (Max.max_spec (depthOf F m) (depthOf F n))
        as [[_ Heq]|[_ Heq]]; rewrite Heq; clear Heq; try omega.
  Qed.

End DepthSize.


From HoTT Require Export HoTT.

Local Set Default Proof Mode "Classic".

Set Universe Polymorphism.

(** This file is based on the paper "Generalizations of Hedberg's Theorem"
    by Kraus, Escardó, Coquand and Altenkirch. *)

(** TODO:
    1. bool -> nat is separated
    2. funext -> separated -> isSet
    3. isSet <-> || x = y || -> x = y
    4. ||X|| -> X <-> constant endomap
    5. fix f is prop
*)

(** * 2 Preliminaries *)

(* Definition 1 *)
(* Print decidable_equality. *)
(* ===> fun A : U => forall x y : A, (x = y) + (x <> y) : U -> U *)

Definition const {A B : U} (f : A -> B) : U :=
  forall x y : A, f x = f y.

Definition collapsible (A : U) : U :=
  {f : A -> A & const f}.

Definition path_collapsible (A : U) : U :=
  forall x y : A, collapsible (x = y).

(** * 3 Hedberg's Theorem *)

(* Lemma 1 *)
Lemma decidable_equality_path_collapsible :
  forall A : U,
    decidable_equality A -> path_collapsible A.
Proof.
  unfold decidable_equality, path_collapsible, collapsible.
  intros A DE x y.
  esplit. Unshelve. all: cycle 1.
    intro p. destruct (DE x y) as [q | q].
      exact q.
      destruct (q p).
    unfold const. intros p q. destruct (DE x y).
      refl.
      destruct (n p).
Defined.

(* Lemma 2 *)
Lemma path_collapsible_isSet :
  forall A : U,
    path_collapsible A -> isSet A.
Proof.
  unfold path_collapsible, collapsible, const, isSet.
  intros A f x y p q.
  assert (Hp : p = cat (pr1' (f x y) p) (inv (pr1' (f y y) (refl y)))).
    destruct p. destruct (f x x). cbn. rewrite cat_inv_r. refl.
  assert (Hq : q = cat (pr1' (f x y) q) (inv (pr1' (f y y) (refl y)))).
    destruct q. destruct (f x x). cbn. rewrite cat_inv_r. refl.
  rewrite Hp, Hq. destruct (f x y) as [f' c]. cbn.
  rewrite (c p q). refl.
Defined.

(* Theorem 1 (Hedberg) *)
Lemma decidable_equality_isSet :
  forall A : U,
    decidable_equality A -> isSet A.
Proof.
  intros. apply path_collapsible_isSet.
  apply decidable_equality_path_collapsible.
  assumption.
Defined.

Lemma isSet_path_collapsible :
  forall A : U,
    isSet A -> path_collapsible A.
Proof.
  unfold isSet, path_collapsible, collapsible, const.
  intros A SA x y.
  exists id. intros p q. apply SA.
Defined.

Lemma isProp_collapsible :
  ~ forall A : U,
      isProp (collapsible A).
Proof.
  unfold isProp, collapsible, const.
  intros X.
  assert (H1 : const (fun b : bool => true)).
    compute. refl.
  assert (H2 : const (fun b : bool => false)).
    compute. refl.
  specialize (X bool (| _, H1 |) (| _, H2 |)).
  apply sigma_eq_elim in X. cbn in X. destruct X as [p _].
  apply neq_false_true. exact (inv (happly p true)).
Defined.

(* TODO *) Lemma isProp_path_collapsible :
  forall A : U,
    isProp (path_collapsible A).
Proof.
  unfold isProp, path_collapsible, collapsible, const.
  intros A f g.
  apply funext. intro x. apply funext. intro y.
  apply sigma_eq_intro.
  esplit. Unshelve. all: cycle 1.
    destruct (f x y) as [f' cf], (g x y) as [g' cg]. cbn.
      apply funext. intro p. apply path_collapsible_isSet. exact f.
    repeat (apply funext; intro). destruct (f x y), (g x y). cbn.
      rewrite transport_pi. apply path_collapsible_isSet.
Abort.

(* TODO *) Lemma equiv_path_collapsible_isSet :
  path_collapsible = isSet.
Proof.
  apply funext. intro A. apply ua. unfold equiv.
  exists (path_collapsible_isSet A).
  apply qinv_isequiv. unfold qinv.
  exists (isSet_path_collapsible A).
  unfold homotopy, comp, id; split.
    intro SA. repeat (apply funext; intro). apply isSet_type1. assumption.
    unfold path_collapsible, collapsible, const, isSet_path_collapsible,
      path_collapsible_isSet.
      {
        intros. repeat (apply funext; intro).
        apply sigma_eq_intro.
Abort.

(* Definition 2 *)
Definition stable (A : U) : U :=
  ~ ~ A -> A.

Definition separated (A : U) : U :=
  forall x y : A, ~ ~ x = y -> x = y.

Lemma decidable_stable :
  forall A : U,
    decidable A -> stable A.
Proof.
  unfold decidable, stable. intros A [a | x] f.
    exact a.
    destruct (f x).
Defined.

Lemma stable_not_decidable :
  ~ forall A : U, stable A -> decidable A.
Proof.
Abort.

Lemma separated_path_collapsible :
  forall A : U,
    separated A -> path_collapsible A.
Proof.
  unfold separated, path_collapsible, collapsible, const.
  intros A s x y.
  esplit. Unshelve. all: cycle 1.
    intro p. apply s. intro. destruct (X p).
    intros p q. cbn. apply ap. apply funext. intro. destruct (x0 p).
Defined.

(* Lemma 3 *)
Lemma separated_isSet :
  forall A : U,
    separated A -> isSet A.
Proof.
  intros A H. apply path_collapsible_isSet, separated_path_collapsible, H.
Defined.

(* Definition 3 *)
(* Print trunc_rec. *)
(* ===> forall A B : U, isProp B -> (A -> B) -> trunc A -> B *)

Lemma isProp_pCont :
  forall A : U,
    isProp (pCont A).
Proof.
  unfold pCont. intros A f g.
  apply funext. intro P. apply funext. intro PP. apply funext. intro h.
  apply PP.
Defined.

(*
Set Universe Polymorphism.

Section lift.

Universe i j.

Definition LiftProp (A : U@{i}) (PA : isProp A) : U@{j} :=
  Eval hnf in let enforce_lt := U@{i} : U@{j} in A.

End lift.
Axiom resize : forall {A : U}, isProp A -> U.
Axiom equiv_resize : forall (A : U) (PA : isProp A), resize PA = A.
Axiom resize_comp :
  forall (A : U) (PA : isProp A),
    resize PA = A.
*)

(* Proposition 1 *)
Lemma trunc_pCont :
  forall A : U,
    trunc A = pCont A.
Proof.
  intro. apply isProp_iff_eq.
    apply isProp_trunc.
    apply isProp_pCont.
    intro a. unfold pCont. intros P PP f. revert a. apply trunc_rec.
      assumption.
      exact f.
    intro a. eapply pCont_rec.
      apply isProp_trunc.
      apply trunc'.
      Fail exact a. (* Universe inconsistency *)
Admitted.

(* Definition 4 *)
Definition hstable (A : U) : U :=
  trunc A -> A.

Definition hseparated (A : U) : U :=
  forall x y : A, trunc (x = y) -> x = y.

Lemma isProp_hstable :
  ~ forall A : U, isProp (hstable A).
Proof.
  unfold isProp, hstable.
  intro f. specialize (f bool (fun _ => true) (fun _ => false)).
  apply happly in f.
    apply neq_false_true. apply inv. assumption.
    exact (trunc' false).
Defined.

Lemma separated_hseparated :
  forall A : U,
    separated A -> hseparated A.
Proof.
  unfold separated, hseparated.
  intros A f x y p. apply f. intro H.
  cut empty.
    destruct 1.
    revert p. apply trunc_rec.
      apply isProp_empty.
      intro p. destruct (H p).
Defined.

(* Theorem 2 *)
Lemma hseparated_path_collapsible :
  forall A : U,
    hseparated A -> path_collapsible A.
Proof.
  unfold hseparated, path_collapsible, collapsible.
  intros A hs x y.
  exists (fun p => hs _ _ (trunc' p)).
  compute. intros p q. apply ap, path.
Defined.

Lemma isSet_hseparated :
  forall A : U,
    isSet A -> hseparated A.
Proof.
  unfold isSet, hseparated.
  intros A SA x y p.
  revert p. apply trunc_rec.
    unfold isProp. apply SA.
    intro p. exact p.
Defined.

Lemma path_collapsible_hseparated :
  forall A : U,
    path_collapsible A -> hseparated A.
Proof.
  intros. apply isSet_hseparated, path_collapsible_isSet. assumption.
Defined.

Lemma hseparated_isSet :
  forall A : U,
    hseparated A -> isSet A.
Proof.
  intros. apply path_collapsible_isSet, hseparated_path_collapsible.
  assumption.
Defined.

(** Having propositional truncation gives us some extensionality, as we
    don't need functional extensionality to prove that separated types
    are h-separated. *)

(** * 4 Collapsibility implies H-Stability *)

Definition fixpoint {A : U} (f : A -> A) : U :=
  {x : A & x = f x}.

(* Proposition 3 *)
Lemma ap_const_aux :
  forall {A B : U} {f : A -> B} (c : const f) {x y : A} (p : x = y),
    ap f p = cat (c x y) (inv (c y y)).
Proof.
  destruct p. cbn. intros. rewrite cat_inv_r. refl.
Defined.

Lemma ap_const :
  forall {A B : U} {f : A -> B},
    const f -> forall {x : A} (p : x = x),
      ap f p = refl (f x).
Proof.
  intros A B f c x p. rewrite (ap_const_aux c p). apply cat_inv_r.
Defined.

Lemma inv_cat :
  forall {A : U} {x y z : A} (p : x = y) (q : y = z),
    inv (cat p q) = cat (inv q) (inv p).
Proof.
  destruct p, q. cbn. refl.
Defined.

(* Lemma 4 (Fixed Point Lemma) *)
Lemma isProp_fixpoint :
  forall (A : U) (f : A -> A),
    const f -> isProp (fixpoint f).
Proof.
  unfold const, isProp, fixpoint.
  intros A f c [x p] [y q].
  apply sigma_eq_intro. cbn.
  destruct (cat p (cat (c x y) (inv q))).
  exists (cat p (inv q)).
  rewrite transport_eq_fun, ap_id, (ap_const c), cat_refl_r, inv_cat,
          inv_inv, <- cat_assoc, cat_inv_l, cat_refl_r.
  refl.
Defined.

(* Theorem 3 *)
Lemma collapsible_hstable :
  forall {A : U},
    collapsible A -> hstable A.
Proof.
  unfold collapsible, const, hstable.
  intros A [f c] ta.
  cut (fixpoint f).
    exact pr1'.
    revert ta. apply trunc_rec.
      apply isProp_fixpoint. exact c.
      intro a. exists (f a). apply c.
Defined.

Lemma hstable_collapsible :
  forall {A : U},
    hstable A -> collapsible A.
Proof.
  unfold hstable, collapsible, const.
  intros A f.
  exists (fun x : A => f (trunc' x)).
  intros x y. apply ap, path.
Defined.

(** The authors claim that this is provable. *)
Lemma wut :
  LEM ->
    forall (A B : U) (f : A -> B) (c : const f),
      isSet B -> trunc A -> B.
Proof.
  unfold const, isSet. intros LEM A B f c SA ta.
  apply isSet_hseparated in SA.
  unfold hseparated in SA.
Abort.

(** * 5 Global Collapsibility implies Decidable Equality *)

Goal
  hstable = collapsible.
Proof.
  apply funext. intro A.
  apply ua. unfold equiv.
  exists hstable_collapsible.
  apply qinv_isequiv. unfold qinv.
  exists collapsible_hstable.
  unfold homotopy, comp, id, hstable, collapsible, const; split.
    2: {
      intro f. apply funext. intro x.
      compute. destruct (trunc_rec _). rewrite e. apply ap, path.
    }
    intros [f c]. apply sigma_eq_intro. esplit. Unshelve. all: cycle 1.
      apply funext. intro x. cbn. destruct (trunc_rec _).
        cbn. rewrite e. apply c.
      rewrite transport_pi. cbn.
        apply funext. intro x. apply funext. intro y.
        rewrite transport_pi. rewrite transport_eq_fun.
Abort.

Lemma not_everything_collapsible :
  ~ forall A : U, collapsible A.
Proof.
  intro H.
  assert (forall A : U, hstable A).
    intro. apply collapsible_hstable. apply H.
  apply (not_Prop_making_functor trunc).
    intros. apply path.
    exact (trunc' false).
    apply X.
Defined.

(* Lemma 5, my custom proof *)
Lemma lemma_5 :
  forall (A : U) (x y : A),
    (forall z : A, collapsible ((x = z) + (y = z))) ->
      decidable (x = y).
Proof.
  unfold collapsible, const, decidable.
  intros A x y H.
  pose (p := (| pr1' (H x) (inl (refl x)), pr2' (H x) (inl (refl x)) _ |)).
  destruct p as [e1 p].
  pose (q := (| pr1' (H y) (inr (refl y)), pr2' (H y) (inr (refl y)) _ |)).
  destruct q as [e2 q].
  destruct e1.
    destruct e2.
      left. exact e0.
      right. destruct 1. assert (inl e = inr e0).
        rewrite <- p, <- q. apply (pr2' (H x)).
        apply encode_sum in X. cbn in X. assumption.
    left. apply inv. exact e.
Defined.

(* Theorem 4 *)
Theorem all_collapsible_all_decidable_equality :
  (forall A : U, collapsible A) ->
  (forall A : U, decidable_equality A).
Proof.
  unfold decidable_equality.
  intros H A x y.
  apply lemma_5. intro. apply H.
Defined.

(** * 6 Populatedness *)

(* Definition 5 *)
Definition populated (A : U) : U :=
  forall f : A -> A, const f -> fixpoint f.

(* Proposition 4.1 *)
Definition make_populated {A : U} (x : A) : populated A :=
  fun (f : A -> A) (c : const f) =>
    (| f x, c x (f x) |).

(* Proposition 4.2 *)
Lemma isProp_populated :
  forall A : U,
    isProp (populated A).
Proof.
  unfold isProp, populated.
  intros A f g.
  apply funext. intro h. apply funext. intro c.
  apply isProp_fixpoint. assumption.
Defined.

Lemma trunc_populated :
  forall A : U,
    trunc A -> populated A.
Proof.
  unfold populated, const, fixpoint.
  intros A ta f c.
  revert ta. apply trunc_rec.
    apply isProp_fixpoint. assumption.
    intro a. exists (f a). apply c.
Defined.

(* Theorem 5 *)
Theorem populated_spec :
  forall A : U,
    populated A =
    forall P : U, isProp P -> (P -> A) -> (A -> P) -> P.
Proof.
  intro. apply isProp_iff_eq.
    apply isProp_populated.
    unfold isProp. intros f g. repeat (apply funext; intro).
      apply x0.
    unfold populated. intros H P PP f g. apply g.
      apply (H (fun x : A => f (g x))). intros x y.
      rewrite (PP (g x) (g y)). refl.
    intro H.
    assert (populated A).
      unfold populated, const, fixpoint. intros f c. apply H.
        apply isProp_fixpoint. exact c.
        exact pr1'.
        intro a. exists (f a). apply c.
    assumption.
Defined.

(** * 7 Taboos and Counter-Models *)

(* Check @trunc'. *)
(* ===> @trunc' : forall A : U, A -> trunc A *)

(* Check trunc_populated. *)
(* ===> trunc_populated : forall A : U, trunc A -> populated A *)

Lemma populated_dbl_neg :
  forall A : U,
    populated A -> ~ ~ A.
Proof.
  unfold populated.
  intros A H f.
  assert (x : A).
    eapply (H (fun x => match f x with end)). intros x y. destruct (f x).
  destruct (f x).
Defined.

(** ** 7.1 Inhabited and H-Inhabited *)

Lemma not_all_hstable :
  ~ forall A : U, hstable A.
Proof.
  unfold hstable. apply not_Prop_making_functor.
    intros. apply path.
    exact (trunc' false).
Defined.

Lemma not_all_hstable' :
  ~ forall A : U, trunc A -> A.
Proof.
  intros. apply not_all_hstable.
Defined.

(* TODO: any relation has a functional subrelation. *)

(** ** 7.2 H-Inhabited and Populated *)

Definition ap2
  {A B C : U} (f : A -> B -> C) {x x' : A} {y y' : B}
  (p : x = x') (q : y = y') : f x y = f x' y'.
Proof.
  destruct p, q. refl.
Defined.

(* Lemma 6 *)
Lemma populated_hstable :
  forall A : U,
    populated (hstable A).
Proof.
  unfold populated, const, fixpoint, hstable.
  intros A f c.
  esplit. Unshelve. all: cycle 1.
    intro ta. assert (fixpoint f).
      unfold fixpoint. revert ta. apply trunc_rec.
        apply isProp_fixpoint. exact c.
        intro a. exists (fun _ => f (fun _ => a) (trunc' a)).
          apply funext. intro x.
          rewrite <- (c (fun _ => a) (fun _ => f (fun _ => a) (trunc' a))).
          apply ap, path.
      exact (pr1' X ta).
    apply funext. intro ta. destruct (trunc_rec _). cbn. rewrite e.
      apply ap2. apply funext. intro. destruct (trunc_rec _).
        cbn. rewrite e, e0. rewrite (c x x1). refl.
        refl.
Defined.

Lemma not_all_populated_trunc :
  (forall A : U, populated A -> trunc A) ->
    forall A : U, trunc (hstable A).
Proof.
  intros H A. apply H. apply populated_hstable.
Defined.

(* Theorem 6 *)
Theorem theorem_6 :
  (forall A : U, populated A -> trunc A) =
  (forall A : U, trunc (trunc A -> A)).
Proof.
  apply isProp_iff_eq.
    intros f g. repeat (apply funext; intro). apply path.
    intros f g. repeat (apply funext; intro). apply path.
    intros H A. apply H. apply populated_hstable.
    intros H A PA.
      specialize (H A). revert H. apply trunc_rec.
        apply isProp_trunc.
        intro f. unfold populated, const, fixpoint in PA.
        apply trunc'. eapply (pr1' (PA (fun x : A => f (trunc' x)) _)).
Unshelve.
  intros. cbn. apply ap, path.
Defined.

Lemma populated_spec' :
  forall A : U,
    populated A = (trunc (trunc A -> A) -> trunc A).
Proof.
  intro A.
  apply isProp_iff_eq.
    apply isProp_populated.
    apply isProp_fun, isProp_trunc.
    intro H. apply trunc_rec.
      apply isProp_trunc.
      intro f. unfold populated, const, fixpoint in H.
        apply trunc'. eapply (pr1' (H (fun x : A => f (trunc' x)) _)). Unshelve. all: cycle 1.
          intros. cbn. apply ap, path.
    {
      unfold populated, const, fixpoint. intros H f c.
      assert (trunc (trunc A -> A)).
        apply trunc'. intro ta. assert (trunc (trunc A -> A)).
          revert ta. apply trunc_rec.
            apply isProp_trunc.
            intro x. apply trunc'. intros _. exact x.
        assert (fixpoint f).
          unfold fixpoint. revert X. apply trunc_rec.
            apply isProp_fixpoint. assumption.
            intro g. exists (f (g ta)). apply c.
          exact (pr1' X0).
      specialize (H X). revert H. apply trunc_rec.
        apply isProp_fixpoint. assumption.
        intro x. exists (f x). apply c.
    }
Defined.

Lemma conclusion_of_theorem_6_is_propositional_axiom_of_choice :
  (forall A : U, trunc (trunc A -> A)) =
  (forall (P : U) (Y : P -> U), isProp P ->
    (forall p : P, trunc (Y p)) -> trunc (forall p : P, Y p)).
Proof.
  apply isProp_iff_eq.
    apply isProp_pi. intro. apply isProp_trunc.
    repeat (apply isProp_pi; intro). apply isProp_trunc.
    intros H P Y PP f. specialize (H (forall p : P, Y p)).
      revert H. apply trunc_rec.
        apply isProp_trunc.
        intro. apply trunc'. intro. apply X.
          specialize (f p). revert f. apply trunc_rec.
            apply isProp_trunc.
            intro. apply trunc'. intro. rewrite (PP p0 p). assumption.
    intros H A.
      specialize (H (trunc A) (fun _ => A) (isProp_trunc A)).
      cbn in H. apply H. exact id.
Defined.

(** ** 7.3 Populated and Non-Empty *)

(* Lemma 7 *)
Lemma dbl_neg_populated_LEM :
  (forall A : U, ~ ~ A -> populated A) -> LEM.
Proof.
  unfold populated, const, fixpoint, LEM.
  intros H P PP.
  eapply (pr1' (H _ _ _ _)). Unshelve.
    intro. apply X. right. intro. apply X. left. assumption.
    exact id.
    intros. apply ex_3_7.
      assumption.
      apply isProp_fun, isProp_empty.
      intro. destruct X. destruct (n p).
Defined.


From Coq Require Import Arith Lia.
From Paco Require Import paco.

From ITree Require Import Axioms.

Create HintDb not_wf.

Set Implicit Arguments.

(* Contains well founded from and not well founded from predicate definitions and reasoning principles *)
Section IterRel.

  Context (A : Type).
  Context (r : A -> A -> Prop).

  Variant not_wf_F (F : A -> Prop) (a : A) : Prop :=
    | not_wf (a' : A) (Hrel : r a a') (Hcorec : F a') .
  Hint Constructors not_wf_F : not_wf.

  Lemma not_wf_F_mono sim sim' a
        (IN : not_wf_F sim a)
        (LE : sim <1= sim') : not_wf_F sim' a.
  Proof.
    destruct IN. eauto with not_wf.
  Qed.

  Lemma not_wf_F_mono' : monotone1 not_wf_F.
  Proof.
    red. intros. eapply not_wf_F_mono; eauto.
  Qed.
  Hint Resolve not_wf_F_mono' : paco.

  Definition not_wf_from : A -> Prop :=
    paco1 not_wf_F bot1.

  Inductive wf_from (a : A) : Prop :=
    | base : (forall a', ~ (r a a')) -> wf_from a
    | step : (forall a', r a a' -> wf_from a') -> wf_from a
  .
  Hint Constructors wf_from : not_wf.
  Lemma neg_wf_from_not_wf_from_l : forall (a : A),
      ~(wf_from a) -> not_wf_from a.
  Proof.
    pcofix CIH. intros. pfold. destruct (classic (exists a', r a a' /\ ~ ( wf_from a') )).
    - destruct H as [a' [Hr Hwf] ]. econstructor; eauto.
    - assert (forall a', ~ r a a' \/ wf_from a').
      {
        intros.
        destruct (classic (r a a')); auto. destruct (classic (wf_from a')); auto.
        exfalso. apply H. exists a'. auto.
      }
      clear H.
      exfalso. apply H0. clear H0. apply step. intros. destruct (H1 a'); auto with not_wf.
  Qed.

  Lemma neg_wf_from_not_wf_from_r : forall (a : A),
      not_wf_from a -> ~ (wf_from a).
  Proof.
    intros. intro Hcontra. punfold H.  inversion H. pclearbot. clear H. generalize dependent a'.
    induction Hcontra; intros.
    - apply H in Hrel. auto.
    - punfold Hcorec. inversion Hcorec. pclearbot. specialize (H0 a' Hrel a'0 Hrel0).
      auto.
  Qed.

  Lemma neg_wf_from_not_wf_from : forall (a : A),
      not_wf_from a <-> ~(wf_from a).
  Proof.
    split; try apply neg_wf_from_not_wf_from_r; try apply neg_wf_from_not_wf_from_l.
  Qed.

  Lemma classic_wf : forall (a : A), wf_from a \/ not_wf_from a.
  Proof.
    intros. destruct (classic (wf_from a)); auto.
    apply neg_wf_from_not_wf_from in H. auto.
  Qed.

  Lemma intro_not_wf : forall (P : A -> Prop) (f : A -> A) (a : A),
    P a -> (forall a1 a2, P a1 -> r a1 a2 -> P a2 ) -> (forall a, P a -> r a (f a)) ->
    not_wf_from a.
  Proof.
    intros. generalize dependent a. pcofix CIH. intros. pfold.
    apply not_wf with (a' := f a).
    - auto using H1.
    - right. apply CIH. eapply H0; eauto.
  Qed.

  Lemma intro_wf : forall (P : A-> Prop) (m : A -> nat) (a : A),
      P a -> (forall a1 a2, P a1 -> r a1 a2 -> P a2 ) ->
      (forall a1 a2, P a1 -> r a1 a2 -> m a2 < m a1) -> wf_from a.
  Proof.
    intros P m a. remember (m a) as ma eqn:Hma. revert a Hma.
    induction ma using lt_wf_ind; intros a -> H0 HS Hlt.
    apply step; eauto.
  Qed.

End IterRel.

Definition rel_rev {A : Type} (r : A -> A -> Prop) : A -> A -> Prop := fun a0 a1 => r a1 a0.

(*note that my notion of well_founded is sort of reverse of theres*)
Lemma well_found_wf_from : forall (A : Type) (r : A -> A -> Prop),
    well_founded (rel_rev r) -> forall a, wf_from r a.
Proof.
  intros A r Hwf a. unfold well_founded in Hwf.
  unfold rel_rev in *. induction (Hwf a). apply step. intros.
  apply H0 in H1. auto.
Qed.

(*Less than is well founded*)

(*my well founded should be closed under subrelation*)

Lemma wf_from_sub_rel : forall (A : Type) (r0 r1 : A -> A -> Prop) (a : A),
    subrelation r0 r1 -> wf_from r1 a -> wf_from r0 a.
Proof.
  intros. induction H0.
  - apply base. intros a' Hcontra. apply H in Hcontra. eapply H0; eauto.
  - apply step. intros a' Hr0aa'. apply H in Hr0aa'. auto.
Qed.

Lemma wf_from_gt : forall (n : nat), wf_from (fun n0 n1 => n0 > n1) n.
Proof.
  intros.
  enough (forall n', n' <= n -> wf_from (fun n0 n1 => n0 > n1) n' ); auto.
  induction n; intros.
  - assert (n' = 0); try lia. subst. apply base. intros. lia.
  - apply step. intros n'' Hn''. assert (n'' <= n); try lia. auto.
Qed.
(*induct on f a*)
Lemma no_inf_dec_seq_aux : forall  (r : nat -> nat -> Prop) (n: nat),
    (forall n1 n2, r n1 n2 -> n1 > n2) ->
     wf_from r n.
Proof.
  intros. eapply wf_from_sub_rel; try apply wf_from_gt.
  repeat intro. auto.
Qed.

(*Possibly uses some kind of transitivity in > that is missing in my more general proofs,
  a more general proof would be nice but I think the nat captures most of what people want*)
Lemma wf_intro_gt : forall (A : Type) (r : A -> A -> Prop) (f : A -> nat) (P : A -> Prop) (a : A),
    (forall a1 a2, P a1 -> r a1 a2 -> P a2) ->
    (forall a1 a2, P a1 -> r a1 a2 -> f a1 > f a2) ->
    P a -> wf_from r a.
Proof.
  intros A r f inv a Hinv Hgt Ha.
  remember (f a) as n0.
  generalize dependent a.
  enough (forall a, f a <= n0 -> inv a -> wf_from r a).
  {
    intros. apply H. lia. auto.
  }
  induction n0; intros.
  - apply base. assert (f a = 0); try lia.
    intros a' Hcontra.
    specialize (Hgt a a' H0 Hcontra). lia.
  - apply step. intros a' Ha'.
    apply IHn0; eauto.
    assert (f a > f a'); eauto. lia.
Qed.


Require Import OrderedType.
Definition t := bool.

Definition eq := @eq bool.

Inductive lt_ : t -> t -> Prop :=
 | BLt : lt_ false true.

Definition lt := lt_.

Lemma eq_refl : forall x : t, eq x x.
Proof. reflexivity. Qed.

Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof. Admitted.

Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof. Admitted.

Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
Proof. Admitted.

Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
Proof. Admitted.

Definition compare : forall (x y: t), Compare lt eq x y.
 intros x y.
 refine (match x, y with
   | true,  true  => EQ _
   | true,  false => GT _
   | false, true  => LT _
   | false, false => EQ _
   end).

 - now apply eq_refl.
 - now constructor.
 - now constructor.
 - now apply eq_refl.
Defined.

Definition eq_dec (x y : t): {eq x y} + {~ eq x y} := Bool.bool_dec x y.

(* Orderes.OrderedType *)
Module OT <: Orders.OrderedType.
  Definition t := t.
  Definition eq := eq.
  Definition lt := lt.
  Program Instance eq_equiv : Equivalence eq.

  Program Instance lt_strorder : StrictOrder lt.
  Obligation 1.
  Admitted.
  Obligation 2.
  Admitted.

  Program Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
  Obligation 1.
  Admitted.

  Definition compare (x y: t) :=
    match x, y with
    | true,  true  => Eq
    | true,  false => Gt
    | false, true  => Lt
    | false, false => Eq
    end.

  Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
  Admitted.

  Definition eq_dec := eq_dec.
End OT.

(* おまけ *)
Definition neq_lt_gt_dec : forall x y, x <> y -> {lt x y} + {lt y x}.
 intros x y Hneq. destruct x, y; [now elim Hneq | now right | now left| now elim Hneq].
Defined.

Axiom lt_irrefl : forall x, ~ lt x x.


Require Import Category.
Require Import Sized.
Require Import Combinators.
Require Import NEList.

Require Import Ascii.
Local Open Scope char.

Require Import Coq.Lists.List.
Import ListNotations.

Require Import BinInt.

Section Numbers.

Context
  {M : Type -> Type} `{RawFunctor M} `{RawApplicative M} `{RawMonad M} `{RawAlternative M}
  {Chars : nat -> Type} `{Sized Chars ascii}
  {n : nat}.

Definition decimal_digit : Parser Chars ascii M nat n :=
  alts ((0 <$ exact "0")
     :: (1 <$ exact "1")
     :: (2 <$ exact "2")
     :: (3 <$ exact "3")
     :: (4 <$ exact "4")
     :: (5 <$ exact "5")
     :: (6 <$ exact "6")
     :: (7 <$ exact "7")
     :: (8 <$ exact "8")
     :: (9 <$ exact "9")
     :: []).

Definition decimal_nat : Parser Chars ascii M nat n :=
  let convert ds := foldl (fun ih d => 10 * ih + d) ds O
  in Combinators.map convert (nelist decimal_digit).

Definition decimal_int : Parser Chars ascii M Z n :=
  let convert s v := option_rect _ (fun _ => Z.opp) (fun x => x) s (Z.of_nat v)
  in Combinators.map (prod_curry convert) (exact "-" <?&> decimal_nat).

End Numbers.


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.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.ProductEquivalences.
Require Import UniMath.Bicategories.Limits.Inserters.
Require Import UniMath.Bicategories.Limits.InserterEquivalences.
Require Import UniMath.Bicategories.Limits.Equifiers.
Require Import UniMath.Bicategories.Limits.EquifierEquivalences.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Colimits.Coproducts.
Require Import UniMath.Bicategories.Colimits.CoproductEquivalences.

Local Open Scope cat.

Section PreservationClosedUnderEquivalence.
  Context {B₁ B₂ : bicat}
          {F G : psfunctor B₁ B₂}
          (η : pstrans F G)
          (Hη : ∏ (x : B₁), left_adjoint_equivalence (η x)).

  Definition preserves_bifinal_left_adjoint_equivalence
             (HF : preserves_bifinal F)
    : preserves_bifinal G.
  Proof.
    intros x Hx.
    exact (is_bifinal_left_adjoint_equivalence
             _
             (Hη x)
             (HF _ Hx)).
  Defined.

  Definition preserves_biinitial_left_adjoint_equivalence
             (HF : preserves_biinitial F)
    : preserves_biinitial G.
  Proof.
    intros x Hx.
    exact (equiv_from_biinitial
             (HF _ Hx)
             (Hη x)).
  Defined.

  Definition preserves_binprods_left_adjoint_equivalence
             (HF : preserves_binprods F)
    : preserves_binprods G.
  Proof.
    intros x y p Hp.
    exact (has_binprod_ump_left_adjoint_equivalence
             _ _
             (HF _ _ _ Hp)
             _ _
             _ _ _
             (Hη x)
             (Hη y)
             (Hη p)
             (psnaturality_of
                η
                (binprod_cone_pr1 p))
             (psnaturality_of
                η
                (binprod_cone_pr2 p))).
  Defined.

  Definition preserves_bincoprods_left_adjoint_equivalence
             (HF : preserves_bincoprods F)
    : preserves_bincoprods G.
  Proof.
    intros x y p Hp.
    exact (has_bincoprod_ump_left_adjoint_equivalence
             _ _
             (HF _ _ _ Hp)
             _ _
             _ _ _
             (Hη x)
             (Hη y)
             (Hη p)
             (psnaturality_of
                η
                (bincoprod_cocone_inl p))
             (psnaturality_of
                η
                (bincoprod_cocone_inr p))).
  Defined.

  Definition preserves_inserters_left_adjoint_equivalence
             (HF : preserves_inserters F)
    : preserves_inserters G.
  Proof.
    intros x y f g p Hp.
    use (has_inserter_ump_left_adjoint_equivalence
             _ _ _
             (Hη x)
             (Hη y)
             (Hη p)
             (psnaturality_of η (inserter_cone_pr1 p))
             (psnaturality_of η f)
             (psnaturality_of η g)
             (HF _ _ _ _ _ Hp)).
    abstract
      (pose (psnaturality_natural η _ _ _ _ (inserter_cone_cell p)) as q ;
       cbn in q ;
       rewrite (pstrans_comp_alt η (inserter_cone_pr1 p) g) in q ;
       rewrite (pstrans_comp_alt η (inserter_cone_pr1 p) f) in q ;
       rewrite !vassocl in q ;
       rewrite <- !lwhisker_vcomp ;
       rewrite <- !rwhisker_vcomp ;
       rewrite !vassocr ;
       use vcomp_move_L_Mp ; [ is_iso | ] ;
       cbn -[psfunctor_comp] ;
       rewrite !vassocl ;
       rewrite q ;
       rewrite !vassocr ;
       do 6 apply maponpaths_2 ;
       rewrite !lwhisker_vcomp ;
       rewrite vcomp_rinv ;
       rewrite lwhisker_id2 ;
       apply id2_left).
  Defined.

  Definition preserves_equifiers_left_adjoint_equivalence
             (HF : preserves_equifiers F)
    : preserves_equifiers G.
  Proof.
    intros x y f g α β p Hp.
    exact (has_equifier_ump_left_adjoint_equivalence
             _ _ _ _ _
             (Hη x)
             (Hη y)
             (Hη p)
             (psnaturality_of η (equifier_cone_pr1 p))
             (psnaturality_of η f)
             (psnaturality_of η g)
             (HF _ _ _ _ _ _ _ Hp)
             (psnaturality_natural η _ _ _ _ α)
             (psnaturality_natural η _ _ _ _ β)).
  Defined.
End PreservationClosedUnderEquivalence.


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


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