Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Import ListNotations.

Module Type LanguageSig.
(* primitive_types *)
  Parameter model : Type .
(* derived types *)
  Definition expr := (model -> Prop) .
(* primitive judgements *)
(* primitive connectives *)
  Parameter join : (model -> model -> model -> Prop) .
  Parameter is_unit : (model -> Prop) .
End LanguageSig.

Module DerivedNames (Names: LanguageSig).
Include Names.
(* derived connectives *)
  Definition impp := (fun (x y : model -> Prop) (m : model) => x m -> y m) .
  Definition andp := (fun (x y : model -> Prop) (m : model) => x m /\ y m) .
  Definition orp := (fun (x y : model -> Prop) (m : model) => x m \/ y m) .
  Definition coq_prop := (fun (P : Prop) (_ : model) => P) .
  Definition sepcon := (fun (x y : model -> Prop) (m : model) => exists m1 m2 : model, join m1 m2 m /\ x m1 /\ y m2) .
  Definition emp := (fun m : model => is_unit m) .
(* derived judgements *)
  Definition provable := (fun x : model -> Prop => forall m : model, x m) .
  Definition derivable1 := (fun x y : expr => provable (impp x y)) .
End DerivedNames.

Module Type PrimitiveRuleSig (Names: LanguageSig).
Include DerivedNames (Names).
  Axiom join_comm : (forall m1 m2 m : model, join m1 m2 m -> join m2 m1 m) .
  Axiom join_assoc : (forall mx my mz mxy mxyz : model, join mx my mxy -> join mxy mz mxyz -> exists myz : model, join my mz myz /\ join mx myz mxyz) .
End PrimitiveRuleSig.

Module Type LogicTheoremSig (Names: LanguageSig) (Rules: PrimitiveRuleSig Names).
Include Rules.
Parameter Inline tree_pos : Type .
(* derived rules *)
  Axiom derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) .
  Axiom derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) .
  Axiom derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) .
  Axiom sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
  Axiom sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) .
  Axiom expr_deep : Set .
  Axiom impp_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom sepcon_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom emp_deep : expr_deep .
  Axiom varp_deep : (nat -> expr_deep) .
  Axiom var_pos : (expr -> option positive -> tree_pos) .
  Axiom sepcon_pos : (tree_pos -> tree_pos -> tree_pos) .
  Axiom cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) .
  Axiom cancel_different : (tree_pos -> tree_pos -> expr) .
  Axiom cancel_same : (tree_pos -> tree_pos -> Prop) .
  Axiom restore : (tree_pos -> tree_pos -> expr) .
(* derived rules as instance *)
  Existing Instance sepcon_proper_impp .
End LogicTheoremSig.

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfJudgement.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfIteratedConnectives.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfClassicalAxioms.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfCancel.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.ProofTheory.IterSepcon.
Require Import Logic.SeparationLogic.ProofTheory.Corable.
Require Import Logic.SeparationLogic.ProofTheory.Deduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.ShallowEmbedded.Join2Sepcon.
Require Import Logic.SeparationLogic.ShallowEmbedded.Model2CoqPropEmp.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.SeparationLogic.ShallowEmbedded.PredicateSeparationLogic.

Module LogicTheorem (Names: LanguageSig) (Rules: PrimitiveRuleSig Names) <: LogicTheoremSig Names Rules.
Include Rules.
(* aux primitive instances *)
  Instance M : Model := (Build_Model model) .
  Instance L : Language := (Build_Language expr) .
  Instance J : (Join model) := join .
  Instance U : (Unit model) := is_unit .
  Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
  Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
  Instance orpL : (OrLanguage L) := (Build_OrLanguage L orp) .
  Instance coq_prop_L : (CoqPropLanguage L) := (Build_CoqPropLanguage L coq_prop) .
  Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
  Instance empL : (EmpLanguage L) := (Build_EmpLanguage L emp) .
  Instance GammaP : (Provable L) := (Build_Provable L provable) .
  Instance GammaD1 : (Derivable1 L) := (Build_Derivable1 L derivable1) .
  Instance J_SA : (SeparationAlgebra model) := (Build_SeparationAlgebra model J join_comm join_assoc) .
(* aux refl instances for derivation *)
  Instance imppDef_model : (ImppDefinition_Model minL) := Model2Impp_Normal .
  Instance andpDef_model : (AndpDefinition_Model andpL) := Model2Andp_Normal .
  Instance orpDef_model : (OrpDefinition_Model orpL) := Model2Orp_Normal .
  Instance coqpropDef_model : (CoqPropDefinition_Model coq_prop_L) := Model2CoqProp_Normal .
  Instance sepconDef_join : (SepconDefinition_Join Join2Sepcon) := Join2Sepcon_Normal .
  Instance empDef_unit : (EmpDefinition_Unit Unit2Emp) := Unit2Emp_Normal .
  Instance provableDef_model : (ProvableDefinition_Model GammaP) := Model2Provable_Normal .
  Instance GammaD1P : (Derivable1Provable L GammaP GammaD1) := Provable2Derivable1_Normal .
(* aux derived instances *)
  Instance sepconAX : (SepconAxiomatization L GammaP) := SeparationAlgebra2SepconAxiomatization .
  Instance sepconD : (SepconDeduction L GammaD1) := SeparationLogic.Axiomatization2Deduction_sepconD .
Definition tree_pos : Type := tree_pos.
(* derived rules *)
  Definition derivable1_sepcon_comm : (forall x y : expr, derivable1 (sepcon x y) (sepcon y x)) := derivable1_sepcon_comm .
  Definition derivable1_sepcon_assoc1 : (forall x y z : expr, derivable1 (sepcon x (sepcon y z)) (sepcon (sepcon x y) z)) := derivable1_sepcon_assoc1 .
  Definition derivable1_sepcon_mono : (forall x1 x2 y1 y2 : expr, derivable1 x1 x2 -> derivable1 y1 y2 -> derivable1 (sepcon x1 y1) (sepcon x2 y2)) := derivable1_sepcon_mono .
  Definition sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) := sepcon_comm_impp .
  Definition sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) := sepcon_assoc1 .
  Definition sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) := sepcon_mono .
  Definition sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) := sepcon_proper_impp .
  Definition expr_deep : Set := expr_deep .
  Definition impp_deep : (expr_deep -> expr_deep -> expr_deep) := impp_deep .
  Definition sepcon_deep : (expr_deep -> expr_deep -> expr_deep) := sepcon_deep .
  Definition emp_deep : expr_deep := emp_deep .
  Definition varp_deep : (nat -> expr_deep) := varp_deep .
  Definition var_pos : (expr -> option positive -> tree_pos) := var_pos .
  Definition sepcon_pos : (tree_pos -> tree_pos -> tree_pos) := sepcon_pos .
  Definition cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) := cancel_mark .
  Definition cancel_different : (tree_pos -> tree_pos -> expr) := cancel_different .
  Definition cancel_same : (tree_pos -> tree_pos -> Prop) := cancel_same .
  Definition restore : (tree_pos -> tree_pos -> expr) := restore .
(* derived rules as instance *)
  Existing Instance sepcon_proper_impp .
End LogicTheorem.

(*Require Logic.PropositionalLogic.DeepEmbedded.Solver.
Module IPSolver (Names: LanguageSig).
  Import Names.
  Ltac ip_solve :=
    change expr with Base.expr;
    change provable with Base.provable;
    change impp with Syntax.impp;
    change andp with Syntax.andp;
    intros; Solver.SolverSound.ipSolver.
End IPSolver.*)


From algebra Require Export cofe.

Record solution (F : cFunctor) := Solution {
  solution_car :> cofeT;
  solution_unfold : solution_car -n> F solution_car;
  solution_fold : F solution_car -n> solution_car;
  solution_fold_unfold X : solution_fold (solution_unfold X) ≡ X;
  solution_unfold_fold X : solution_unfold (solution_fold X) ≡ X
}.
Arguments solution_unfold {_} _.
Arguments solution_fold {_} _.

Module solver. Section solver.
Context (F : cFunctor) `{Fcontr : cFunctorContractive F}
        `{Finhab : Inhabited (F unitC)}.
Notation map := (cFunctor_map F).

Fixpoint A (k : nat) : cofeT :=
  match k with 0 => unitC | S k => F (A k) end.
Fixpoint f (k : nat) : A k -n> A (S k) :=
  match k with 0 => CofeMor (λ _, inhabitant) | S k => map (g k,f k) end
with g (k : nat) : A (S k) -n> A k :=
  match k with 0 => CofeMor (λ _, ()) | S k => map (f k,g k) end.
Definition f_S k (x : A (S k)) : f (S k) x = map (g k,f k) x := eq_refl.
Definition g_S k (x : A (S (S k))) : g (S k) x = map (f k,g k) x := eq_refl.
Arguments A : simpl never.
Arguments f : simpl never.
Arguments g : simpl never.

Lemma gf {k} (x : A k) : g k (f k x) ≡ x.
Proof.
  induction k as [|k IH]; simpl in *; [by destruct x|].
  rewrite -cFunctor_compose -{2}[x]cFunctor_id. by apply (contractive_proper map).
Qed.
Lemma fg {k} (x : A (S (S k))) : f (S k) (g (S k) x) ≡{k}≡ x.
Proof.
  induction k as [|k IH]; simpl.
  - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose.
    apply (contractive_0 map).
  - rewrite f_S g_S -{2}[x]cFunctor_id -cFunctor_compose.
    by apply (contractive_S map).
Qed.

Record tower := {
  tower_car k :> A k;
  g_tower k : g k (tower_car (S k)) ≡ tower_car k
}.
Instance tower_equiv : Equiv tower := λ X Y, ∀ k, X k ≡ Y k.
Instance tower_dist : Dist tower := λ n X Y, ∀ k, X k ≡{n}≡ Y k.
Program Definition tower_chain (c : chain tower) (k : nat) : chain (A k) :=
  {| chain_car i := c i k |}.
Next Obligation. intros c k n i ?; apply (chain_cauchy c n); lia. Qed.
Program Instance tower_compl : Compl tower := λ c,
  {| tower_car n := compl (tower_chain c n) |}.
Next Obligation.
  intros c k; apply equiv_dist=> n.
  by rewrite (conv_compl n (tower_chain c k))
    (conv_compl n (tower_chain c (S k))) /= (g_tower (c _) k).
Qed.
Definition tower_cofe_mixin : CofeMixin tower.
Proof.
  split.
  - intros X Y; split; [by intros HXY n k; apply equiv_dist|].
    intros HXY k; apply equiv_dist; intros n; apply HXY.
  - intros k; split.
    + by intros X n.
    + by intros X Y ? n.
    + by intros X Y Z ?? n; trans (Y n).
  - intros k X Y HXY n; apply dist_S.
    by rewrite -(g_tower X) (HXY (S n)) g_tower.
  - intros n c k; rewrite /= (conv_compl n (tower_chain c k)).
    apply (chain_cauchy c); lia.
Qed.
Definition T : cofeT := CofeT tower_cofe_mixin.

Fixpoint ff {k} (i : nat) : A k -n> A (i + k) :=
  match i with 0 => cid | S i => f (i + k) ◎ ff i end.
Fixpoint gg {k} (i : nat) : A (i + k) -n> A k :=
  match i with 0 => cid | S i => gg i ◎ g (i + k) end.
Lemma ggff {k i} (x : A k) : gg i (ff i x) ≡ x.
Proof. induction i as [|i IH]; simpl; [done|by rewrite (gf (ff i x)) IH]. Qed.
Lemma f_tower k (X : tower) : f (S k) (X (S k)) ≡{k}≡ X (S (S k)).
Proof. intros. by rewrite -(fg (X (S (S k)))) -(g_tower X). Qed.
Lemma ff_tower k i (X : tower) : ff i (X (S k)) ≡{k}≡ X (i + S k).
Proof.
  intros; induction i as [|i IH]; simpl; [done|].
  by rewrite IH Nat.add_succ_r (dist_le _ _ _ _ (f_tower _ X)); last omega.
Qed.
Lemma gg_tower k i (X : tower) : gg i (X (i + k)) ≡ X k.
Proof. by induction i as [|i IH]; simpl; [done|rewrite g_tower IH]. Qed.

Instance tower_car_ne n k : Proper (dist n ==> dist n) (λ X, tower_car X k).
Proof. by intros X Y HX. Qed.
Definition project (k : nat) : T -n> A k := CofeMor (λ X : T, tower_car X k).

Definition coerce {i j} (H : i = j) : A i -n> A j :=
  eq_rect _ (λ i', A i -n> A i') cid _ H.
Lemma coerce_id {i} (H : i = i) (x : A i) : coerce H x = x.
Proof. unfold coerce. by rewrite (proof_irrel H (eq_refl i)). Qed.
Lemma coerce_proper {i j} (x y : A i) (H1 H2 : i = j) :
  x = y → coerce H1 x = coerce H2 y.
Proof. by destruct H1; rewrite !coerce_id. Qed.
Lemma g_coerce {k j} (H : S k = S j) (x : A (S k)) :
  g j (coerce H x) = coerce (Nat.succ_inj _ _ H) (g k x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma coerce_f {k j} (H : S k = S j) (x : A k) :
  coerce H (f k x) = f j (coerce (Nat.succ_inj _ _ H) x).
Proof. by assert (k = j) by lia; subst; rewrite !coerce_id. Qed.
Lemma gg_gg {k i i1 i2 j} (H1 : k = i + j) (H2 : k = i2 + (i1 + j)) (x : A k) :
  gg i (coerce H1 x) = gg i1 (gg i2 (coerce H2 x)).
Proof.
  assert (i = i2 + i1) by lia; simplify_eq/=. revert j x H1.
  induction i2 as [|i2 IH]; intros j X H1; simplify_eq/=;
    [by rewrite coerce_id|by rewrite g_coerce IH].
Qed.
Lemma ff_ff {k i i1 i2 j} (H1 : i + k = j) (H2 : i1 + (i2 + k) = j) (x : A k) :
  coerce H1 (ff i x) = coerce H2 (ff i1 (ff i2 x)).
Proof.
  assert (i = i1 + i2) by lia; simplify_eq/=.
  induction i1 as [|i1 IH]; simplify_eq/=;
    [by rewrite coerce_id|by rewrite coerce_f IH].
Qed.

Definition embed_coerce {k} (i : nat) : A k -n> A i :=
  match le_lt_dec i k with
  | left H => gg (k-i) ◎ coerce (eq_sym (Nat.sub_add _ _ H))
  | right H => coerce (Nat.sub_add k i (Nat.lt_le_incl _ _ H)) ◎ ff (i-k)
  end.
Lemma g_embed_coerce {k i} (x : A k) :
  g i (embed_coerce (S i) x) ≡ embed_coerce i x.
Proof.
  unfold embed_coerce; destruct (le_lt_dec (S i) k), (le_lt_dec i k); simpl.
  - symmetry; by erewrite (@gg_gg _ _ 1 (k - S i)); simpl.
  - exfalso; lia.
  - assert (i = k) by lia; subst.
    rewrite (ff_ff _ (eq_refl (1 + (0 + k)))) /= gf.
    by rewrite (gg_gg _ (eq_refl (0 + (0 + k)))).
  - assert (H : 1 + ((i - k) + k) = S i) by lia.
    rewrite (ff_ff _ H) /= -{2}(gf (ff (i - k) x)) g_coerce.
    by erewrite coerce_proper by done.
Qed.
Program Definition embed (k : nat) (x : A k) : T :=
  {| tower_car n := embed_coerce n x |}.
Next Obligation. intros k x i. apply g_embed_coerce. Qed.
Instance: Params (@embed) 1.
Instance embed_ne k n : Proper (dist n ==> dist n) (embed k).
Proof. by intros x y Hxy i; rewrite /= Hxy. Qed.
Definition embed' (k : nat) : A k -n> T := CofeMor (embed k).
Lemma embed_f k (x : A k) : embed (S k) (f k x) ≡ embed k x.
Proof.
  rewrite equiv_dist=> n i; rewrite /embed /= /embed_coerce.
  destruct (le_lt_dec i (S k)), (le_lt_dec i k); simpl.
  - assert (H : S k = S (k - i) + (0 + i)) by lia; rewrite (gg_gg _ H) /=.
    by erewrite g_coerce, gf, coerce_proper by done.
  - assert (S k = 0 + (0 + i)) as H by lia.
    rewrite (gg_gg _ H); simplify_eq/=.
    by rewrite (ff_ff _ (eq_refl (1 + (0 + k)))).
  - exfalso; lia.
  - assert (H : (i - S k) + (1 + k) = i) by lia; rewrite (ff_ff _ H) /=.
    by erewrite coerce_proper by done.
Qed.
Lemma embed_tower k (X : T) : embed (S k) (X (S k)) ≡{k}≡ X.
Proof.
  intros i; rewrite /= /embed_coerce.
  destruct (le_lt_dec i (S k)) as [H|H]; simpl.
  - rewrite -(gg_tower i (S k - i) X).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct (eq_sym _).
  - rewrite (ff_tower k (i - S k) X). by destruct (Nat.sub_add _ _ _).
Qed.

Program Definition unfold_chain (X : T) : chain (F T) :=
  {| chain_car n := map (project n,embed' n) (X (S n)) |}.
Next Obligation.
  intros X n i Hi.
  assert (∃ k, i = k + n) as [k ?] by (exists (i - n); lia); subst; clear Hi.
  induction k as [|k IH]; simpl; first done.
  rewrite -IH -(dist_le _ _ _ _ (f_tower (k + n) _)); last lia.
  rewrite f_S -cFunctor_compose.
  by apply (contractive_ne map); split=> Y /=; rewrite ?g_tower ?embed_f.
Qed.
Definition unfold (X : T) : F T := compl (unfold_chain X).
Instance unfold_ne : Proper (dist n ==> dist n) unfold.
Proof.
  intros n X Y HXY. by rewrite /unfold (conv_compl n (unfold_chain X))
    (conv_compl n (unfold_chain Y)) /= (HXY (S n)).
Qed.

Program Definition fold (X : F T) : T :=
  {| tower_car n := g n (map (embed' n,project n) X) |}.
Next Obligation.
  intros X k. apply (_ : Proper ((≡) ==> (≡)) (g k)).
  rewrite g_S -cFunctor_compose.
  apply (contractive_proper map); split=> Y; [apply embed_f|apply g_tower].
Qed.
Instance fold_ne : Proper (dist n ==> dist n) fold.
Proof. by intros n X Y HXY k; rewrite /fold /= HXY. Qed.

Theorem result : solution F.
Proof.
  apply (Solution F T (CofeMor unfold) (CofeMor fold)).
  - move=> X /=. rewrite equiv_dist=> n k; rewrite /unfold /fold /=.
    rewrite -g_tower -(gg_tower _ n); apply (_ : Proper (_ ==> _) (g _)).
    trans (map (ff n, gg n) (X (S (n + k)))).
    { rewrite /unfold (conv_compl n (unfold_chain X)).
      rewrite -(chain_cauchy (unfold_chain X) n (S (n + k))) /=; last lia.
      rewrite -(dist_le _ _ _ _ (f_tower (n + k) _)); last lia.
      rewrite f_S -!cFunctor_compose; apply (contractive_ne map); split=> Y.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [exfalso; lia|].
        by rewrite (ff_ff _ (eq_refl (S n + (0 + k)))) /= gf.
      + rewrite /embed' /= /embed_coerce.
        destruct (le_lt_dec _ _); simpl; [|exfalso; lia].
        by rewrite (gg_gg _ (eq_refl (0 + (S n + k)))) /= gf. }
    assert (∀ i k (x : A (S i + k)) (H : S i + k = i + S k),
      map (ff i, gg i) x ≡ gg i (coerce H x)) as map_ff_gg.
    { intros i; induction i as [|i IH]; intros k' x H; simpl.
      { by rewrite coerce_id cFunctor_id. }
      rewrite cFunctor_compose g_coerce; apply IH. }
    assert (H: S n + k = n + S k) by lia.
    rewrite (map_ff_gg _ _ _ H).
    apply (_ : Proper (_ ==> _) (gg _)); by destruct H.
  - intros X; rewrite equiv_dist=> n /=.
    rewrite /unfold /= (conv_compl' n (unfold_chain (fold X))) /=.
    rewrite g_S -!cFunctor_compose -{2}[X]cFunctor_id.
    apply (contractive_ne map); split => Y /=.
    + rewrite f_tower. apply dist_S. by rewrite embed_tower.
    + etrans; [apply embed_ne, equiv_dist, g_tower|apply embed_tower].
Qed.
End solver. End solver.


Require Import List.
Require Import ZArith.
Require Import Lia.
Require Import EquivDec.

Require Import Utils.
Require Import Lattices.

Require Import Instr Memory.
Require Export Semantics.
Require Import AbstractCommon.

Set Implicit Arguments.

Local Open Scope Z_scope.

Section ARuleMachine.

Context {T: Type}
        {Latt: JoinSemiLattice T}
        {EqT: EqDec T eq}.

Variable table : ASysTable T.

Definition a_state := AS T T. (* We stamp block with allocation label *)
Definition a_alloc
      (size:Z) (lpc:T) (a:Atom T T) (m:memory T T): option (block T * memory T T) :=
  alloc Local lpc size a m.

Inductive a_step : a_state -> (Event T)+τ -> a_state -> Prop :=
| step_nop : forall m i s pcv pcl
    (INSTR: index_list_Z pcv i = Some Noop),
    a_step (AState m i s (pcv,pcl)) Silent (AState m i s (pcv+1,pcl))

| step_add: forall m i s pcv pcl x1v x1l x2v x2l xv
    (INSTR: index_list_Z pcv i = Some Add)
    (ADD: add x1v x2v = Some xv),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_sub: forall m i s pcv pcl x1v x1l x2v x2l xv
    (INSTR: index_list_Z pcv i = Some Sub)
    (SUB: sub x1v x2v = Some xv),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_eq: forall m i s pcv pcl x1v x1l x2v x2l
    (INSTR: index_list_Z pcv i = Some Eq),
    a_step (AState m i ((AData (x1v,x1l)::(AData (x2v,x2l))::s)) (pcv,pcl))
               Silent
               (AState m i ((AData (val_eq x1v x2v,x1l \_/ x2l))::s) (pcv+1,pcl))

| step_dup : forall m i s1 s2 pcv pcl n x
    (INSTR: index_list_Z pcv i = Some (Dup n))
    (IDX: index_list n s1 = Some x)
    (DATA: forall se, In se s1 -> exists a, se = AData a),
    a_step (AState m i (s1 ++ s2) (pcv, pcl))
           Silent
           (AState m i (x :: s1 ++ s2) (pcv+1,pcl))

| step_swap : forall m i s1 s1' s2 pcv pcl n
    (INSTR: index_list_Z pcv i = Some (Swap n))
    (SWAP: swap n s1 = Some s1')
    (DATA: forall se, In se s1 -> exists a, se = AData a),
    a_step (AState m i (s1 ++ s2) (pcv, pcl))
           Silent
           (AState m i (s1' ++ s2) (pcv+1,pcl))

| step_push: forall m i s pcv pcl cv
    (INSTR: index_list_Z pcv i = Some (Push cv)),
    a_step (AState m i s (pcv,pcl))
               Silent
               (AState m i ((AData (Vint cv,bot))::s) (pcv+1,pcl))

| step_pop: forall m i s pcv pcl a
    (INSTR: index_list_Z pcv i = Some Pop),
    a_step (AState m i (AData a :: s) (pcv,pcl))
               Silent
               (AState m i s (pcv+1,pcl))

| step_alloc: forall m i s pcv pcl b size sizel xv xl m'
    (INSTR: index_list_Z pcv i = Some Alloc)
    (ALLOC: a_alloc size (sizel \_/ pcl) (xv,xl) m = Some (b,m')),
    a_step (AState m i ((AData (Vint size,sizel))::(AData (xv,xl))::s) (pcv,pcl))
               Silent
               (AState m' i (AData (Vptr (b, 0),sizel)::s) (pcv+1,pcl))

| step_load: forall m i s pcv pcl addrl p xv xl
    (INSTR: index_list_Z pcv i = Some Load)
    (LOAD: load p m = Some (xv,xl)),
    a_step (AState m i ((AData (Vptr p,addrl))::s) (pcv,pcl))
               Silent
               (AState m i ((AData (xv,addrl \_/ xl)::s)) (pcv+1,pcl))

| step_store: forall m i s pcv pcl p addrl xv xl mv ml m'
    (INSTR: index_list_Z pcv i = Some Store)
    (LOAD: load p m = Some (mv,ml))
    (CHECK: addrl \_/ pcl <: ml = true)
    (STORE: store p  (xv, addrl \_/ pcl \_/ xl) m = Some m'),
    a_step (AState m i ((AData (Vptr p,addrl))::(AData (xv,xl))::s) (pcv,pcl))
               Silent
               (AState m' i s (pcv+1,pcl))

| step_jump: forall m i s pcv pcl pcv' pcl'
    (INSTR: index_list_Z pcv i = Some Jump),
    a_step (AState m i ((AData (Vint pcv',pcl'))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv',pcl' \_/ pcl))

| step_branchnz_true: forall m i s pcv pcl offv al
    (INSTR: index_list_Z pcv i = Some (BranchNZ offv)), (* relative target *)
    a_step (AState m i ((AData (Vint 0,al))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv+1,al \_/ pcl))

| step_branchnz_false: forall m i s pcv pcl offv av al
    (INSTR: index_list_Z pcv i = Some (BranchNZ offv)) (* relative target *)
    (BRANCH: av <> 0),
    a_step (AState m i ((AData (Vint av,al))::s) (pcv,pcl))
               Silent
               (AState m i s (pcv+offv,al \_/ pcl))

| step_call: forall m i s pcv pcl pcv' pcl' args a r
    (INSTR: index_list_Z pcv i = Some (Call a r))
    (LENGTH: length args = a)
    (ARGS: forall a, In a args -> exists d, a = AData d),
    a_step (AState m i ((AData (Vint pcv',pcl'))::args++s) (pcv,pcl))
               Silent
               (AState m i (args++(ARet (pcv+1,pcl) r)::s) (pcv',pcl' \_/ pcl))

| step_ret: forall m i s pcv pcl pcv' pcl' s'
    (INSTR: index_list_Z pcv i = Some Ret)
    (POP: pop_to_return s ((ARet (pcv',pcl') false)::s')),
    a_step (AState m i s (pcv,pcl)) Silent (AState m i s' (pcv',pcl'))

| step_vret: forall m i s pcv pcl pcv' pcl' resv resl s'
    (INSTR: index_list_Z pcv i = Some VRet)
    (POP: pop_to_return s ((ARet (pcv',pcl') true)::s')),
    a_step (AState m i (AData (resv,resl)::s) (pcv,pcl))
               Silent (AState m i (AData (resv, resl \_/ pcl)::s') (pcv',pcl'))

| step_output: forall m i s pcv pcl xv xl
    (INSTR: index_list_Z pcv i = Some Output),
    a_step (AState m i (AData (Vint xv,xl)::s) (pcv,pcl))
               (E (EInt (xv,xl \_/ pcl))) (AState m i s (pcv+1,pcl))

| step_syscall: forall id m i s pcv pcl args res sys_info
    (INSTR: index_list_Z pcv i = Some (SysCall id))
    (SYS: table id = Some sys_info)
    (SYSLENGTH: length args = sys_info.(asi_arity))
    (SYSSEM: sys_info.(asi_sem) args = Some res), (* this encodes potential IFC check failures *)
    a_step (AState m i (map AData args ++ s) (pcv,pcl))
           Silent (AState m i (AData res :: s) (pcv+1,pcl))

| step_sizeof: forall m i s pcv pcl p pl fr
    (INSTR: index_list_Z pcv i = Some SizeOf)
    (FRAME: Mem.get_frame m (fst p) = Some fr),
    a_step (AState m i (AData (Vptr p, pl)::s) (pcv,pcl))
           Silent (AState m i (AData (Vint (Z.of_nat (length fr)), pl)::s) (pcv+1,pcl))

| step_getoff: forall m i s pcv pcl p pl
    (INSTR: index_list_Z pcv i = Some GetOff),
    a_step (AState m i (AData (Vptr p, pl)::s) (pcv,pcl))
           Silent (AState m i (AData (Vint (snd p), pl)::s) (pcv+1,pcl)).

Lemma a_step_instr : forall m i s pcv pcl s' e,
  a_step (AState m i s (pcv,pcl)) e s' ->
  exists instr,
    index_list_Z pcv i = Some instr.
Proof.
  intros m i s pcv pcl s' e H.
  inv H ; eauto.
Qed.

Definition abstract_machine :=
  {| state := a_state ;
    event := (Event T) ;
    step := a_step ;
    init_data := abstract_init_data T;
    init_state := fun id =>
                    let '(p,d,b) := id in
                    {| amem := Mem.empty _ _;
                       aimem := p ;
                       astk := map (fun a: (Z*T) => let (i,l) := a in AData (Vint i,l)) d;
                       apc := (0%Z, b) |}
  |}.

End ARuleMachine.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** Base-2 Logarithm Properties *)

Require Import NAxioms NSub NPow NParity NZLog.

Module Type NLog2Prop
 (A : NAxiomsSig)
 (B : NSubProp A)
 (C : NParityProp A B)
 (D : NPowProp A B C).

 (** For the moment we simply reuse NZ properties *)

 Include NZLog2Prop A A A B D.Private_NZPow.
 Include NZLog2UpProp A A A B D.Private_NZPow.
End NLog2Prop.


Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Local Open Scope cat.

(**
 Equivalences between full subcategories
 *)
Section EquivalenceFullSub.
  Context {C₁ C₂ : category}
          {P : hsubtype C₁}
          {Q : hsubtype C₂}
          (L : C₁ ⟶ C₂)
          (L_equiv : adj_equivalence_of_cats L)
          (HL : ∏ (x : C₁), P x → Q (L x))
          (HR : ∏ (x : C₂), Q x → P (right_adjoint L_equiv x)).

  Let L' : full_sub_category C₁ P ⟶ full_sub_category C₂ Q
    := full_sub_category_functor P Q L HL.
  Let R' : full_sub_category C₂ Q ⟶ full_sub_category C₁ P
    := full_sub_category_functor Q P _ HR.

  Definition full_sub_category_equivalence_unit_data
    : nat_trans_data
        (functor_identity (full_sub_category C₁ P))
        (L' ∙ R')
    := λ y, unit_from_left_adjoint L_equiv (pr1 y) ,, tt.

  Definition full_sub_category_equivalence_unit_is_nat_trans
    : is_nat_trans
        _ _
        full_sub_category_equivalence_unit_data.
  Proof.
    intros y₁ y₂ f ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    apply (nat_trans_ax (unit_from_left_adjoint L_equiv)).
  Qed.

  Definition full_sub_category_equivalence_unit
    : functor_identity _ ⟹ L' ∙ R'.
  Proof.
    use make_nat_trans.
    - exact full_sub_category_equivalence_unit_data.
    - exact full_sub_category_equivalence_unit_is_nat_trans.
  Defined.

  Definition full_sub_category_equivalence_counit_data
    : nat_trans_data
        (R' ∙ L')
        (functor_identity _)
    := λ y, counit_from_left_adjoint L_equiv (pr1 y) ,, tt.

  Definition full_sub_category_equivalence_counit_is_nat_trans
    : is_nat_trans
        _ _
        full_sub_category_equivalence_counit_data.
  Proof.
    intros y₁ y₂ f ; cbn.
    use subtypePath.
    {
      intro.
      apply isapropunit.
    }
    cbn.
    apply (nat_trans_ax (counit_from_left_adjoint L_equiv)).
  Qed.

  Definition full_sub_category_equivalence_counit
    : R' ∙ L' ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - exact full_sub_category_equivalence_counit_data.
    - exact full_sub_category_equivalence_counit_is_nat_trans.
  Defined.

  Definition full_sub_category_equivalence
    : equivalence_of_cats
        (full_sub_category C₁ P)
        (full_sub_category C₂ Q).
  Proof.
    use make_equivalence_of_cats.
    - use make_adjunction_data.
      + exact L'.
      + exact R'.
      + exact full_sub_category_equivalence_unit.
      + exact full_sub_category_equivalence_counit.
    - split.
      + intro.
        apply is_iso_full_sub.
        apply unit_nat_z_iso_from_adj_equivalence_of_cats.
      + intro.
        apply is_iso_full_sub.
        apply counit_nat_z_iso_from_adj_equivalence_of_cats.
  Defined.

  Definition full_sub_category_adj_equivalence
    : adj_equivalence_of_cats (full_sub_category_functor P Q L HL)
    := adjointificiation
         full_sub_category_equivalence.
End EquivalenceFullSub.


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

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

Print Assumptions add.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal9.

From lfind Require Import LFind.
Lemma lfind_state  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) (IHl:@eq lst (drop (Succ x1) (drop (Succ x2) (Cons x3 l)))
  (drop (Succ x2) (drop (Succ x1) (Cons x3 l)))):@eq lst (drop x2 (drop (Succ x1) (Cons n l)))
  (drop x1 (drop (Succ x2) (Cons n l))).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal9_drop_Cons_assoc_33_drop_Cons/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x1:natural) (x2:natural) (x3:natural) (n:natural) (l:lst) :=
 let lfind_var := "x1:" ++ "(" ++ show x1 ++ ")"++ "|" ++"x2:" ++ "(" ++ show x2 ++ ")"++ "|" ++"x3:" ++ "(" ++ show x3 ++ ")"++ "|" ++"n:" ++ "(" ++ show n ++ ")"++ "|" ++"l:" ++ "(" ++ show l ++ ")"
 in let lfind_v := print x1 lfind_var
 in lfind_state lfind_v  x2 x3 n l.
QuickChick collect_data.
Success.


Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import UniMath.RezkCompletion.limits.products.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import UniMath.RezkCompletion.limits.initial.
Require Import UniMath.RezkCompletion.FunctorAlgebras.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.Signatures.
Require Import SubstSystems.SubstitutionSystems.
Require Import SubstSystems.FunctorsPointwiseCoproduct.
Require Import SubstSystems.GenMendlerIteration.
(* Require Import SubstSystems.FunctorAlgebraViews. *)
Require Import SubstSystems.RightKanExtension.
Require Import SubstSystems.GenMendlerIteration.
Require Import SubstSystems.EndofunctorsMonoidal.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).
Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).
Local Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) (at level 50).

Local Coercion alg_carrier : algebra_ob >-> ob.

Arguments θ_source {_ _} _ .
Arguments θ_target {_ _} _ .
Arguments θ_Strength1 {_ _ _} _ .
Arguments θ_Strength2 {_ _ _} _ .

Section Precategory_Algebra.

Variable C : precategory.
Variable hs : has_homsets C.

Variable CP : Coproducts C.

Local Notation "'EndC'":= ([C, C, hs]) .
Local Notation "'Ptd'" := (precategory_Ptd C hs).
Local Notation "'U'" := (functor_ptd_forget C hs).

Let hsEndC : has_homsets EndC := functor_category_has_homsets C C hs.
Let CPEndC : Coproducts EndC := Coproducts_functor_precat _ _ CP hs.
Let EndEndC := [EndC, EndC, hsEndC].
Let CPEndEndC:= Coproducts_functor_precat _ _ CPEndC hsEndC: Coproducts EndEndC.
(*Opaque CPEndEndC.*)

Definition ℓ (X : EndC) : EndEndC := (pre_composition_functor C C C hs hs X).
(*   in Agda mode \ell *)

(*
Opaque hsEndC.
*)
(*Opaque CPEndC.*)

Variable KanExt : ∀ Z : Ptd, GlobalRightKanExtensionExists _ _ (U Z) _ hs hs.

Variable H : Signature C hs.
Let θ := theta H.

Definition Const_plus_H (X : EndC) : functor EndC EndC
  := coproduct_functor _ _ CPEndC
                       (constant_functor _ _ X)
                       H.

Definition Id_H := Const_plus_H (functor_identity _ : EndC).

Let Alg : precategory := precategory_FunctorAlg _ Id_H hsEndC.

Variable IA : Initial Alg.
Definition SpecializedGMIt (Z : Ptd) (X : EndC) :=
  SpecialGenMendlerIteration _ _ _ IA EndC hsEndC X _ (KanExt Z) .

Definition θ_in_first_arg (Z: Ptd) := nat_trans_fix_snd_arg _ _ _ _ _ θ Z.

Definition InitAlg : Alg := InitialObject _ IA.

(* original try in bracket_for_InitAlg with
  assert (iso_1 : functor_composite Id_H (pre_composition_functor C C C hs hs (U Z)) ⟶
                 coproduct_functor_data ([C, C] hs) ([C, C] hs) CPEndC
    (constant_functor ([C, C] hs) ([C, C] hs) (pr1 Z))
    (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z) : EndEndC ⟦ _ , _ ⟧ ).
  { admit. }
 *)

Lemma aux_iso_1_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (functor_composite Id_H (ℓ (U Z)))
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))))
     (λ X : [C, C] hs,
      CoproductOfArrows ([C, C] hs)
        (CPEndC (functor_composite (U Z) (functor_identity C))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (ρ_functor C (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    eapply pathscomp0.
    apply CoproductOfArrows_comp.
    eapply pathscomp0.
Focus 2.
    eapply pathsinv0.
    apply CoproductOfArrows_comp.
    apply CoproductOfArrows_eq.
    + rewrite id_right.
      apply pathsinv0.
      apply id_right.
    + rewrite functor_id.
      do 2 rewrite id_right.
      apply pathsinv0.
      apply id_left.
Qed.

Definition aux_iso_1 (Z: Ptd): EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
                            CoproductObject EndEndC
           (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
              (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))
                          ⟧.
Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (CoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (ρ_functor _ (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))).
  - exact (aux_iso_1_is_nat_trans Z).
Defined.

Lemma aux_iso_1_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))) )
     (functor_composite Id_H (ℓ (U Z)))
     (λ X : [C, C] hs,
      CoproductOfArrows ([C, C] hs)
        (CPEndC (functor_composite (functor_identity C) (U Z))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (λ_functor C (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    eapply pathscomp0.
    apply CoproductOfArrows_comp.
    eapply pathscomp0.
Focus 2.
    eapply pathsinv0.
    apply CoproductOfArrows_comp.
    apply CoproductOfArrows_eq.
    + rewrite id_right.
      apply pathsinv0.
      apply id_right.
    + rewrite functor_id.
      do 2 rewrite id_right.
      apply pathsinv0.
      apply id_left.
Qed.

Definition aux_iso_1_inv (Z: Ptd): EndEndC ⟦ CoproductObject EndEndC
           (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
              (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z)),
             functor_composite Id_H (ℓ (U Z)) ⟧.
Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (CoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (λ_functor _ (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.
 *)

Lemma aux_iso_2_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z))) )
     (functor_composite (ℓ (U Z))
        (Const_plus_H (U Z)))
     (λ X : [C, C] hs,
      nat_trans_id
        (CoproductObject ([C, C] hs) (CPEndC (U Z) ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    rewrite (id_left EndC).
    rewrite (id_right EndC).
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    apply CoproductOfArrows_eq.
    + apply idpath.
    + unfold functor_fix_snd_arg_mor; simpl.
      unfold θ_target_mor; simpl.
      revert c.
      apply nat_trans_eq_pointwise.
      apply maponpaths.
      apply nat_trans_eq; try (exact hs).
      intro c.
      simpl.
      rewrite <- (nat_trans_ax α).
      rewrite functor_id.
      apply id_left.
Qed.

Definition aux_iso_2_inv (Z: Ptd): EndEndC ⟦
                           CoproductObject EndEndC
         (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
                    (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z)),

                       functor_composite (ℓ (U Z) )   (Const_plus_H (U Z)) ⟧.
  Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (nat_trans_id ((@CoproductObject 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):= CoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_precategory EndC EndC hsEndC)) (θ_in_first_arg Z).

Definition ρ_Thm15 (Z: Ptd)(f : Ptd ⟦ Z,  ptd_from_alg _ _ _ _ InitAlg ⟧):= @CoproductArrow EndC _ _  (CPEndC (U Z) (H (pr1 InitAlg))) (pr1 InitAlg) (#U f)(CoproductIn2 _ _ ;; (alg_map _ _ InitAlg)).

Definition SpecializedGMIt_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) := 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 : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :=
   pr1 (pr1 (SpecializedGMIt_Thm15 Z f)).

(* the property in h_eq in the Alg world has to be translated into the ALG setting *)
(* we prove the individual components for ease of compilation *)
Lemma bracket_Thm15_ok_part1 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
# U f =
 # (pr1 (ℓ (U Z)))
   (eta_from_alg _ _ _ _ (InitAlg));;
 bracket_Thm15 Z f.
Proof.
  apply nat_trans_eq; try (exact hs).
  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⟧ => (CoproductIn1 EndC (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 |- _ = _   ] =>
         pathvia (f) end.

  *      clear h_eq1'_inst.
         unfold coproduct_nat_trans_data; simpl.
         unfold coproduct_nat_trans_in1_data ; simpl.
         repeat rewrite <- assoc .
         apply CoproductIn1Commutes_right_in_ctx_dir.
         unfold λ_functor; simpl.
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         unfold ρ_functor; simpl.
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         rewrite (id_left EndC).
(*         rewrite (id_left EndC). *)
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         rewrite (id_left EndC).
         apply CoproductIn1Commutes_right_dir.
         apply idpath.
  *      rewrite <- h_eq1'_inst.
         clear h_eq1'_inst.

         apply CoproductIn1Commutes_left_in_ctx_dir.
         unfold λ_functor, 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.   (* one may consider Admitted for speedup during development *)

(* produce some output to keep TRAVIS running *)
Check bracket_Thm15_ok_part1.

Lemma bracket_Thm15_ok_part2 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 (theta H) ((pr1 InitAlg) ⊗ Z);;
   # H (bracket_Thm15 Z f);;
   tau_from_alg  _ _ _ _ InitAlg =
   # (pr1 (ℓ (U Z)))
     (tau_from_alg  _ _ _ _  InitAlg);;
   bracket_Thm15 Z f.
Proof.
  apply nat_trans_eq; try (exact hs).
  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⟧ => (CoproductIn2 EndC (CPEndC _ _));; m) h_eq').
         clear h_eq'.
         assert (h_eq2'_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h_eq2' c).
         clear h_eq2'.
 (*        simpl in h_eq2'_inst. *)
         match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.
         + clear h_eq2'_inst.
 (*          unfold coproduct_nat_trans_data.
           unfold coproduct_nat_trans_in2_data.
*)
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold aux_iso_1; simpl.
           rewrite id_right.
           rewrite id_left.
           do 3 rewrite <- assoc.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_id; simpl. rewrite id_left.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_fix_snd_arg_data.
           apply CoproductIn2Commutes_right_in_double_ctx_dir.
           rewrite <- assoc.
           apply maponpaths.
           eapply pathscomp0. Focus 2. apply assoc.
           apply maponpaths.
           apply pathsinv0.
           apply CoproductIn2Commutes.

(* alternative with slightly less precise control:
           do 4 rewrite <- assoc.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           rewrite id_left.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_fix_snd_arg_data.
           rewrite id_left.
           apply CoproductIn2Commutes_right_in_double_ctx_dir.
           do 2 rewrite <- assoc.
           apply maponpaths.
           apply maponpaths.
           apply pathsinv0.
           apply CoproductIn2Commutes.
*)
         + rewrite <- h_eq2'_inst. clear h_eq2'_inst.
           apply CoproductIn2Commutes_left_in_ctx_dir.
           (* unfold Coproducts_functor_precat.
              unfold functor_precat_coproduct_cocone. *)
(*           simpl. *)
           (* unfold coproduct_nat_trans_in2_data. *)
           repeat rewrite id_left.
           apply assoc.
(*           repeat rewrite <- assoc.
           (* apply maponpaths.
              apply maponpaths. *)
           apply idpath. *)
Qed. (* Qed works fine but takes quite some time, hence Admitted for the purpose of development *)

(* produce some output to keep TRAVIS running *)
Check bracket_Thm15_ok_part2.

Lemma bracket_Thm15_ok (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 bracket_property_parts _ hs CP H InitAlg f (bracket_Thm15 Z 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 : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 bracket_property _ hs CP H InitAlg f (bracket_Thm15 Z f).
Proof.
  apply whole_from_parts.
  apply bracket_Thm15_ok.
Qed.

(* we will directly need the later lemma foo'
Lemma foo (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :
 ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       bracket_property_parts _ hs CP H InitAlg f h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      bracket_property_parts _ hs CP H InitAlg f h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok Z f).
(*
   ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       # U f =
       # (pre_composition_functor_data C C C hs hs (U Z))
         (eta_from_alg _ _ _ _  InitAlg);; h
       × (theta H) ((pr1 InitAlg) ⊗ Z);; # H h;;
         tau_from_alg _ _ _ _  InitAlg =
         # (pre_composition_functor_data C C C hs hs (U Z))
           (tau_from_alg _ _ _ _  InitAlg);; h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      # U f =
      # (pre_composition_functor_data C C C hs hs (U Z))
        (eta_from_alg _ _ _  _ InitAlg);; h
      × (theta H) ((pr1 InitAlg) ⊗ Z);; # H h;;
        tau_from_alg _ _ _ _  InitAlg =
        # (pre_composition_functor_data C C C hs hs (U Z))
          (tau_from_alg _ _ _ _  InitAlg);; h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok Z f).
*)
Proof.
  intros [h' [h'_eq1 h'_eq2]].
    (* simpl in *. *)
    apply total2_paths_second_isaprop.
    + apply isofhleveltotal2.
      * apply isaset_nat_trans. exact hs.
      * intro Hyp. apply isaset_nat_trans. exact hs.
    + simpl.
      unfold bracket_Thm15.
      apply path_to_ctr.
      apply nat_trans_eq; try (exact hs).
      intro c; simpl.
      unfold coproduct_nat_trans_data.
      repeat rewrite (id_left EndC).
      rewrite id_right.
      repeat rewrite <- assoc.
      eapply pathscomp0.
Focus 2.
      eapply pathsinv0.
      apply postcompWithCoproductArrow.
      apply CoproductArrowUnique.
      * simpl.
        clear h'_eq2.
        rewrite (id_left C).
(*        unfold coproduct_nat_trans_in1_data; simpl. *)
        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.
        eapply pathscomp0.
          eapply pathsinv0.
          exact h'_eq1_inst.
        clear h'_eq1_inst.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * clear h'_eq1.
        (*simpl.
        unfold coproduct_nat_trans_in2_data; simpl. *)
        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.
        eapply pathscomp0.
          exact h'_eq2_inst. clear h'_eq2_inst.

        apply CoproductIn2Commutes_right_in_ctx_dir.
        apply CoproductIn2Commutes_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 CoproductIn2Commutes.
Qed.
*)

Lemma foo' (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :
 ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       bracket_property _ hs CP H InitAlg f h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      bracket_property _ hs CP H InitAlg f h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok_cor Z f).
Proof.
   intros [h' h'_eq].
    (* simpl in *. *)
    apply total2_paths_second_isaprop.
    + unfold bracket_property.
      apply isaset_nat_trans. exact hs.
    + 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; try (exact hs).
      intro c; simpl.
      unfold coproduct_nat_trans_data.
      repeat rewrite (id_left EndC).
      rewrite id_right.
      repeat rewrite <- assoc.
      eapply pathscomp0.
Focus 2.
      eapply pathsinv0.
      apply postcompWithCoproductArrow.
      apply CoproductArrowUnique.
      * simpl.
        clear h'_eq2.
        rewrite (id_left C).
(*        unfold coproduct_nat_trans_in1_data; simpl. *)
        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.
        eapply pathscomp0.
          eapply pathsinv0.
          exact h'_eq1_inst.
        clear h'_eq1_inst.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * clear h'_eq1.
        (*simpl.
        unfold coproduct_nat_trans_in2_data; simpl. *)
        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.
        eapply pathscomp0.
          exact h'_eq2_inst. clear h'_eq2_inst.

        apply CoproductIn2Commutes_right_in_ctx_dir.
        apply CoproductIn2Commutes_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 CoproductIn2Commutes.
Qed.

Definition bracket_for_InitAlg : bracket _ _ CP H (InitAlg).
Proof.
  intros Z f.
  refine (tpair _ _ _ ).
  - refine (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 *)
  - apply foo'.
Defined.

(* produce some output to keep TRAVIS running *)
Check bracket_for_InitAlg.

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

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

Definition constant_nat_trans (C' D : precategory) (hsD : has_homsets D) (d d' : D) (m : d ⇒ d')
    : [C', D, hsD] ⟦constant_functor C' D d, constant_functor C' D d'⟧.
Proof.
  exists (fun _ => m).
  abstract (
    intros ? ? ? ;
    pathvia m ;
    [
    apply id_left |
    apply pathsinv0 ;
  apply id_right] ).
Defined.

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

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

Lemma is_nat_trans_iso2' (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z))))
     (functor_composite (ℓ (U Z)) Ghat)
     (λ X : [C, C] hs,
      nat_trans_id
        (CoproductObject ([C, C] hs)
           (CPEndC
              ((constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg)) X)
              ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    rewrite (id_left EndC).
    rewrite (id_right EndC).
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    apply CoproductOfArrows_eq.
    + apply idpath.
    + unfold functor_fix_snd_arg_mor; simpl.
      unfold θ_target_mor; simpl.
      revert c.
      apply nat_trans_eq_pointwise.
      apply maponpaths.
      apply nat_trans_eq; try (exact hs).
      intro c.
      simpl.
      rewrite <- (nat_trans_ax α).
      rewrite functor_id.
      apply id_left.
Qed.

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

Definition thetahat (Z : Ptd)  (f : Z ⇒ 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.

Require Import UniMath.RezkCompletion.opp_precat.
Require Import UniMath.RezkCompletion.yoneda.
Require Import UniMath.RezkCompletion.category_hset.

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

Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC hsEndC 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.
  refine (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 ;
    [
      assumption
        |
      simpl ; intros ? ;
      apply pathsinv0, assoc ]).
Defined.

Lemma ishssMor_InitAlg (T' : hss CP H) :
  @ishssMor C hs CP H
        InitHSS T'
           (InitialArrow Alg IA (pr1 T') : algebra_mor EndC Id_H InitAlg T' ).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  set (β0 := InitialArrow Alg IA (pr1 T')).
  match goal with | [|- _ ;; ?b = _ ] => set (β := b) end.
  set ( rhohat := CoproductArrow EndC  (CPEndC _ _ )  β (tau_from_alg _ _ _ _ T')
                  :  pr1 Ghat T' ⇒ T').
  set (X:= SpecializedGMIt Z _ Ghat rhohat (thetahat Z f)).
  pathvia (pr1 (pr1 X)).
  - set (TT:= fusion_law _ _ _ IA _ hsEndC (pr1 InitAlg) T' _ (KanExt Z)).
    set (Psi := ψ_from_comps _ (Id_H) _ hsEndC _ (ℓ (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) _ hsEndC _ (ℓ (U Z)) (Ghat) (rhohat)
                             (iso1' Z ;; thetahat_0 Z f ;; iso2' Z) ).
    set (T4 := T3 Psi').
    set (Φ := (Phi_fusion Z T' β)).
    set (T5 := T4 Φ).
    pathvia (Φ _ (fbracket InitHSS f)).
      apply idpath.
    eapply pathscomp0.
      Focus 2.
        eapply T5.
      (* hypothesis of fusion law *)
      apply funextsec. intro.
      simpl.
      unfold compose. simpl.
      apply nat_trans_eq. assumption.
      simpl.
      intro c.
      rewrite id_right.
      rewrite id_right.
      (* should be decomposed into two diagrams *)
      apply CoproductArrow_eq_cor.
      * (* first diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        rewrite <- assoc.
        apply maponpaths.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * (* a bit out of order what follows *)
        apply cancel_postcomposition.
        apply idpath.
      * (* second diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_ctx_dir.
        rewrite (id_left EndC).
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_ctx_dir.
        simpl.
        unfold nat_trans_fix_snd_arg_data.
        repeat rewrite <- assoc.
        apply maponpaths.
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_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  ] =>
         pathvia (f;;g;;h) end.
        + clear H_nat_inst_c.
          simpl.
          repeat rewrite <- assoc.
          apply maponpaths.
          apply CoproductIn2Commutes_left_in_ctx_dir.
          simpl.
          unfold coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
          assert (Hyp := τ_part_of_alg_mor _ hs CP _ _ _ (InitialArrow Alg IA (pr1 T'))).
          assert (Hyp_c := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
          simpl in Hyp_c.
          eapply pathscomp0.
            eapply pathsinv0.
            exact Hyp_c.
          clear Hyp_c.
          apply maponpaths.
          apply pathsinv0.
          apply CoproductIn2Commutes.
        + rewrite <- H_nat_inst_c.
          apply idpath.
  - apply pathsinv0.
    apply path_to_ctr.
    (* now a lot of serious verification work to be done *)
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    rewrite id_right.
    (* look at type:
       match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply CoproductArrow_eq_cor.
    + repeat rewrite <- assoc.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply CoproductIn1Commutes_right_in_ctx_dir.

      simpl.
      repeat rewrite <- assoc.

      eapply pathscomp0.
Focus 2.
      apply maponpaths.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_dir.
      apply idpath.

      do 2 rewrite assoc.
      eapply pathscomp0.
        apply cancel_postcomposition.
        assert (ptd_mor_commutes_inst := ptd_mor_commutes _ (ptd_from_alg_mor _ hs CP H β0) ((pr1 Z) c)).
        apply ptd_mor_commutes_inst.

      eapply pathscomp0.
        eapply pathsinv0.
        assert (fbracket_η_inst := fbracket_η T' (f;; ptd_from_alg_mor _ hs CP H β0)).
        assert (fbracket_η_inst_c := nat_trans_eq_pointwise _ _ _ _ _ _ fbracket_η_inst c); clear fbracket_η_inst.
        apply fbracket_η_inst_c.

      rewrite functor_comp.
      apply idpath.
    + (* now the difficult case *)
      repeat rewrite <- assoc.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      unfold nat_trans_fix_snd_arg_data.
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.

      eapply pathscomp0.
Focus 2.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.

      do 2 rewrite assoc.
      eapply pathscomp0.
        apply cancel_postcomposition.
        eapply pathsinv0.
        assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ hs 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.
      eapply pathscomp0.
        apply maponpaths.
        rewrite assoc.
        eapply pathsinv0.
        assert (fbracket_τ_inst := fbracket_τ T' (f;; ptd_from_alg_mor _ hs 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;; ptd_from_alg_mor C hs CP H β0)) = θ (tpair (λ _ : functor C C, ptd_obj C) (pr1 (pr1 IA)) Z) ;; # H (# (pr1 (ℓ(U Z))) β ;; fbracket T' (f;; ptd_from_alg_mor C hs CP H β0)))).

Focus 2.
      assert (Hyp_c := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
      exact Hyp_c.

      clear c.
      rewrite (functor_comp H).
      rewrite assoc.
      apply cancel_postcomposition.
      fold θ.
      apply nat_trans_eq; try (exact hs).
      intro c.
      assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ hs H θ _ _ β Z c).
      eapply pathscomp0 ; [exact θ_nat_1_pointwise_inst | ].
      clear θ_nat_1_pointwise_inst.
      simpl.
      apply maponpaths.
      assert (Hyp: # H (β ∙∙ nat_trans_id (pr1 Z)) = # H (# (pr1 (ℓ(U Z))) β)).
      { apply maponpaths.
        apply nat_trans_eq; try (exact hs).
        intro c'.
        simpl.
        rewrite functor_id.
        apply id_right. }
      apply (nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c).
Qed.

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

Lemma hss_InitMor_unique (T' : hss_precategory CP H):
  ∀ t : hss_precategory CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'.
Proof.
  intro t.
  (* show lemma that says that two hss morphisms are equal if their underlying alg morphisms are *)
  apply (invmap (hssMor_eq1 _ _ _ _ _ _ _ _ )).
  set (T2:= pr2 IA).
  simpl in T2.
  set (T3 := T2 (pr1 T')).
  simpl.
  set (T4 := pr2 T3).
  simpl in T4.
  set (T5 := T4 (pr1 t)).
  apply T5.
Qed.

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

(*
  simpl.
  set (T' :=  (pr1 T)).
*)
(*
  assert (auxT' : ALG_from_Alg C hs CP H T' = pr1 T).
Focus 2.
 *)
(*
  set (β := InitialArrow _ IA T').
  (*set (β' := ALG_mor_from_Alg_mor _ hs CP _ β). *)
  refine (tpair _ _ _ ).
  - refine (tpair _ _ _ ).
    apply β.
    unfold ishssMor.
    unfold isbracketMor.
    intros Z f.
*)

(*

    + refine (tpair _ _ _ ).
      * apply β.
      * destruct β as [β βalg].
        assert (β_is_ptd := pr2 (pr1 β')).
        simpl in β_is_ptd.
        unfold is_ptd_mor in β_is_ptd. simpl in *.
        unfold is_ptd_mor. simpl.
        (* does not work: apply β_is_ptd.*)
        intro c.
        assert (β_is_ptd_inst := β_is_ptd c); clear β_is_ptd.
        eapply pathscomp0.
          exact  β_is_ptd_inst.
        clear β_is_ptd_inst.
        apply CoproductIn1Commutes.
 *)
(*
   + destruct β as [β βalg].
      simpl in *.
      unfold ishssMor.
      split.
      * assert (β_isALGMor := pr2 β').
        unfold isALGMor. simpl.
        unfold isALGMor in β_isALGMor. simpl in β_isALGMor.
        eapply pathscomp0. Focus 2. apply β_isALGMor.
        apply maponpaths.
        apply pathsinv0.
        eapply pathscomp0.
        apply (CoproductIn2Commutes EndC). apply idpath.
      * simpl.
        unfold isbracketMor. simpl.
        intros Z f.
(*        destruct β as [β βalg]; simpl in *.
        unfold isbracketMor. simpl.
        intros Z f.
*)
*)

        (* now define Ψ for fusion law *)

Lemma Ihss : Initial (hss_precategory CP H).
Proof.
  exists InitHSS.
  apply isInitial_InitHSS.
Defined.

End Precategory_Algebra.

(*

(** Define the precategory of Id+H-algebras.

    We could define this precategory before that of hss, and
    define hss as a sub-precategory of that of Id+H-algebras
    As a consequence, we would have faithfulness of the forgetful
    functor for free.
    Also, composition and identity would be inherited instead of
    having to be defined twice.

    On the other hand, the category of hss is the main object of
    investigation, so maybe it is better to give it more explicitly.
    Working with sub-precategories is a pain in the butt.

*)

Local Notation "'Alg_obj'" := (Alg H).

Definition Alg_mor (A B : Alg_obj) : UU
  := Σ f : Ptd ⟦A, B⟧, isAlgMor C hs H f.

(* explicit coercion not necessary, this works, too:
Definition Alg_mor' (A B : Alg_obj) : UU
  := Σ f : A ⇒ pr1 B, isAlgMor C hs H f.
*)

Coercion Ptd_mor_from_Alg_mor (A B : Alg_obj)(f : Alg_mor A B) : Ptd ⟦A, B⟧ := pr1 f.

Definition isAlgMor_Alg_mor (A B : Alg_obj)(f : Alg_mor A B) : isAlgMor _ _ _ f := pr2 f.

Definition Alg_mor_eq_weq (A B : Alg_obj) (f g : Alg_mor A B)
  : f = g ≃ #U f = #U g.
Proof.
  eapply weqcomp.
  - apply total2_paths_isaprop_equiv.
    intro h. apply isaprop_isAlgMor.
  - apply eq_ptd_mor.
    apply hs.
Defined.

Definition isAlgMor_id (A : Alg_obj) : isAlgMor C hs H (identity A : Ptd⟦A,A⟧).
Proof.
  unfold isAlgMor.
  rewrite functor_id.
  rewrite functor_id.
  rewrite id_left.
  set (H2 := id_right ([C,C,hs])).
  apply pathsinv0, H2.
Qed.

Definition AlgMor_id (A : Alg_obj) : Alg_mor A A := tpair _ _ (isAlgMor_id A).

Definition isAlgMor_comp (A B D : Alg_obj) (f : Alg_mor A B) (g : Alg_mor B D)
  : isAlgMor C hs H (f ;; g : Ptd⟦A, D⟧).
Proof.
  unfold isAlgMor.
  rewrite functor_comp.
  rewrite functor_comp.
  rewrite <- assoc.
  rewrite isAlgMor_Alg_mor.
  rewrite assoc.
  rewrite isAlgMor_Alg_mor.
  apply pathsinv0, assoc.
Qed.

Definition AlgMor_comp (A B D : Alg_obj) (f : Alg_mor A B) (g : Alg_mor B D) : Alg_mor A D
  := tpair _ _ (isAlgMor_comp A B D f g).

Definition Alg_precategory_ob_mor : precategory_ob_mor.
Proof.
  exists Alg_obj.
  exact (Alg_mor).
Defined.

Definition Alg_precategory_data : precategory_data.
Proof.
  exists Alg_precategory_ob_mor.
  split.
  - exact AlgMor_id.
  - exact AlgMor_comp.
Defined.

Lemma is_precategory_Alg : is_precategory Alg_precategory_data.
Proof.
  repeat split; intros.
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (id_left EndC).
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (id_right EndC).
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (assoc EndC).
Qed.

Definition precategory_Alg : precategory := tpair _ _ is_precategory_Alg.

Local Notation "'ALG'" := precategory_Alg.
 *)


(** * Colim -| Diag -| Lim **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import
        COC.Base.Main
        COC.Limit.Main
        COC.Adj.Adjunction.

Program Definition Diagonal_functor (J C: Category)
  : C --> (C^J) :=
  [Functor by f :-> [X in J :=> f]
   with X :-> [ * in J |-> X in C ]].
Next Obligation.
  now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition Colimit_functor (J C: Category)(colim: forall (D: J --> C), Colimit D)
  : (C^J) --> C :=
  [Functor by (fun D D' S => colimit_univ (colim D) [Cocone by i :-> (colim D') i \o S i] )
   with `(colim D)].
Next Obligation.
  rewrite cat_comp_assoc, natrans_naturality.
  rewrite <- cat_comp_assoc.
  now rewrite (cocone_commute (IsCocone:=colim D')).
Qed.
Next Obligation.
  - rename X into D, Y into D'.
    intros S T Heq; simpl.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D') i \o T i])(u:=colimit_univ (colim D) [ Cocone by i :-> (colim D') i \o S i])); simpl.
    intros j; simpl.
    rewrite <- (Heq j).
    now rewrite (colimit_universality (IsColimit:=colim D)[Cocone by i :-> colim D' i \o S i]).

  - rename X into D, Y into D', Z into D''.
    rename f into S, g into T.
    symmetry.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D'') i \o T i \o S i])).
    simpl; intros i.
    rewrite cat_comp_assoc.
    rewrite (colimit_universality (IsColimit:=colim D)[ Cocone by i :-> (colim D') i \o S i]); simpl.
    rewrite <- cat_comp_assoc.
    rewrite (colimit_universality (IsColimit:=colim D')[ Cocone by i :-> (colim D'') i \o T i]); simpl.
    now rewrite cat_comp_assoc.
  - symmetry.
    rename X into D.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D) i \o Id (D i)])); simpl.
    intros i.
    now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition colimit_diag_adjunction
        (J C: Category)
        (colim: forall (D: J --> C), Colimit D)
  : Colimit_functor colim -| Diagonal_functor J C :=
  [Adj by (fun D c => [f :-> [i in J :=> f \o colim D i]]),
          (fun D c => [g :-> colimit_univ (colim D) [Cocone by g to c]])].
Next Obligation.
  rename X into i, Y into j, f0 into u.
  rewrite cat_comp_assoc, (cocone_commute (IsCocone:=colim D)).
  now rewrite cat_comp_id_cod.
Qed.
Next Obligation.
  intros f g Heq i; simpl.
  now rewrite Heq.
Qed.
Next Obligation.
  rewrite (natrans_naturality (IsNatrans:=g)); simpl.
  now rewrite cat_comp_id_cod.
Qed.
Next Obligation.
  intros S T Heq; simpl.
  apply (colimit_uniqueness (IsColimit:=colim D)(c:=[Cocone by T to c])(u:=colimit_univ (colim D) [Cocone by S to c])); simpl.
  intros i.
  rewrite <- (Heq i).
  now rewrite (colimit_universality (IsColimit:=colim D) [Cocone by S to c]).
Qed.
Next Obligation.
  - symmetry.
    now apply (colimit_uniqueness (IsColimit:=colim c)(c:=[Cocone by i :-> f \o (colim c) i])); simpl.
  - now rewrite (colimit_universality (IsColimit:=colim c) [Cocone by g to d]).
  - rewrite !cat_comp_assoc.
    now rewrite (colimit_universality (IsColimit:=colim c')[Cocone by i :-> (colim c) i \o f i]).
Qed.

Program Definition Limit_functor (J C: Category)(lim: forall (D: J --> C), Limit D)
  : (C^J) --> C :=
  [Functor by (fun D D' S => limit_univ (lim D') [Cone by i :-> S i \o (lim D) i] )
   with `(lim D)].
Next Obligation.
  rewrite <- cat_comp_assoc, <- natrans_naturality.
  rewrite cat_comp_assoc.
  now rewrite (cone_commute (IsCone:=lim D)).
Qed.
Next Obligation.
  - rename X into D, Y into D'.
    intros S T Heq; simpl.
    apply (limit_uniqueness (IsLimit:=lim D')(c:=[ Cone by i :-> T i \o (lim D) i])(u:=limit_univ (lim D') [ Cone by i :-> S i \o (lim D) i])); simpl.
    intros j; simpl.
    rewrite <- (Heq j).
    now rewrite (limit_universality (IsLimit:=lim D')[Cone by i :-> S i \o lim D i]).
  - rename X into D, Y into D', Z into D''.
    rename f into S, g into T.
    symmetry.
    apply (limit_uniqueness (IsLimit:=lim D'')(c:=[ Cone by i :-> (T i \o S i) \o (lim D i)])).
    simpl; intros i.
    rewrite <- cat_comp_assoc.
    rewrite (limit_universality (IsLimit:=lim D'')[ Cone by i :-> T i \o (lim D') i]); simpl.
    rewrite cat_comp_assoc.
    rewrite (limit_universality (IsLimit:=lim D')[ Cone by i :-> S i \o (lim D) i]); simpl.
    now rewrite cat_comp_assoc.
  - symmetry.
    rename X into D.
    apply (limit_uniqueness (IsLimit:=lim D)(c:=[ Cone by i :-> Id (D i) \o (lim D) i])); simpl.
    intros i.
    now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition diag_limit_adjunction
        (J C: Category)
        (lim: forall (D: J --> C), Limit D)
  : Diagonal_functor J C -| Limit_functor lim :=
  [Adj by (fun c D => [g :-> limit_univ (lim D) [Cone by g from c]]),
          (fun c D => [f :-> [i in J :=> lim D i \o f]])].
Next Obligation.
  rewrite <- (natrans_naturality (IsNatrans:=g)); simpl.
  now rewrite cat_comp_id_dom.
Qed.
Next Obligation.
  intros S T Heq; simpl.
  apply (limit_uniqueness (IsLimit:=lim D)(c:=[Cone by T from c])(u:=limit_univ (lim D) [Cone by S from c])); simpl.
  intros i.
  rewrite <- (Heq i).
  now rewrite (limit_universality (IsLimit:=lim D) [Cone by S from c]).
Qed.
Next Obligation.
  rename X into i, Y into j, f0 into u.
  rewrite <- cat_comp_assoc, (cone_commute (IsCone:=lim D)).
  now rewrite cat_comp_id_dom.
Qed.
Next Obligation.
  intros f g Heq i; simpl.
  now rewrite Heq.
Qed.
Next Obligation.
  - now rewrite (limit_universality (IsLimit:=lim d)[Cone by f from c]).
  - symmetry.
    now apply (limit_uniqueness (IsLimit:=lim d)(c:=[Cone by i :-> (lim d) i \o g])); simpl.
  - rename d into D, d' into D', g into S, h into T.
    symmetry.
    apply (limit_uniqueness (IsLimit:=lim D')(c:=[ Cone by X :-> S X \o T X \o f])); simpl.
    intros i.
    rewrite <- !cat_comp_assoc.
    apply cat_comp_proper; try now idtac.
    rewrite (limit_universality (IsLimit:=lim D')[ Cone by i :-> S i \o (lim D) i]); simpl.
    rewrite cat_comp_assoc.
    now rewrite (limit_universality (IsLimit:=lim D) [ Cone by T from c]); simpl.
Qed.


Require Import List.
Import ListNotations.
Require Import Sumbool.

Ltac break_let :=
  match goal with
    | [ H : context [ (let (_,_) := ?X in _) ] |- _ ] => destruct X eqn:?
    | [ |- context [ (let (_,_) := ?X in _) ] ] => destruct X eqn:?
  end.

Ltac find_injection :=
  match goal with
    | [ H : ?X _ _ = ?X _ _ |- _ ] => injection H; intros; subst
  end.

Ltac break_and :=
  repeat match goal with
           | [H : _ /\ _ |- _ ] => destruct H
         end.

Ltac break_if :=
  match goal with
    | [ |- context [ if ?X then _ else _ ] ] =>
      match type of X with
        | sumbool _ _ => destruct X
        | _ => destruct X eqn:?
      end
  end.

Definition update2 {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (f : A -> A -> B) (x y : A) (v : B) :=
  fun x' y' => if sumbool_and _ _ _ _ (A_eq_dec x x') (A_eq_dec y y') then v else f x' y'.

Fixpoint collate {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (from : A) (f : A -> A -> list B) (ms : list (A * B)) :=
  match ms with
   | [] => f
   | (to, m) :: ms' => collate A_eq_dec from (update2 A_eq_dec f from to (f from to ++ [m])) ms'
  end.

Section Update2.
  Variables A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma collate_f_eq :
    forall (f : A -> A -> list B) g h n n' l,
      f n n' = g n n' ->
      collate A_eq_dec h f l n n' = collate A_eq_dec h g l n n'.
  Proof using.
    intros f g h n n' l.
    generalize f g; clear f g.
    induction l; auto.
    intros.
    simpl in *.
    break_let.
    destruct a.
    find_injection.
    set (f' := update2 _ _ _ _ _).
    set (g' := update2 _ _ _ _ _).
    rewrite (IHl f' g'); auto.
    unfold f', g', update2.
    break_if; auto.
    break_and.
    subst.
    rewrite H.
    trivial.
  Qed.
End Update2.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2020 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals ssreflect.

Require Import Rbar Hierarchy RInt Lim_seq Continuity Derive Rcomplements RInt_analysis.

(** This file describes improper integrals, such as integrals with an
infinity endpoint or integrals of a function with a singularity. A few
properties are given: Chasles, operations, composition, derivation.*)

Open Scope R_scope.

(** * Improper Riemann integral *)

Section is_RInt_gen.

Context {V : NormedModule R_AbsRing}.

Definition is_RInt_gen (f : R -> V) (Fa Fb : (R -> Prop) -> Prop) (l : V) :=
  filterlimi (fun ab => is_RInt f (fst ab) (snd ab)) (filter_prod Fa Fb) (locally l).
Definition ex_RInt_gen (f : R -> V) (Fa Fb : (R -> Prop) -> Prop) :=
  exists l : V, is_RInt_gen f Fa Fb l.

Definition is_RInt_gen_at_point f a b l :
  is_RInt_gen f (at_point a) (at_point b) l
    <-> is_RInt f a b l.
Proof.
split.
- intros H P HP.
  apply locally_locally in HP.
  specialize (H _ HP).
  destruct H as [Q R Qa Rb H].
  destruct (H a b Qa Rb) as [y [Hy1 Hy2]].
  now apply Hy1.
- intros Hl P HP.
  exists (fun x => x = a) (fun x => x = b) ; try easy.
  intros x y -> ->.
  exists l.
  apply (conj Hl).
  exact: locally_singleton.
Qed.

(** * Basic properties of integrals *)

Lemma is_RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (l : V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  is_RInt_gen f Fa Fb l -> is_RInt_gen g Fa Fb l.
Proof.
intros Heq.
apply: filterlimi_ext_loc.
apply: filter_imp Heq.
intros [a b] Heq y.
split.
now apply is_RInt_ext.
apply is_RInt_ext.
intros x Hx.
now apply sym_eq, Heq.
Qed.

Lemma ex_RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  ex_RInt_gen f Fa Fb -> ex_RInt_gen g Fa Fb.
Proof.
move => Heq.
case => I HI.
exists I.
exact: (is_RInt_gen_ext f g).
Qed.

Lemma ex_RInt_gen_ext_eq {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) :
  (forall x, f x = g x) -> ex_RInt_gen f Fa Fb -> ex_RInt_gen g Fa Fb.
Proof.
move => Heq.
apply: ex_RInt_gen_ext.
exact: filter_forall => bds x _.
Qed.

Lemma is_RInt_gen_point (f : R -> V) (a : R) :
  is_RInt_gen f (at_point a) (at_point a) zero.
Proof.
  apply is_RInt_gen_at_point.
  exact: is_RInt_point.
Qed.

Lemma is_RInt_gen_swap {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fb Fa l -> is_RInt_gen f Fa Fb (opp l).
Proof.
intros Hf P HP.
specialize (Hf (fun y => P (opp y))).
destruct Hf as [Q R HQ HR H].
  exact: filterlim_opp.
apply: Filter_prod HR HQ _ => a b Ha Hb.
specialize (H b a Hb Ha).
destruct H as [y [Hy1 Hy2]].
exists (opp y).
split.
exact: is_RInt_swap.
exact Hy2.
Qed.

Lemma is_RInt_gen_Chasles {Fa Fc : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFc : Filter Fc}
  (f : R -> V) (b : R) (l1 l2 : V) :
  is_RInt_gen f Fa (at_point b) l1 -> is_RInt_gen f (at_point b) Fc l2
  -> is_RInt_gen f Fa Fc (plus l1 l2).
Proof.
intros Hab Hbc P HP.
specialize (filterlim_plus _ _ P HP).
intros [Q R HQ HR H].
specialize (Hab Q HQ).
specialize (Hbc R HR).
destruct Hab as [Qa Ra HQa HRa Hab].
destruct Hbc as [Qc Rc HQc HRc Hbc].
apply: Filter_prod HQa HRc _.
intros a c Ha Hc.
specialize (Hab _ _ Ha HRa).
specialize (Hbc _ _ HQc Hc).
destruct Hab as [ya [Hya1 Hya2]].
destruct Hbc as [yc [Hyc1 Hyc2]].
exists (plus ya yc).
split.
apply: is_RInt_Chasles Hya1 Hyc1.
now apply H.
Qed.

Lemma ex_RInt_gen_Chasles :
  forall {Fa Fc : (R -> Prop) -> Prop},
  forall {FFa : Filter Fa} {FFc : Filter Fc},
  forall (f : R -> V) (b : R),
  ex_RInt_gen f Fa (at_point b) ->
  ex_RInt_gen f (at_point b) Fc ->
  ex_RInt_gen f Fa Fc.
Proof.
intros Fa Fc FFa FFc f b [Iab Hab] [Ibc Hbc].
exists (plus Iab Ibc).
now apply is_RInt_gen_Chasles with b.
Qed.

(** * Composition *)

(*
Lemma is_RInt_gen_comp_opp {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f (filtermap opp Fa) (filtermap opp Fb) l ->
  is_RInt_gen (fun y => opp (f (- y))) Fa Fb l.
Proof.
intros H.
apply: filterlimi_ext.
unfold is_RInt_gen.
apply: filterlimi_comp_2.
apply filterlim_fst.
apply filterlim_snd.
SearchAbout fst filter_prod.

  case => If [Hf Hl].
  exists (fun x => If (opp x)) ; split.
  case: Hf => P Q ;
  unfold filtermap => Pa Qb H.
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply is_RInt_comp_opp, H.
  eapply filterlim_comp, Hl.
  intros P [Q1 Q2 Q1a Q2b H].
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply H.
Qed.

Lemma is_RInt_gen_comp_lin {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (u v : R) (l : V) :
  is_RInt_gen f (filtermap (fun a => u * a + v) Fa) (filtermap (fun b => u * b + v) Fb) l
    -> is_RInt_gen (fun y => scal u (f (u * y + v))) Fa Fb l.
Proof.
  case => If [Hf Hl].
  exists (fun x => If (plus (scal u x) (v,v))) ; split.
  case: Hf => P Q ;
  unfold filtermap => Pa Qb H.
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply is_RInt_comp_lin, H.
  eapply filterlim_comp, Hl.
  intros P [Q1 Q2 Q1a Q2b H].
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply H.
Qed.
*)

(** * Operations *)

Lemma is_RInt_gen_scal {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (k : R) (l : V) :
  is_RInt_gen f Fa Fb l ->
  is_RInt_gen (fun y => scal k (f y)) Fa Fb (scal k l).
Proof.
intros H P HP.
move /filterlim_scal_r in HP.
specialize (H _ HP).
unfold filtermapi in H |- *.
apply: filter_imp H.
move => [a b] /= [y [Hy1 Hy2]].
exists (scal k y).
apply: conj Hy2.
exact: is_RInt_scal.
Qed.

Lemma is_RInt_gen_opp {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fa Fb l ->
  is_RInt_gen (fun y => opp (f y)) Fa Fb (opp l).
Proof.
intros H P HP.
move /filterlim_opp in HP.
specialize (H _ HP).
unfold filtermapi in H |- *.
apply: filter_imp H.
move => [a b] /= [y [Hy1 Hy2]].
exists (opp y).
apply: conj Hy2.
exact: is_RInt_opp.
Qed.

Lemma is_RInt_gen_plus {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (lf lg : V) :
  is_RInt_gen f Fa Fb lf ->
  is_RInt_gen g Fa Fb lg ->
  is_RInt_gen (fun y => plus (f y) (g y)) Fa Fb (plus lf lg).
Proof.
intros Hf Hg P HP.
move /filterlim_plus in HP.
destruct HP as [Q R HQ HR H].
specialize (Hf _ HQ).
specialize (Hg _ HR).
unfold filtermapi in Hf, Hg |- *.
apply: filter_imp (filter_and _ _ Hf Hg).
move => [a b] /= [[If [HIf1 HIf2]] [Ig [HIg1 HIg2]]].
exists (plus If Ig).
apply: conj (H _ _ HIf2 HIg2).
exact: is_RInt_plus.
Qed.

Lemma is_RInt_gen_minus {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (lf lg : V) :
  is_RInt_gen f Fa Fb lf ->
  is_RInt_gen g Fa Fb lg ->
  is_RInt_gen (fun y => minus (f y) (g y)) Fa Fb (minus lf lg).
Proof.
intros Hf Hg.
apply: is_RInt_gen_plus Hf _.
exact: is_RInt_gen_opp.
Qed.

End is_RInt_gen.

Section RInt_gen.

Context {V : CompleteNormedModule R_AbsRing}.

Definition RInt_gen (f : R -> V) (a b : (R -> Prop) -> Prop) :=
  iota (is_RInt_gen f a b).

Lemma is_RInt_gen_unique {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter' Fa} {FFb : ProperFilter' Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fa Fb l -> RInt_gen f Fa Fb = l.
Proof.
apply iota_filterlimi_locally.
apply filter_forall.
intros [a b] y1 u2 H1 H2.
rewrite -(is_RInt_unique _ _ _ _ H1).
now apply is_RInt_unique.
Qed.

Lemma RInt_gen_correct {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter' Fa} {FFb : ProperFilter' Fb} (f : R -> V) :
  ex_RInt_gen f Fa Fb -> is_RInt_gen f Fa Fb (RInt_gen f Fa Fb).
Proof.
intros [If HIf].
erewrite is_RInt_gen_unique ; exact HIf.
Qed.

Lemma RInt_gen_norm {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f : R -> V) (g : R -> R) (lf : V) (lg : R) :
  filter_prod Fa Fb (fun ab => fst ab <= snd ab) ->
  filter_prod Fa Fb (fun ab => forall x, fst ab <= x <= snd ab -> norm (f x) <= g x) ->
  is_RInt_gen f Fa Fb lf -> is_RInt_gen g Fa Fb lg ->
  norm lf <= lg.
Proof.
intros Hab Hle Hf Hg.
apply (filterlim_le (F := filter_prod Fa Fb) (fun ab => norm (RInt f (fst ab) (snd ab))) (fun ab => RInt g (fst ab) (snd ab)) (norm lf) lg).
- specialize (Hf _ (locally_ball lf (mkposreal _ Rlt_0_1))).
  specialize (Hg _ (locally_ball lg (mkposreal _ Rlt_0_1))).
  unfold filtermapi in Hf, Hg.
  apply: filter_imp (filter_and _ _ (filter_and  _ _ Hf Hg) (filter_and _ _ Hab Hle)) => {Hf Hg Hab Hle}.
  move => [a b] /= [[[If [Hf1 Hf2]] [Ig [Hg1 Hg2]]] [H H']].
  apply: norm_RInt_le H H' _ _.
  apply: RInt_correct.
  now exists If.
  apply: RInt_correct.
  now exists Ig.
- eapply filterlim_comp, filterlim_norm.
  intros P HP.
  specialize (Hf P HP).
  unfold filtermapi, filtermap in Hf |- *.
  apply: filter_imp Hf.
  move => [a b] /= [y [Hy1 Hy2]].
  now rewrite (is_RInt_unique _ a b y Hy1).
- intros P HP.
  specialize (Hg P HP).
  unfold filtermapi, filtermap in Hg |- *.
  apply: filter_imp Hg.
  move => [a b] /= [y [Hy1 Hy2]].
  now rewrite (is_RInt_unique _ a b y Hy1).
Qed.

Lemma RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  ex_RInt_gen f Fa Fb -> RInt_gen f Fa Fb = RInt_gen g Fa Fb.
Proof.
move => Heq [I HI].
rewrite (is_RInt_gen_unique f I HI); symmetry.
apply is_RInt_gen_unique. (* 'apply:' does not work *)
by apply: is_RInt_gen_ext; first exact: Heq.
Qed.

Lemma RInt_gen_ext_eq {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V):
  (forall x, f x = g x) ->
  ex_RInt_gen f Fa Fb -> RInt_gen f Fa Fb = RInt_gen g Fa Fb.
Proof.
move => Heq.
apply: (RInt_gen_ext f g).
exact: filter_forall => bnds x _.
Qed.

Lemma RInt_gen_Chasles :
  forall {Fa Fc : (R -> Prop) -> Prop},
  forall {FFa : ProperFilter' Fa} {FFc : ProperFilter' Fc},
  forall (f : R -> V) (b : R),
  ex_RInt_gen f Fa (at_point b) ->
  ex_RInt_gen f (at_point b) Fc ->
  plus (RInt_gen f Fa (at_point b)) (RInt_gen f (at_point b) Fc) = RInt_gen f Fa Fc.
Proof.
intros Fa Fc FFa FFc f b Hab Hbc.
apply eq_sym, is_RInt_gen_unique.
apply: is_RInt_gen_Chasles.
now apply RInt_gen_correct.
now apply RInt_gen_correct.
Qed.

End RInt_gen.

Lemma is_RInt_gen_Derive {Fa Fb : (R -> Prop) -> Prop} {FFa : Filter Fa} {FFb : Filter Fb}
  (f : R -> R) (la lb : R) :
  filter_prod Fa Fb
    (fun ab => forall x : R, Rmin (fst ab) (snd ab) <= x <= Rmax (fst ab) (snd ab) -> ex_derive f x)
  -> filter_prod Fa Fb
    (fun ab => forall x : R, Rmin (fst ab) (snd ab) <= x <= Rmax (fst ab) (snd ab) -> continuous (Derive f) x)
  -> filterlim f Fa (locally la) -> filterlim f Fb (locally lb)
  -> is_RInt_gen (Derive f) Fa Fb (lb - la).
Proof.
intros Df Cf Lfa Lfb P HP.
assert (HP': filter_prod Fa Fb (fun ab => P (f (snd ab) - f (fst ab)))).
  unfold Rminus.
  eapply filterlim_comp_2.
  eapply filterlim_comp, Lfb.
  by apply filterlim_snd.
  eapply filterlim_comp, @filterlim_opp.
  eapply filterlim_comp, Lfa.
  by apply filterlim_fst.
  exact: (filterlim_plus lb (- la)).
  exact HP.
apply: filter_imp (filter_and _ _ (filter_and _ _ Df Cf) HP').
move => [a b] /= {Df Cf HP HP'} [[Df Cf] HP].
eexists.
apply: conj HP.
apply: is_RInt_derive => x Hx.
now apply Derive_correct, Df.
exact: Cf.
Qed.

Section Complements_RInt_gen.

Context {V : CompleteNormedModule R_AbsRing}.

Lemma ex_RInt_gen_at_point f a b : @ex_RInt_gen V f (at_point a) (at_point b) <-> ex_RInt f a b.
Proof.
split;  case => I.
  rewrite is_RInt_gen_at_point => HI.
  by exists I.
rewrite -is_RInt_gen_at_point => HI.
  by exists I.
Qed.

Lemma RInt_gen_at_point f a b :
  ex_RInt f a b -> @RInt_gen V f (at_point a) (at_point b) = RInt f a b.
Proof.
move => Hfint.
apply is_RInt_gen_unique.
apply is_RInt_gen_at_point.
exact: RInt_correct.
Qed.

End Complements_RInt_gen.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  Absz.v                                                                  *)
(*                                                                          *)
(*  Definition of the absolute value on integers                            *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               Absz.v                                     *)
(****************************************************************************)

Require Import quotient.
Require Import Arith.

Section AbsZ.

Require Import integer.

Lemma ABSZ : forall z : Z, Z.

intro z.
elim (Constructive_Z_partition z).
simple induction 1.
intro.
exact (- z)%INT.
intro.
exact z.
intro.
exact z.
Defined.

(* On a construit le terme:

ABSZ_O < Print ABSZ.
ABSZ =
[z:Z]
 (sumor_rec {(leZ z |((O,(S O)))|)}+{z=|((O,O))|} (leZ |(((S O),O))| z)
   [_:({(leZ z |((O,(S O)))|)}+{z=|((O,O))|})+{(leZ |(((S O),O))| z)}]Z
   [y:{(leZ z |((O,(S O)))|)}+{z=|((O,O))|}]
    (sumbool_rec (leZ z |((O,(S O)))|) z=|((O,O))|
      [_:{(leZ z |((O,(S O)))|)}+{z=|((O,O))|}]Z
      [_:(leZ z |((O,(S O)))|)](unary_minus z) [_:z=|((O,O))|]z y)
   [_:(leZ |(((S O),O))| z)]z (Constructive_Z_partition z))
     : Z->Z

Rappel:

( Syntax sumbool "{_}+{_}". )
Inductive sumbool [A,B:Prop] : Set
    := left  : A -> ({A}+{B})
     | right : B -> ({A}+{B}).

*)

Open Scope INT_scope.

Lemma ABSZ_neg : forall z : Z, z <= - 1 -> ABSZ z = - z.

intros.
elim (z_lt_O z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Lemma ABSZ_O : forall z : Z, z = 0 -> ABSZ z = z.

intros.
elim (z_eq_O z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Lemma ABSZ_pos : forall z : Z, 1 <= z -> ABSZ z = z.

intros.
elim (O_lt_z z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Opaque ABSZ.

End AbsZ.