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

 Limits in the Eilenberg-Moore category

 Contents
 1. Terminal objects
 2. Binary products
 3. Pullbacks
 4. Initial objects
 5. Binary coproducts

 ******************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.categories.Dialgebras.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.Preservation.

Local Open Scope cat.

Section EilenbergMooreCategoryLimits.
  Context {C : category}
          (m : Monad C).

  (**
   1. Terminal objects
   *)
  Definition terminal_obj_eilenberg_moore_cat
             (T : C)
             (HT : isTerminal _ T)
    : eilenberg_moore_cat m.
  Proof.
    use make_ob_eilenberg_moore.
    - exact T.
    - apply (TerminalArrow (_ ,, HT)).
    - apply (@TerminalArrowEq _ (_ ,, HT)).
    - apply (@TerminalArrowEq _ (_ ,, HT)).
  Defined.

  Definition is_terminal_obj_eilenberg_moore_cat
             (T : eilenberg_moore_cat m)
             (HT : isTerminal _ (pr11 T))
    : isTerminal
        (eilenberg_moore_cat m)
        T.
  Proof.
    intro x.
    use make_iscontr.
    - use make_mor_eilenberg_moore.
      + apply (TerminalArrow (_ ,, HT)).
      + apply (@TerminalArrowEq _ (_ ,, HT)).
    - abstract
        (intro f ;
         use eq_mor_eilenberg_moore ;
         apply (@TerminalArrowEq _ (_ ,, HT))).
  Defined.

  Section Terminal.
    Context (T : Terminal C).

    Definition terminal_eilenberg_moore_cat
      : Terminal (eilenberg_moore_cat m).
    Proof.
      use make_Terminal.
      - exact (terminal_obj_eilenberg_moore_cat (pr1 T) (pr2 T)).
      - refine (is_terminal_obj_eilenberg_moore_cat _ _).
        exact (pr2 T).
    Defined.

    Definition eilenberg_moore_pr_preserves_terminal
      : preserves_terminal (eilenberg_moore_pr m).
    Proof.
      use preserves_terminal_if_preserves_chosen.
      - exact terminal_eilenberg_moore_cat.
      - unfold preserves_chosen_terminal.
        apply T.
    Defined.

    Definition functor_to_eilenberg_moore_cat_preserves_terminal
               {C' : category}
               (F : C' ⟶ C)
               (HF : preserves_terminal F)
               (α : F ∙ m ⟹ functor_identity C' ∙ F)
               (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x)))
               (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x)
      : preserves_terminal (functor_to_eilenberg_moore_cat m F α p₁ p₂).
    Proof.
      intros x Hx.
      use is_terminal_obj_eilenberg_moore_cat.
      apply HF.
      exact Hx.
    Defined.
  End Terminal.

  (**
   2. Binary products
   *)
  Section IsBinaryProduct.
    Context {x y p : eilenberg_moore_cat m}
            (π₁ : p --> x)
            (π₂ : p --> y)
            (H : isBinProduct C _ _ _ (pr11 π₁) (pr11 π₂)).

    Let P : BinProduct C (pr11 x) (pr11 y) := make_BinProduct _ _ _ _ _ _ H.

    Definition isBinProduct_eilenberg_moore_cat_unique
               {w : eilenberg_moore_cat m}
               (f : w --> x)
               (g : w --> y)
      : isaprop (∑ (k : w --> p), k · π₁ = f × k · π₂ = g).
    Proof.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply homset_property.
      }
      use eq_mor_eilenberg_moore.
      use (BinProductArrowsEq _ _ _ P).
      - exact (maponpaths (λ z, pr11 z) (pr12 φ₁) @ !(maponpaths (λ z, pr11 z) (pr12 φ₂))).
      - exact (maponpaths (λ z, pr11 z) (pr22 φ₁) @ !(maponpaths (λ z, pr11 z) (pr22 φ₂))).
    Qed.

    Definition isBinProduct_eilenberg_moore_cat_mor
               {w : eilenberg_moore_cat m}
               (f : w --> x)
               (g : w --> y)
      : w --> p.
    Proof.
      use make_mor_eilenberg_moore.
      - exact (BinProductArrow _ P (pr11 f) (pr11 g)).
      - use (BinProductArrowsEq _ _ _ P).
        + abstract
            (rewrite !assoc' ;
             etrans ;
             [ apply maponpaths ;
               apply (BinProductPr1Commutes _ _ _ P)
             | ] ;
             refine (eq_of_eilenberg_moore_mor f @ !_) ;
             etrans ;
             [ apply maponpaths ;
               exact (pr21 π₁)
             | ] ;
             rewrite !assoc ;
             apply maponpaths_2 ;
             rewrite <- functor_comp ;
             apply maponpaths ;
             apply (BinProductPr1Commutes _ _ _ P)).
        + abstract
            (rewrite !assoc' ;
             etrans ;
             [ apply maponpaths ;
               apply (BinProductPr2Commutes _ _ _ P)
             | ] ;
             refine (eq_of_eilenberg_moore_mor g @ !_) ;
             etrans ;
             [ apply maponpaths ;
               exact (pr21 π₂)
             | ] ;
             rewrite !assoc ;
             apply maponpaths_2 ;
             rewrite <- functor_comp ;
             apply maponpaths ;
             apply (BinProductPr2Commutes _ _ _ P)).
    Defined.

    Definition isBinProduct_eilenberg_moore_cat_pr1
               {w : eilenberg_moore_cat m}
               (f : w --> x)
               (g : w --> y)
      : isBinProduct_eilenberg_moore_cat_mor f g · π₁ = f.
    Proof.
      use eq_mor_eilenberg_moore.
      apply (BinProductPr1Commutes _ _ _ P).
    Qed.

    Definition isBinProduct_eilenberg_moore_cat_pr2
               {w : eilenberg_moore_cat m}
               (f : w --> x)
               (g : w --> y)
      : isBinProduct_eilenberg_moore_cat_mor f g · π₂ = g.
    Proof.
      use eq_mor_eilenberg_moore.
      apply (BinProductPr2Commutes _ _ _ P).
    Qed.

    Definition isBinProduct_eilenberg_moore_cat
      : isBinProduct _ x y p π₁ π₂.
    Proof.
      use make_isBinProduct.
      intros w f g.
      use iscontraprop1.
      - exact (isBinProduct_eilenberg_moore_cat_unique f g).
      - simple refine (_ ,, _ ,, _).
        + exact (isBinProduct_eilenberg_moore_cat_mor f g).
        + exact (isBinProduct_eilenberg_moore_cat_pr1 f g).
        + exact (isBinProduct_eilenberg_moore_cat_pr2 f g).
    Defined.
  End IsBinaryProduct.

  Section BinaryProducts.
    Context (P : BinProducts C).

    Definition BinProduct_obj_eilenberg_moore_cat_ob
               (x y : eilenberg_moore_cat m)
      : C
      := pr11 (P (pr11 x) (pr11 y)).

    Definition BinProduct_obj_eilenberg_moore_cat_mor
               (x y : eilenberg_moore_cat m)
      : m (BinProduct_obj_eilenberg_moore_cat_ob x y)
        -->
        BinProduct_obj_eilenberg_moore_cat_ob x y.
    Proof.
      use BinProductArrow.
      - exact (# m (BinProductPr1 _ _) · pr21 x).
      - exact (# m (BinProductPr2 _ _) · pr21 y).
    Defined.

    Definition BinProduct_obj_eilenberg_moore_cat_unit
               (x y : eilenberg_moore_cat m)
      : η m (BinProduct_obj_eilenberg_moore_cat_ob x y)
        · BinProduct_obj_eilenberg_moore_cat_mor x y
        =
        identity _.
    Proof.
      use BinProductArrowsEq.
      - rewrite !assoc', id_left.
        etrans.
        {
          apply maponpaths.
          apply BinProductPr1Commutes.
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (nat_trans_ax (η m)).
        }
        cbn.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          exact (pr12 x).
        }
        apply id_right.
      - rewrite !assoc', id_left.
        etrans.
        {
          apply maponpaths.
          apply BinProductPr2Commutes.
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (nat_trans_ax (η m)).
        }
        cbn.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          exact (pr12 y).
        }
        apply id_right.
    Qed.

    Definition BinProduct_obj_eilenberg_moore_cat_mult
               (x y : eilenberg_moore_cat m)
      : μ m (BinProduct_obj_eilenberg_moore_cat_ob x y)
        · BinProduct_obj_eilenberg_moore_cat_mor x y
        =
        # m (BinProduct_obj_eilenberg_moore_cat_mor x y)
        · BinProduct_obj_eilenberg_moore_cat_mor x y.
    Proof.
      use BinProductArrowsEq.
      - rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply BinProductPr1Commutes.
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (nat_trans_ax (μ m)).
        }
        cbn.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (pr22 x).
        }
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply BinProductPr1Commutes.
        }
        rewrite !assoc.
        apply maponpaths_2.
        rewrite <- !functor_comp.
        apply maponpaths.
        apply BinProductPr1Commutes.
      - rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply BinProductPr2Commutes.
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply (nat_trans_ax (μ m)).
        }
        cbn.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (pr22 y).
        }
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply BinProductPr2Commutes.
        }
        rewrite !assoc.
        apply maponpaths_2.
        rewrite <- !functor_comp.
        apply maponpaths.
        apply BinProductPr2Commutes.
    Qed.

    Definition BinProduct_obj_eilenberg_moore_cat
               (x y : eilenberg_moore_cat m)
      : eilenberg_moore_cat m.
    Proof.
      use make_ob_eilenberg_moore.
      - exact (BinProduct_obj_eilenberg_moore_cat_ob x y).
      - exact (BinProduct_obj_eilenberg_moore_cat_mor x y).
      - exact (BinProduct_obj_eilenberg_moore_cat_unit x y).
      - exact (BinProduct_obj_eilenberg_moore_cat_mult x y).
    Defined.

    Definition BinProduct_pr1_eilenberg_moore_cat
               (x y : eilenberg_moore_cat m)
      : BinProduct_obj_eilenberg_moore_cat x y --> x.
    Proof.
      use make_mor_eilenberg_moore.
      - apply BinProductPr1.
      - apply BinProductPr1Commutes.
    Defined.

    Definition BinProduct_pr2_eilenberg_moore_cat
               (x y : eilenberg_moore_cat m)
      : BinProduct_obj_eilenberg_moore_cat x y --> y.
    Proof.
      use make_mor_eilenberg_moore.
      - apply BinProductPr2.
      - apply BinProductPr2Commutes.
    Defined.

    Definition BinProducts_eilenberg_moore_cat
      : BinProducts (eilenberg_moore_cat m).
    Proof.
      intros x y.
      use make_BinProduct.
      - exact (BinProduct_obj_eilenberg_moore_cat x y).
      - exact (BinProduct_pr1_eilenberg_moore_cat x y).
      - exact (BinProduct_pr2_eilenberg_moore_cat x y).
      - apply isBinProduct_eilenberg_moore_cat.
        apply P.
    Defined.

    Definition eilenberg_moore_pr_preserves_binproduct
      : preserves_binproduct (eilenberg_moore_pr m).
    Proof.
      use preserves_binproduct_if_preserves_chosen.
      - exact BinProducts_eilenberg_moore_cat.
      - intros x y.
        apply P.
    Defined.

    Definition functor_to_eilenberg_moore_cat_preserves_binproduct
               {C' : category}
               (F : C' ⟶ C)
               (HF : preserves_binproduct F)
               (α : F ∙ m ⟹ functor_identity C' ∙ F)
               (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x)))
               (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x)
      : preserves_binproduct (functor_to_eilenberg_moore_cat m F α p₁ p₂).
    Proof.
      intros x y p π₁ π₂ Hx.
      use isBinProduct_eilenberg_moore_cat.
      apply HF.
      exact Hx.
    Defined.
  End BinaryProducts.

  (**
   3. Pullbacks
   *)
  Section IsPullback.
    Context {x y z : eilenberg_moore_cat m}
            {f : x --> z}
            {g : y --> z}
            {pb : eilenberg_moore_cat m}
            {π₁ : pb --> x}
            {π₂ : pb --> y}
            (q : π₁ · f = π₂ · g)
            (q' : pr11 π₁ · pr11 f = pr11 π₂ · pr11 g)
            (H : @isPullback
                   C
                   (pr11 z) (pr11 x) (pr11 y)
                   (pr11 pb)
                   (pr11 f) (pr11 g)
                   (pr11 π₁) (pr11 π₂)
                   q').

    Section UMP.
      Context {w : eilenberg_moore_cat m}
              (h : w --> x)
              (k : w --> y)
              (r : h · f = k · g).

      Definition isPullback_eilenberg_moore_unique
        : isaprop (∑ (hk : w --> pb), hk · π₁ = h × hk · π₂ = k).
      Proof.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isapropdirprod ; apply homset_property.
        }
        use eq_mor_eilenberg_moore.
        use (MorphismsIntoPullbackEqual H).
        - exact (maponpaths (λ z, pr11 z) (pr12 φ₁ @ !(pr12 φ₂))).
        - exact (maponpaths (λ z, pr11 z) (pr22 φ₁ @ !(pr22 φ₂))).
      Qed.

      Definition isPullback_eilenberg_moore_mor
        : w --> pb.
      Proof.
        use make_mor_eilenberg_moore.
        - use (PullbackArrow (make_Pullback _ H)).
          + exact (mor_of_eilenberg_moore_mor h).
          + exact (mor_of_eilenberg_moore_mor k).
          + exact (maponpaths (λ z, pr11 z) r).
        - use (MorphismsIntoPullbackEqual H).
          + abstract
              (rewrite !assoc' ;
               etrans ;
                 [ apply maponpaths ;
                   apply (PullbackArrow_PullbackPr1 (make_Pullback _ H))
                 | ] ;
               refine (!_) ;
               etrans ;
                 [ apply maponpaths ;
                   exact (pr21 π₁)
                 | ] ;
               rewrite !assoc ;
               rewrite <- functor_comp ;
               etrans ;
                 [ apply maponpaths_2 ;
                   apply maponpaths ;
                   apply (PullbackArrow_PullbackPr1 (make_Pullback _ H))
                 | ] ;
               exact (!(eq_of_eilenberg_moore_mor h))).
          + abstract
              (rewrite !assoc' ;
               etrans ;
                 [ apply maponpaths ;
                   apply (PullbackArrow_PullbackPr2 (make_Pullback _ H))
                 | ] ;
               refine (!_) ;
               etrans ;
                 [ apply maponpaths ;
                   exact (pr21 π₂)
                 | ] ;
               rewrite !assoc ;
               rewrite <- functor_comp ;
               etrans ;
                 [ apply maponpaths_2 ;
                   apply maponpaths ;
                   apply (PullbackArrow_PullbackPr2 (make_Pullback _ H))
                 | ] ;
               exact (!(eq_of_eilenberg_moore_mor k))).
      Defined.
    End UMP.

    Definition isPullback_eilenberg_moore
      : isPullback q.
    Proof.
      intros w h k r.
      use iscontraprop1.
      - exact (isPullback_eilenberg_moore_unique h k).
      - simple refine (_ ,, _ ,, _).
        + exact (isPullback_eilenberg_moore_mor h k r).
        + abstract
            (use eq_mor_eilenberg_moore ;
             apply (PullbackArrow_PullbackPr1 (make_Pullback _ H))).
        + abstract
            (use eq_mor_eilenberg_moore ;
             apply (PullbackArrow_PullbackPr2 (make_Pullback _ H))).
    Defined.
  End IsPullback.

  Section Pullbacks.
    Context (PB : Pullbacks C).

    Section PullbackCone.
      Context {x y z : eilenberg_moore_cat m}
              (f : x --> z)
              (g : y --> z).

      Definition ob_of_pullbacks_eilenberg_moore_ob
        : C
        := PB _ _ _ (pr11 f) (pr11 g).

      Definition mor_of_pullbacks_eilenberg_moore_ob
        : m ob_of_pullbacks_eilenberg_moore_ob
          -->
          ob_of_pullbacks_eilenberg_moore_ob.
      Proof.
        use PullbackArrow.
        - exact (# m (PullbackPr1 (PB _ _ _ (pr11 f) (pr11 g))) · pr21 x).
        - exact (# m (PullbackPr2 (PB _ _ _ (pr11 f) (pr11 g))) · pr21 y).
        - abstract
            (rewrite !assoc' ;
             refine (maponpaths (λ z, _ · z) (pr21 f) @ _) ;
             refine (_ @ !(maponpaths (λ z, _ · z) (pr21 g))) ;
             rewrite !assoc ;
             rewrite <- !functor_comp ;
             apply maponpaths_2 ;
             apply maponpaths ;
             apply PullbackSqrCommutes).
      Defined.

      Definition pullbacks_eilenberg_moore_ob_unit
        : η m ob_of_pullbacks_eilenberg_moore_ob
          · mor_of_pullbacks_eilenberg_moore_ob
          =
          identity _.
      Proof.
        use (MorphismsIntoPullbackEqual (pr22 (PB _ _ _ (pr11 f) (pr11 g)))) ;
          unfold mor_of_pullbacks_eilenberg_moore_ob.
        - rewrite !assoc', id_left.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr1.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply (nat_trans_ax (η m)).
          }
          cbn.
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            exact (pr12 x).
          }
          apply id_right.
        - rewrite !assoc', id_left.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr2.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply (nat_trans_ax (η m)).
          }
          cbn.
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            exact (pr12 y).
          }
          apply id_right.
      Qed.

      Definition pullbacks_eilenberg_moore_ob_mult
        : μ m ob_of_pullbacks_eilenberg_moore_ob
          · mor_of_pullbacks_eilenberg_moore_ob
          =
          # m mor_of_pullbacks_eilenberg_moore_ob
          · mor_of_pullbacks_eilenberg_moore_ob.
      Proof.
        use (MorphismsIntoPullbackEqual (pr22 (PB _ _ _ (pr11 f) (pr11 g)))) ;
          unfold mor_of_pullbacks_eilenberg_moore_ob.
        - rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr1.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply (nat_trans_ax (μ m)).
          }
          cbn.
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            exact (pr22 x).
          }
          rewrite !assoc.
          rewrite <- functor_comp.
          refine (!_).
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr1.
          }
          rewrite !assoc.
          apply maponpaths_2.
          rewrite <- functor_comp.
          apply maponpaths.
          apply PullbackArrow_PullbackPr1.
        - rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr2.
          }
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply (nat_trans_ax (μ m)).
          }
          cbn.
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            exact (pr22 y).
          }
          rewrite !assoc.
          rewrite <- functor_comp.
          refine (!_).
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply PullbackArrow_PullbackPr2.
          }
          rewrite !assoc.
          apply maponpaths_2.
          rewrite <- functor_comp.
          apply maponpaths.
          apply PullbackArrow_PullbackPr2.
      Qed.

      Definition pullbacks_eilenberg_moore_ob
        : eilenberg_moore_cat m.
      Proof.
        use make_ob_eilenberg_moore.
        - exact ob_of_pullbacks_eilenberg_moore_ob.
        - exact mor_of_pullbacks_eilenberg_moore_ob.
        - exact pullbacks_eilenberg_moore_ob_unit.
        - exact pullbacks_eilenberg_moore_ob_mult.
      Defined.

      Definition pullbacks_eilenberg_moore_pr1
        : pullbacks_eilenberg_moore_ob --> x.
      Proof.
        use make_mor_eilenberg_moore.
        - apply PullbackPr1.
        - apply PullbackArrow_PullbackPr1.
      Defined.

      Definition pullbacks_eilenberg_moore_pr2
        : pullbacks_eilenberg_moore_ob --> y.
      Proof.
        use make_mor_eilenberg_moore.
        - apply PullbackPr2.
        - apply PullbackArrow_PullbackPr2.
      Defined.

      Definition pullbacks_eilenberg_moore_eq
        : pullbacks_eilenberg_moore_pr1 · f
          =
          pullbacks_eilenberg_moore_pr2 · g.
      Proof.
        use eq_mor_eilenberg_moore.
        apply PullbackSqrCommutes.
      Qed.
    End PullbackCone.

    Definition Pullbacks_eilenberg_moore
      : Pullbacks (eilenberg_moore_cat m).
    Proof.
      intros x y z f g.
      use make_Pullback.
      - exact (pullbacks_eilenberg_moore_ob f g).
      - exact (pullbacks_eilenberg_moore_pr1 f g).
      - exact (pullbacks_eilenberg_moore_pr2 f g).
      - exact (pullbacks_eilenberg_moore_eq f g).
      - refine (isPullback_eilenberg_moore _ _ _).
        exact (pr22 (PB _ _ _ (pr11 f) (pr11 g))).
    Defined.

    Definition eilenberg_moore_pr_preserves_pullback
      : preserves_pullback (eilenberg_moore_pr m).
    Proof.
      use preserves_pullback_if_preserves_chosen.
      - exact Pullbacks_eilenberg_moore.
      - intro ; intros.
        apply PB.
    Defined.

    Definition functor_to_eilenberg_moore_cat_preserves_pullback
               {C' : category}
               (F : C' ⟶ C)
               (HF : preserves_pullback F)
               (α : F ∙ m ⟹ functor_identity C' ∙ F)
               (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x)))
               (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x)
      : preserves_pullback (functor_to_eilenberg_moore_cat m F α p₁ p₂).
    Proof.
      intros ? ? ? ? ? ? ? ? ? ? Hx.
      use isPullback_eilenberg_moore.
      - abstract
          (cbn ;
           rewrite <- !functor_comp ;
           apply maponpaths ;
           exact q).
      - use HF.
        + exact q.
        + exact Hx.
    Defined.
  End Pullbacks.

  (**
   4. Initial objects
   *)
  Definition is_initial_eilenberg_moore_cat
             (I : eilenberg_moore_cat m)
             (HI : isInitial _ (pr11 I))
             (Hm : preserves_initial m)
    : isInitial (eilenberg_moore_cat m) I.
  Proof.
    use make_isInitial.
    intro x.
    use make_iscontr.
    - use make_mor_eilenberg_moore.
      + apply (InitialArrow (make_Initial _ HI)).
      + apply (@InitialArrowEq _ (make_Initial _ (Hm _ HI))).
    - abstract
        (intro f ;
         use eq_mor_eilenberg_moore ;
         apply (@InitialArrowEq _ (make_Initial _ HI))).
  Defined.

  Section Initial.
    Context (I : Initial C)
            (Hm : preserves_initial m).

    Definition initial_obj_eilenberg_moore_cat
      : eilenberg_moore_cat m.
    Proof.
      use make_ob_eilenberg_moore.
      - exact I.
      - apply (InitialArrow (make_Initial _ (Hm I (pr2 I)))).
      - apply InitialArrowEq.
      - apply (@InitialArrowEq _ (make_Initial _ (Hm _ (Hm I (pr2 I))))).
    Defined.

    Definition initial_eilenberg_moore_cat
      : Initial (eilenberg_moore_cat m).
    Proof.
      use make_Initial.
      - exact initial_obj_eilenberg_moore_cat.
      - apply is_initial_eilenberg_moore_cat.
        + exact (pr2 I).
        + exact Hm.
    Defined.

    Definition eilenberg_moore_pr_preserves_initial
      : preserves_initial (eilenberg_moore_pr m).
    Proof.
      use preserves_initial_if_preserves_chosen.
      - exact initial_eilenberg_moore_cat.
      - apply I.
    Defined.

    Definition functor_to_eilenberg_moore_cat_preserves_initial
               {C' : category}
               (F : C' ⟶ C)
               (HF : preserves_initial F)
               (α : F ∙ m ⟹ functor_identity C' ∙ F)
               (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x)))
               (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x)
      : preserves_initial (functor_to_eilenberg_moore_cat m F α p₁ p₂).
    Proof.
      intros x Hx.
      use is_initial_eilenberg_moore_cat.
      - apply HF.
        exact Hx.
      - exact Hm.
    Defined.
  End Initial.

  (**
   5. Binary coproducts
   *)
  Section IsBinaryCoproduct.
    Context (Hm : preserves_bincoproduct m)
            {x y sum : eilenberg_moore_cat m}
            (ι₁ : x --> sum)
            (ι₂ : y --> sum)
            (H : isBinCoproduct _ _ _ _ (pr11 ι₁) (pr11 ι₂)).

    Let copr : BinCoproduct (pr11 x) (pr11 y)
      := make_BinCoproduct _ _ _ _ _ _ H.

    Section UMP.
      Context {w : eilenberg_moore_cat m}
              (f : x --> w)
              (g : y --> w).

      Definition isBinCoproduct_eilenberg_moore_unique
        : isaprop (∑ (fg : sum --> w), ι₁ · fg = f × ι₂ · fg = g).
      Proof.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isapropdirprod ; apply homset_property.
        }
        use eq_mor_eilenberg_moore.
        use (BinCoproductArrowsEq _ _ _ copr).
        - exact (maponpaths (λ z, pr11 z) (pr12 φ₁ @ !(pr12 φ₂))).
        - exact (maponpaths (λ z, pr11 z) (pr22 φ₁ @ !(pr22 φ₂))).
      Qed.

      Definition isBinCoproduct_eilenberg_moore_mor
        : sum --> w.
      Proof.
        use make_mor_eilenberg_moore.
        - exact (BinCoproductArrow copr (pr11 f) (pr11 g)).
        - use (BinCoproductArrowsEq
                 _ _ _
                 (make_BinCoproduct _ _ _ _ _ _ (Hm _ _ _ _ _ H))) ; cbn.
          + abstract
              (rewrite !assoc ;
               rewrite <- functor_comp ;
               etrans ;
               [ apply maponpaths_2 ;
                 exact (!(eq_of_eilenberg_moore_mor ι₁))
               | ] ;
               rewrite !assoc' ;
               etrans ;
               [ apply maponpaths ;
                 apply (BinCoproductIn1Commutes _ _ _ copr)
               | ] ;
               refine (!_) ;
               etrans ;
               [ apply maponpaths_2 ;
                 apply maponpaths ;
                 apply (BinCoproductIn1Commutes _ _ _ copr)
               | ] ;
               exact (!(eq_of_eilenberg_moore_mor f))).
          + abstract
              (rewrite !assoc ;
               rewrite <- functor_comp ;
               etrans ;
               [ apply maponpaths_2 ;
                 exact (!(eq_of_eilenberg_moore_mor ι₂))
               | ] ;
               rewrite !assoc' ;
               etrans ;
               [ apply maponpaths ;
                 apply (BinCoproductIn2Commutes _ _ _ copr)
               | ] ;
               refine (!_) ;
               etrans ;
               [ apply maponpaths_2 ;
                 apply maponpaths ;
                 apply (BinCoproductIn2Commutes _ _ _ copr)
               | ] ;
               exact (!(eq_of_eilenberg_moore_mor g))).
      Defined.

      Definition isBinCoproduct_eilenberg_moore_in1
        : ι₁ · isBinCoproduct_eilenberg_moore_mor = f.
      Proof.
        use eq_mor_eilenberg_moore.
        apply (BinCoproductIn1Commutes _ _ _ copr).
      Qed.

      Definition isBinCoproduct_eilenberg_moore_in2
        : ι₂ · isBinCoproduct_eilenberg_moore_mor = g.
      Proof.
        use eq_mor_eilenberg_moore.
        apply (BinCoproductIn2Commutes _ _ _ copr).
      Qed.
    End UMP.

    Definition isBinCoproduct_eilenberg_moore
      : isBinCoproduct _ _ _ _ ι₁ ι₂.
    Proof.
      intros w f g.
      use iscontraprop1.
      - exact (isBinCoproduct_eilenberg_moore_unique f g).
      - simple refine (_ ,, _ ,, _).
        + exact (isBinCoproduct_eilenberg_moore_mor f g).
        + exact (isBinCoproduct_eilenberg_moore_in1 f g).
        + exact (isBinCoproduct_eilenberg_moore_in2 f g).
    Defined.
  End IsBinaryCoproduct.

  Section BinaryCoproducts.
    Context (P : BinCoproducts C)
            (Hm : preserves_bincoproduct m).

    Definition bincoproduct_obj_eilenberg_moore_ob
               (x y : eilenberg_moore_cat m)
      : C
      := pr11 (P (pr11 x) (pr11 y)).

    Definition bincoproduct_obj_eilenberg_moore_ob_mor
               (x y : eilenberg_moore_cat m)
      : m (bincoproduct_obj_eilenberg_moore_ob x y)
        -->
        bincoproduct_obj_eilenberg_moore_ob x y.
    Proof.
      use (BinCoproductArrow
             (make_BinCoproduct
                _ _ _ _ _ _
                (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
      - exact (pr21 x · BinCoproductIn1 _).
      - exact (pr21 y · BinCoproductIn2 _).
    Defined.

    Definition bincoproduct_obj_eilenberg_moore_ob_unit
               (x y : eilenberg_moore_cat m)
      : η m (bincoproduct_obj_eilenberg_moore_ob x y)
        · bincoproduct_obj_eilenberg_moore_ob_mor x y
        =
        identity _.
    Proof.
      use BinCoproductArrowsEq ; unfold bincoproduct_obj_eilenberg_moore_ob_mor.
      - rewrite id_right.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply (nat_trans_ax (η m)).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (BinCoproductIn1Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          exact (pr12 x).
        }
        apply id_left.
      - rewrite id_right.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply (nat_trans_ax (η m)).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (BinCoproductIn2Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          exact (pr12 y).
        }
        apply id_left.
    Qed.

    Definition bincoproduct_obj_eilenberg_moore_ob_mult
               (x y : eilenberg_moore_cat m)
      : μ m (bincoproduct_obj_eilenberg_moore_ob x y)
        · bincoproduct_obj_eilenberg_moore_ob_mor x y
        =
        # m (bincoproduct_obj_eilenberg_moore_ob_mor x y)
        · bincoproduct_obj_eilenberg_moore_ob_mor x y.
    Proof.
      use (BinCoproductArrowsEq
             _ _ _
             (make_BinCoproduct
                _ _ _ _ _ _
                (Hm _ _ _ _ _ (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))) ;
        unfold bincoproduct_obj_eilenberg_moore_ob_mor ; cbn.
      - rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply (nat_trans_ax (μ m)).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (BinCoproductIn1Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          exact (pr22 x).
        }
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          rewrite <- functor_comp.
          apply maponpaths.
          apply (BinCoproductIn1Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite functor_comp.
        rewrite !assoc'.
        apply maponpaths.
        apply (BinCoproductIn1Commutes
                 _ _ _
                 (make_BinCoproduct
                    _ _ _ _ _ _
                    (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
      - rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply (nat_trans_ax (μ m)).
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply (BinCoproductIn2Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          exact (pr22 y).
        }
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          rewrite <- functor_comp.
          apply maponpaths.
          apply (BinCoproductIn2Commutes
                   _ _ _
                   (make_BinCoproduct
                      _ _ _ _ _ _
                      (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
        }
        rewrite functor_comp.
        rewrite !assoc'.
        apply maponpaths.
        apply (BinCoproductIn2Commutes
                 _ _ _
                 (make_BinCoproduct
                    _ _ _ _ _ _
                    (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y)))))).
    Qed.

    Definition bincoproduct_obj_eilenberg_moore
               (x y : eilenberg_moore_cat m)
      : eilenberg_moore_cat m.
    Proof.
      use make_ob_eilenberg_moore.
      - exact (bincoproduct_obj_eilenberg_moore_ob x y).
      - exact (bincoproduct_obj_eilenberg_moore_ob_mor x y).
      - exact (bincoproduct_obj_eilenberg_moore_ob_unit x y).
      - exact (bincoproduct_obj_eilenberg_moore_ob_mult x y).
    Defined.

    Definition bincoproduct_eilenberg_moore_in1
               (x y : eilenberg_moore_cat m)
      : x --> bincoproduct_obj_eilenberg_moore x y.
    Proof.
      use make_mor_eilenberg_moore.
      - apply BinCoproductIn1.
      - abstract
          (refine (!_) ;
           apply (BinCoproductIn1Commutes
                    _ _ _
                    (make_BinCoproduct
                       _ _ _ _ _ _
                       (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))).
    Defined.

    Definition bincoproduct_eilenberg_moore_in2
               (x y : eilenberg_moore_cat m)
      : y --> bincoproduct_obj_eilenberg_moore x y.
    Proof.
      use make_mor_eilenberg_moore.
      - apply BinCoproductIn2.
      - abstract
          (refine (!_) ;
           apply (BinCoproductIn2Commutes
                    _ _ _
                    (make_BinCoproduct
                       _ _ _ _ _ _
                       (Hm _ _ _ _ _ (pr2 (P (pr11 x) (pr11 y))))))).
    Defined.

    Definition bincoproducts_eilenberg_moore
      : BinCoproducts (eilenberg_moore_cat m).
    Proof.
      intros x y.
      use make_BinCoproduct.
      - exact (bincoproduct_obj_eilenberg_moore x y).
      - exact (bincoproduct_eilenberg_moore_in1 x y).
      - exact (bincoproduct_eilenberg_moore_in2 x y).
      - use isBinCoproduct_eilenberg_moore.
        + exact Hm.
        + exact (pr2 (P (pr11 x) (pr11 y))).
    Defined.

    Definition eilenberg_moore_pr_preserves_bincoproduct
      : preserves_bincoproduct (eilenberg_moore_pr m).
    Proof.
      use preserves_bincoproduct_if_preserves_chosen.
      - exact bincoproducts_eilenberg_moore.
      - intros x y.
        apply P.
    Defined.

    Definition functor_to_eilenberg_moore_cat_preserves_bincoproduct
               {C' : category}
               (F : C' ⟶ C)
               (HF : preserves_bincoproduct F)
               (α : F ∙ m ⟹ functor_identity C' ∙ F)
               (p₁ : ∏ (x : C'), η m (F x) · α x = identity (functor_identity C (F x)))
               (p₂ : ∏ (x : C'), # m (α x) · α x = μ m (F x) · α x)
      : preserves_bincoproduct (functor_to_eilenberg_moore_cat m F α p₁ p₂).
    Proof.
      intros x y p π₁ π₂ Hx.
      use isBinCoproduct_eilenberg_moore.
      - exact Hm.
      - apply HF.
        exact Hx.
    Defined.
  End BinaryCoproducts.
End EilenbergMooreCategoryLimits.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require bool.Bool.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Axiom pow2pos : forall (i:Z), (0%Z <= i)%Z -> (0%Z < (pow2 i))%Z.

Axiom pow2_0 : ((pow2 0%Z) = 1%Z).

Axiom pow2_1 : ((pow2 1%Z) = 2%Z).

Axiom pow2_2 : ((pow2 2%Z) = 4%Z).

Axiom pow2_3 : ((pow2 3%Z) = 8%Z).

Axiom pow2_4 : ((pow2 4%Z) = 16%Z).

Axiom pow2_5 : ((pow2 5%Z) = 32%Z).

Axiom pow2_6 : ((pow2 6%Z) = 64%Z).

Axiom pow2_7 : ((pow2 7%Z) = 128%Z).

Axiom pow2_8 : ((pow2 8%Z) = 256%Z).

Axiom pow2_9 : ((pow2 9%Z) = 512%Z).

Axiom pow2_10 : ((pow2 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow2 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow2 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow2 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow2 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow2 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow2 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow2 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow2 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow2 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow2 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow2 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow2 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow2 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow2 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow2 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow2 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow2 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow2 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow2 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow2 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow2 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow2 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow2 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow2 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow2 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow2 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow2 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow2 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow2 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow2 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow2 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow2 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow2 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow2 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow2 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow2 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow2 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow2 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow2 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow2 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow2 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow2 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow2 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow2 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow2 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow2 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow2 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow2 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow2 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow2 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow2 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow2 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow2 63%Z) = 9223372036854775808%Z).

Axiom Div_mult_inst : forall (x:Z) (z:Z), (0%Z < x)%Z ->
  ((int.EuclideanDivision.div ((x * 1%Z)%Z + z)%Z
  x) = (1%Z + (int.EuclideanDivision.div z x))%Z).

Axiom Div_double : forall (x:Z) (y:Z), ((0%Z < y)%Z /\ ((y <= x)%Z /\
  (x < (2%Z * y)%Z)%Z)) -> ((int.EuclideanDivision.div x y) = 1%Z).

Axiom Div_pow : forall (x:Z) (i:Z), (0%Z < i)%Z ->
  ((((pow2 (i - 1%Z)%Z) <= x)%Z /\ (x < (pow2 i))%Z) ->
  ((int.EuclideanDivision.div x (pow2 (i - 1%Z)%Z)) = 1%Z)).

Axiom Div_double_neg : forall (x:Z) (y:Z), ((((-2%Z)%Z * y)%Z <= x)%Z /\
  ((x < (-y)%Z)%Z /\ ((-y)%Z < 0%Z)%Z)) -> ((int.EuclideanDivision.div x
  y) = (-2%Z)%Z).

Axiom Div_pow2 : forall (x:Z) (i:Z), (0%Z < i)%Z ->
  ((((-(pow2 i))%Z <= x)%Z /\ (x < (-(pow2 (i - 1%Z)%Z))%Z)%Z) ->
  ((int.EuclideanDivision.div x (pow2 (i - 1%Z)%Z)) = (-2%Z)%Z)).

Axiom Mod_pow2_gen : forall (x:Z) (i:Z) (k:Z), ((0%Z <= k)%Z /\ (k < i)%Z) ->
  ((int.EuclideanDivision.mod1 (int.EuclideanDivision.div (x + (pow2 i))%Z
  (pow2 k)) 2%Z) = (int.EuclideanDivision.mod1 (int.EuclideanDivision.div x
  (pow2 k)) 2%Z)).

Parameter size: Z.

Axiom size_positive : (1%Z < size)%Z.

Axiom bv : Type.
Parameter bv_WhyType : WhyType bv.
Existing Instance bv_WhyType.

Parameter nth: bv -> Z -> bool.

Parameter bvzero: bv.

Axiom Nth_zero : forall (n:Z), ((0%Z <= n)%Z /\ (n < size)%Z) -> ((nth bvzero
  n) = false).

Parameter bvone: bv.

Axiom Nth_one : forall (n:Z), ((0%Z <= n)%Z /\ (n < size)%Z) -> ((nth bvone
  n) = true).

(* Why3 assumption *)
Definition eq (v1:bv) (v2:bv): Prop := forall (n:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((nth v1 n) = (nth v2 n)).

Axiom extensionality : forall (v1:bv) (v2:bv), (eq v1 v2) -> (v1 = v2).

Parameter bw_and: bv -> bv -> bv.

Axiom Nth_bw_and : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((nth (bw_and v1 v2) n) = (andb (nth v1 n) (nth v2 n))).

Parameter bw_or: bv -> bv -> bv.

Axiom Nth_bw_or : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((nth (bw_or v1 v2) n) = (orb (nth v1 n) (nth v2 n))).

Parameter bw_xor: bv -> bv -> bv.

Axiom Nth_bw_xor : forall (v1:bv) (v2:bv) (n:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((nth (bw_xor v1 v2) n) = (xorb (nth v1 n) (nth v2 n))).

Axiom Nth_bw_xor_v1true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ ((nth v1 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v2 n))).

Axiom Nth_bw_xor_v1false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ ((nth v1 n) = false)) -> ((nth (bw_xor v1 v2) n) = (nth v2
  n)).

Axiom Nth_bw_xor_v2true : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ ((nth v2 n) = true)) -> ((nth (bw_xor v1 v2)
  n) = (negb (nth v1 n))).

Axiom Nth_bw_xor_v2false : forall (v1:bv) (v2:bv) (n:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ ((nth v2 n) = false)) -> ((nth (bw_xor v1 v2) n) = (nth v1
  n)).

Parameter bw_not: bv -> bv.

Axiom Nth_bw_not : forall (v:bv) (n:Z), ((0%Z <= n)%Z /\ (n < size)%Z) ->
  ((nth (bw_not v) n) = (negb (nth v n))).

Parameter lsr: bv -> Z -> bv.

Axiom lsr_nth_low : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ (((0%Z <= s)%Z /\ (s < size)%Z) /\
  ((n + s)%Z < size)%Z)) -> ((nth (lsr b s) n) = (nth b (n + s)%Z)).

Axiom lsr_nth_high : forall (b:bv) (n:Z) (s:Z), (((0%Z <= n)%Z /\
  (n < size)%Z) /\ (((0%Z <= s)%Z /\ (s < size)%Z) /\
  (size <= (n + s)%Z)%Z)) -> ((nth (lsr b s) n) = false).

Parameter asr: bv -> Z -> bv.

Axiom asr_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((0%Z <= s)%Z -> (((n + s)%Z < size)%Z -> ((nth (asr b s)
  n) = (nth b (n + s)%Z)))).

Axiom asr_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((0%Z <= s)%Z -> ((size <= (n + s)%Z)%Z -> ((nth (asr b s)
  n) = (nth b (size - 1%Z)%Z)))).

Parameter lsl: bv -> Z -> bv.

Axiom lsl_nth_high : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((0%Z <= s)%Z -> ((0%Z <= (n - s)%Z)%Z -> ((nth (lsl b s)
  n) = (nth b (n - s)%Z)))).

Axiom lsl_nth_low : forall (b:bv) (n:Z) (s:Z), ((0%Z <= n)%Z /\
  (n < size)%Z) -> ((0%Z <= s)%Z -> (((n - s)%Z < 0%Z)%Z -> ((nth (lsl b s)
  n) = false))).

Parameter to_nat_sub: bv -> Z -> Z -> Z.

Axiom to_nat_sub_zero : forall (b:bv) (j:Z) (i:Z), ((0%Z <= i)%Z /\
  ((i <= j)%Z /\ (j < size)%Z)) -> (((nth b j) = false) -> ((to_nat_sub b j
  i) = (to_nat_sub b (j - 1%Z)%Z i))).

Axiom to_nat_sub_one : forall (b:bv) (j:Z) (i:Z), ((0%Z <= i)%Z /\
  ((i <= j)%Z /\ (j < size)%Z)) -> (((nth b j) = true) -> ((to_nat_sub b j
  i) = ((pow2 (j - i)%Z) + (to_nat_sub b (j - 1%Z)%Z i))%Z)).

Axiom to_nat_sub_high : forall (b:bv) (j:Z) (i:Z), (j < i)%Z ->
  ((to_nat_sub b j i) = 0%Z).

(*
Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 3.
*)
Open Scope Z_scope.

(* Why3 goal *)
Theorem to_nat_of_zero2 : forall (b:bv) (i:Z) (j:Z), ((j < size)%Z /\
  ((i <= j)%Z /\ (0%Z <= i)%Z)) -> ((forall (k:Z), ((k <= j)%Z /\
  (i < k)%Z) -> ((nth b k) = false)) -> ((to_nat_sub b j 0%Z) = (to_nat_sub b
  i 0%Z))).
(* Why3 intros b i j (h1,(h2,h3)) h4. *)
intros b i j (Hj,(Hij,Hipos)).
generalize Hj.
pattern j; apply Zlt_lower_bound_ind with (z:=i); auto.
clear j Hj Hij.
intros j Hind Hij.
assert (h:(i=j \/i < j)) by omega.
destruct h.
subst; auto.
intros Hbits Hnth.
rewrite to_nat_sub_zero; auto with zarith.
Qed.


Class FieldType (F : Set) := mkFieldType { fldTy: F -> Set }.
Hint Mode FieldType + : typeclass_instances. (* The F parameter is an input *)

Inductive I1 := C.
Inductive I2 := .

Instance I1FieldType : FieldType I1 := { fldTy := I1_rect _ bool }.
Instance I2FieldType : FieldType I2 := { fldTy := I2_rect _ }.

Definition RecordOf F (FT: FieldType F) := forall f:F, fldTy f.

Class MapOps (M K : Set) := {
  tgtTy: K -> Set;
  update: M -> forall k:K, tgtTy k -> M
}.

Instance RecordMapOps F (FT: FieldType F) : MapOps (RecordOf F FT) F :=
{ tgtTy := fldTy; update := fun r (f: F) (x: fldTy f) z => r z }.

Axiom ex : RecordOf _ I1FieldType.

Definition works := (fun ex' => update ex' C true) (update ex C false).
Set Typeclasses Debug.
Definition doesnt := update (update ex C false) C true.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.basic.schedule.
Require Import rt.model.schedule.apa.affinity rt.model.schedule.apa.interference
               rt.model.schedule.apa.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module InterferenceEDF.

  Import Schedule Priority Platform Interference Priority Affinity.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* Consider any schedule. *)
    Variable num_cpus: nat.
    Variable sched: schedule Job num_cpus.

    (* Assume that every job at any time has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Assume that the schedule satisfies the global scheduling invariant
       for EDF, i.e., if any job of tsk is backlogged, every processor
       must be busy with jobs with no larger absolute deadline. *)
    Hypothesis H_scheduler_uses_EDF:
      respects_JLFP_policy_under_weak_APA job_arrival job_cost job_task arr_seq sched
                                          alpha (EDF job_arrival job_deadline).

    (* Under EDF scheduling, a job only causes interference if its deadline
       is not larger than the deadline of the analyzed job. *)
    Lemma interference_under_edf_implies_shorter_deadlines :
      forall j j' t1 t2,
        arrives_in arr_seq j' ->
        job_interference job_arrival job_cost job_task sched alpha j' j t1 t2 != 0 ->
        job_arrival j + job_deadline j <= job_arrival j' + job_deadline j'.
    Proof.
      rename H_scheduler_uses_EDF into PRIO.
      unfold respects_JLDP_policy_under_weak_APA in *.
      intros j j' t1 t2 ARR' INTERF.
      unfold job_interference in INTERF.
      destruct ([exists t': 'I_t2,
                   [exists cpu: processor num_cpus,
                      (t' >= t1) &&
                      backlogged job_arrival job_cost sched j' t' &&
                      can_execute_on alpha (job_task j') cpu &&
                      scheduled_on sched j cpu t']]) eqn:EX.
      {
        move: EX => /existsP [t' /existsP [cpu /andP [/andP [/andP [LE BACK] CAN] SCHED]]].
        by specialize (PRIO j' j cpu t' ARR' BACK SCHED CAN).
      }
      {
        apply negbT in EX; rewrite negb_exists in EX; move: EX => /forallP ALL.
        rewrite big_nat_cond (eq_bigr (fun x => 0)) in INTERF;
          first by rewrite -big_nat_cond big_const_nat iter_addn mul0n  addn0 eq_refl in INTERF.
        move => i /andP [/andP [GEi LTi] _].
        specialize (ALL (Ordinal LTi)).
        rewrite negb_exists in ALL.
        move: ALL => /forallP ALL.
        rewrite (eq_bigr (fun x => 0));
          first by rewrite big_const_ord iter_addn mul0n addn0.
        intros cpu _; specialize (ALL cpu); simpl in ALL.
        destruct (backlogged job_arrival job_cost sched j' i); last by rewrite andFb.
        rewrite GEi 2!andTb in ALL; rewrite andTb.
        by apply negbTE in ALL; rewrite ALL.
      }
    Qed.

  End Lemmas.

End InterferenceEDF.


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

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

Print Assumptions mul.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus (mult lv0 lv1) lv2) lv1) (plus (mult (Succ lv0) lv1) lv2)).
Admitted.
QuickChick conj22synthconj3.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj6 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult lv0 (Succ (plus lv1 lv2))) (plus (plus (mult lv2 lv0) lv0) (mult lv1 lv0))).
Admitted.
QuickChick conj14synthconj6.


Require Import List.
Import ListNotations.

From Vellvm Require Import
     Utils.Util
     Syntax.CFG
     Syntax.DynamicTypes
     Syntax.LLVMAst
     Syntax.AstLib
     Syntax.Scope
     Analysis.Dom
     Analysis.DomKildall.

(* Note : Would it make sense to define a modular notion of dominance tree?
   A.k.a. : Can we define the dominance tree on an open cfg parameterized by
   an entry point (or an entry interface ?).
 *)

(** * GRAPH instance for dominance calculation *)

Definition mem_id (g:cfg dtyp) (u: block_id): Prop :=
  match find_block (blks g) u with
  | Some _ => True
  | _ => False
  end.

Definition succ_id (g:cfg dtyp) (u: block_id) (v: block_id) : Prop :=
  match find_block (blks g) u with
  | None => False
  | Some i => In v (successors i)
  end.

Definition succ_id_cmp (g:cfg dtyp) (u: block_id): list block_id :=
  match find_block (blks g) u with
  | None => []
  | Some i => successors i
  end.

Definition inputs_cfg (g : cfg dtyp) : list block_id :=
  inputs g.(blks).

Module idGraph <: GRAPH.
  Definition t := cfg dtyp.
  Definition V := block_id.
  Definition eq_dec_V := raw_id_eq_dec.
  Definition entry (g : cfg dtyp) := init g.
  Definition edge := succ_id.
  Definition mem := mem_id.
End idGraph.

Module idGraphCmp <: GRAPH_CMP idGraph.
  Definition succs   := succ_id_cmp.
  Definition enum_vs := inputs_cfg.
End idGraphCmp.

(** Instantiate the dominance spec for this graph *)
Module Export Dominance := Dom.Spec idGraph.
Module Export Kildall := AlgdomKildall AstLib.RawIDOrd idGraph idGraphCmp.


From iris.base_logic Require Import invariants.
From iris.proofmode Require Import coq_tactics.
From iris.algebra Require Import lib.gmap_view.
From iris_time.heap_lang Require Import proofmode notation adequacy lang.
From iris_time Require Import Auth_nat Auth_max_nat Reduction Tactics.
From iris_time Require Export Simulation.

Implicit Type e : expr.
Implicit Type v : val.
Implicit Type σ : state.
Implicit Type t : list expr.
Implicit Type K : ectx heap_ectx_lang.
Implicit Type m n nmax : nat.
Implicit Type φ ψ : val → Prop.
Implicit Type Σ : gFunctors.

(*
 * Abstract interface of time receipts
 *)

(* Ideally, this would be represented as a record (or a typeclass), but it has
 * to be an Iris proposition (iProp Σ) and not a Coq proposition (Prop). *)
Definition TR_interface `{irisGS heap_lang Σ, Tick}
  (nmax : nat)
  (TR : nat → iProp Σ)
  (TRdup : nat → iProp Σ)
: iProp Σ := (
    ⌜∀ n, Timeless (TR n)⌝
  ∗ ⌜∀ n, Timeless (TRdup n)⌝
  ∗ ⌜∀ n, Persistent (TRdup n)⌝
  ∗ (∀ n, TR n ={⊤}=∗ TR n ∗ TRdup n)
  ∗ (|==> TR 0%nat)
(*   ∗ (|==> TRdup 0%nat) *)
  ∗ ⌜∀ m n, TR (m + n)%nat ≡ (TR m ∗ TR n)⌝
  ∗ ⌜∀ m n, TRdup (m `max` n)%nat ≡ (TRdup m ∗ TRdup n)⌝
(*   ∗ (TR nmax ={⊤}=∗ False) *)
  ∗ (TRdup nmax ={⊤}=∗ False)
  ∗ (∀ v n, {{{ TRdup n }}} tick v {{{ RET v ; TR 1%nat ∗ TRdup (n+1)%nat }}})
)%I.

(*
 * Prerequisites on the global monoid Σ
 *)

Class timeReceiptHeapPreG Σ := {
  timeReceiptHeapPreG_heapPreG :> heapGpreS Σ ;
  timeReceiptHeapPreG_inG1 :> inG Σ (authR natUR) ;
  timeReceiptHeapPreG_inG2 :> inG Σ (authR max_natUR) ;
}.

Class timeReceiptHeapG Σ := {
  timeReceiptHeapG_heapG :> heapGS Σ ;
  timeReceiptHeapG_inG1 :> inG Σ (authR natUR) ;
  timeReceiptHeapG_inG2 :> inG Σ (authR max_natUR) ;
  timeReceiptHeapG_loc :> TickCounter ;
  timeReceiptHeapG_name1 : gname ;
  timeReceiptHeapG_name2 : gname ;
}.

Local Notation γ1 := timeReceiptHeapG_name1.
Local Notation γ2 := timeReceiptHeapG_name2.
Local Notation ℓ := tick_counter.

(*
 * Implementation and specification of `TR` and `tick`
 *)

Definition loop : val :=
  rec: "f" <> := "f" #().

Global Instance receipts_tick `{TickCounter} : Tick :=
  generic_tick loop.

Section TickSpec.

  Context `{timeReceiptHeapG Σ} (nmax : nat).

  Definition TR (n : nat) : iProp Σ :=
    own γ1 (◯nat n).

  Definition TRdup (n : nat) : iProp Σ :=
    own γ2 (◯ MaxNat n).

  (* Note: we can avoid the update modality by redefining TR like so:
         Definition TR' n : iProp Σ := ⌜n = 0%nat⌝ ∨ TR n. *)
  Lemma zero_TR :
    ⊢ |==> TR 0.
  Proof. apply own_unit. Qed.
  Lemma TR_plus m n :
    TR (m + n) ≡ (TR m ∗ TR n)%I.
  Proof. by rewrite /TR auth_frag_op own_op. Qed.
  Lemma TR_succ n :
    TR (S n) ≡ (TR 1 ∗ TR n)%I.
  Proof. by rewrite (eq_refl : S n = 1 + n)%nat TR_plus. Qed.
  Lemma TR_weaken (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    TR n₁ -∗ TR n₂.
  Proof. apply own_auth_nat_weaken. Qed.

  Lemma TR_timeless n :
    Timeless (TR n).
  Proof. exact _. Qed.

  Global Instance into_sep_TR_plus m n : IntoSep (TR (m + n)) (TR m) (TR n).
  Proof. by rewrite /IntoSep TR_plus. Qed.
  Global Instance from_sep_TR_plus m n : FromSep (TR (m + n)) (TR m) (TR n).
  Proof. by rewrite /FromSep TR_plus. Qed.
  Global Instance into_sep_TR_succ n : IntoSep (TR (S n)) (TR 1) (TR n).
  Proof. by rewrite /IntoSep TR_succ. Qed.
  Global Instance from_sep_TR_succ n : FromSep (TR (S n)) (TR 1) (TR n).
  Proof. by rewrite /FromSep [TR (S n)] TR_succ. Qed.

  (* Note: we can avoid the update modality by redefining TRdup like so:
         Definition TRdup' n : iProp Σ := ⌜n = 0%nat⌝ ∨ TRdup n. *)
  Lemma zero_TRdup :
    ⊢ |==> TRdup 0.
  Proof. apply own_unit. Qed.
  Lemma TRdup_max m n :
    TRdup (m `max` n) ≡ (TRdup m ∗ TRdup n)%I.
  Proof. by rewrite /TRdup -own_op -auth_frag_op. Qed.
  Lemma TRdup_weaken (n₁ n₂ : nat) :
    (n₂ ≤ n₁)%nat →
    TRdup n₁ -∗ TRdup n₂.
  Proof. apply own_auth_max_nat_weaken. Qed.

  Lemma TRdup_timeless n :
    Timeless (TRdup n).
  Proof. exact _. Qed.
  Lemma TRdup_persistent n :
    Persistent (TRdup n).
  Proof. exact _. Qed.

  Global Instance into_sep_TRdup_max m n : IntoSep (TRdup (m `max` n)) (TRdup m) (TRdup n).
  Proof. by rewrite /IntoSep TRdup_max. Qed.
  Global Instance from_sep_TRdup_max m n : FromSep (TRdup (m `max` n)) (TRdup m) (TRdup n).
  Proof. by rewrite /FromSep TRdup_max. Qed.

  Definition timeReceiptN := nroot .@ "timeReceipt".

  Definition TR_invariant : iProp Σ :=
    inv timeReceiptN (∃ (n:nat), ℓ ↦ #(nmax-n-1) ∗ own γ1 (●nat n) ∗ own γ2 (● MaxNat n) ∗ ⌜(n < nmax)%nat⌝)%I.

  Lemma TR_nmax_absurd (E : coPset) :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗ TR nmax ={E}=∗ False.
  Proof.
    iIntros (?) "#Inv Hγ1◯".
    iInv timeReceiptN as (n) ">(Hℓ & Hγ1● & Hγ2● & In)" "InvClose" ; iDestruct "In" as %In.
    iDestruct (own_auth_nat_le with "Hγ1● Hγ1◯") as %In'.
    exfalso ; lia.
  Qed.
  Lemma TR_lt_nmax n (E : coPset) :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗ TR n ={E}=∗ TR n ∗ ⌜n < nmax⌝%nat.
  Proof.
    iIntros (?) "#Inv Hγ1◯".
    destruct (le_lt_dec nmax n) as [ I | I ] ; last by iFrame.
    iDestruct (TR_weaken n nmax with "Hγ1◯") as "Hγ1◯" ; first done.
    iDestruct (TR_nmax_absurd with "Inv Hγ1◯") as ">?" ; first done.
    done.
  Qed.

  Lemma TRdup_nmax_absurd (E : coPset) :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗ TRdup nmax ={E}=∗ False.
  Proof.
    iIntros (?) "#Inv Hγ2◯".
    iInv timeReceiptN as (n) ">(Hℓ & Hγ1● & Hγ2● & In)" "InvClose" ; iDestruct "In" as %In.
    iDestruct (own_auth_max_nat_le with "Hγ2● Hγ2◯") as %In'. exfalso ; lia.
  Qed.
  Lemma TRdup_lt_nmax n (E : coPset) :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗ TRdup n ={E}=∗ TRdup n ∗ ⌜n < nmax⌝%nat.
  Proof.
    iIntros (?) "#Inv Hγ1◯".
    destruct (le_lt_dec nmax n) as [ I | I ] ; last by iFrame.
    iDestruct (TRdup_weaken n nmax with "Hγ1◯") as "Hγ1◯" ; first done.
    iDestruct (TRdup_nmax_absurd with "Inv Hγ1◯") as ">?" ; first done.
    done.
  Qed.

  Lemma TR_TRdup (E : coPset) n :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗ TR n ={E}=∗ TR n ∗ TRdup n.
  Proof.
    iIntros (?) "#Inv Hγ1◯".
    iInv timeReceiptN as (m) ">(Hℓ & Hγ1● & Hγ2● & Im)" "InvClose".
    iDestruct (own_auth_nat_le with "Hγ1● Hγ1◯") as %In.
    iDestruct (auth_max_nat_update_read_auth with "Hγ2●") as ">[Hγ2● Hγ2◯]".
    iAssert (TR n ∗ TRdup n)%I with "[$Hγ1◯ Hγ2◯]" as "$". {
      rewrite (_ : m = m `max` n)%nat ; last lia.
      iDestruct "Hγ2◯" as "[_ $]".
    }
    iApply "InvClose". auto with iFrame.
  Qed.

  Theorem loop_spec s E (Φ : val → iProp Σ) :
    ⊢ WP loop #() @ s ; E {{ Φ }}.
  Proof.
    iLöb as "IH". wp_rec. iExact "IH".
  Qed.

  Theorem tick_spec s E (v : val) m :
    ↑timeReceiptN ⊆ E →
    TR_invariant -∗
    {{{ TRdup m }}} tick v @ s ; E {{{ RET v ; TR 1 ∗ TRdup (m+1) }}}.
  Proof.
    intros ?. iIntros "#Inv" (Ψ) "!# Hγ2◯ HΨ".
    iLöb as "IH".
    wp_lam.
    (* open the invariant, in order to read the value k = nmax−n−1 of location ℓ: *)
    wp_bind (! _)%E ;
    iInv timeReceiptN as (n) ">(Hℓ & Hγ1● & Hγ2● & In)" "InvClose" ; iDestruct "In" as %In.
    wp_load.
    (* close the invariant: *)
    iMod ("InvClose" with "[ Hℓ Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ].
    wp_let.
    (* test whether k ≤ 0: *)
    wp_op ; destruct (bool_decide (nmax - n - 1 ≤ 0)) eqn:Im ; wp_if.
    (* — if k ≤ 0 then we loop indefinitely, which gives us any spec we want
         (because we are reasoning in partial correctness): *)
    - iApply loop_spec.
    (* — otherwise: *)
    - apply Is_true_false in Im ; rewrite -> bool_decide_spec in Im.
      wp_op.
      (* open the invariant again, in order to perform CAS on location ℓ: *)
      wp_bind (CAS _ _ _)%E ;
      iInv timeReceiptN as (n') ">(Hℓ & Hγ1● & Hγ2● & In')" "InvClose" ; iDestruct "In'" as %In'.
      (* test whether the value ℓ is still k, by comparing n with n': *)
      destruct (nat_eq_dec n n') as [ <- | Hneq ].
      (* — if it holds, then CAS succeeds and ℓ is decremented: *)
      + wp_cas_suc.
        (* reform the invariant with n+1 instead of n, and an additional time
           receipt produced: *)
        replace (nmax - n - 1 - 1) with (nmax - (n+1)%nat - 1) by lia.
        iMod (auth_nat_update_incr _ _ 1 with "Hγ1●") as "[Hγ1● Hγ1◯]".
        iMod (auth_max_nat_update_incr' _ _ _ 1 with "Hγ2● Hγ2◯") as "[Hγ2● Hγ2◯]".
        assert ((n+1) < nmax)%nat by lia.
        (* close the invariant: *)
        iMod ("InvClose" with "[ Hℓ Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ].
        (* finish: *)
        wp_if. iApply "HΨ" ; by iFrame.
      (* — otherwise, CAS fails and ℓ is unchanged: *)
      + wp_cas_fail ; first (injection ; lia).
        (* close the invariant as is: *)
        iMod ("InvClose" with "[ Hℓ Hγ1● Hγ2● ]") as "_" ; [ by auto with iFrame | iModIntro ] ; clear dependent n.
        wp_if.
        (* conclude using the induction hypothesis: *)
        iApply ("IH" with "Hγ2◯ HΨ").
  Qed.

  Theorem tick_spec_simple v n :
    TR_invariant -∗
    {{{ TRdup n }}} tick v {{{ RET v ; TR 1 ∗ TRdup (n+1) }}}.
  Proof.
    iIntros "#Inv" (Ψ) "!# H HΨ".
    by iApply (tick_spec with "Inv H HΨ").
  Qed.

  Lemma TR_implementation : TR_invariant -∗ TR_interface nmax TR TRdup.
  Proof.
    iIntros "#Hinv". repeat iSplitR.
    - iPureIntro. by apply TR_timeless.
    - iPureIntro. by apply TRdup_timeless.
    - iPureIntro. by apply TRdup_persistent.
    - iIntros (n). by iApply (TR_TRdup with "Hinv").
    - by iApply zero_TR.
    - iPureIntro. by apply TR_plus.
    - iPureIntro. by apply TRdup_max.
    - by iApply (TRdup_nmax_absurd with "Hinv").
    - iIntros (v n). by iApply (tick_spec_simple with "Hinv").
  Qed.

End TickSpec.

(*
 * Soundness
 *)

Section Soundness.

  Definition adequate_trtranslation__nadequate := adequate_translation__nadequate loop.

  (* derive the adequacy of the translated program from a Hoare triple in Iris. *)

  Lemma spec_trtranslation__adequate_translation {Σ} nmax ψ e :
    (0 < nmax)%nat →
    (∀ `{timeReceiptHeapG Σ},
      TR_invariant nmax -∗
      {{{ True }}} «e» {{{ v, RET v ; ⌜ψ v⌝ }}}
    ) →
    ∀ `{timeReceiptHeapPreG Σ, TickCounter} σ,
      adequate NotStuck «e» S«σ,nmax-1» (λ v σ, ψ v).
  Proof.
    intros Inmax Hspec HpreG Hloc σ.
    (* apply the adequacy results. *)
    apply (wp_adequacy _ _) ; simpl ; intros HinvG κ.
    (* … now we have to prove a WP. *)
    set σ' := S«σ».
    (* allocate the heap, including cell ℓ (on which we need to keep an eye): *)
    iMod (gen_heap_init (<[ℓ := #(nmax-1)%nat]> σ')) as (Hheap) "(Hh● & Hℓ◯ & _)".
    iDestruct (big_sepM_lookup _ _ ℓ with "Hℓ◯") as "Hℓ◯".
    { by rewrite lookup_insert. }
    (* allocate the ghost state associated with ℓ: *)
    iMod (auth_nat_alloc 0) as (γ1) "[Hγ1● _]".
    iMod (auth_max_nat_alloc 0) as (γ2) "[Hγ2● _]".
    (* packing all those bits, build the heap instance necessary to use time receipts: *)
    pose (Build_timeReceiptHeapG Σ (HeapGS Σ _ Hheap) _ _ _ γ1 γ2)
      as HtrHeapG.
    (* create the invariant: *)
    iAssert (|={⊤}=> TR_invariant nmax)%I with "[Hℓ◯ Hγ1● Hγ2●]" as "> Hinv".
    {
      iApply inv_alloc.
      iExists 0%nat. rewrite (_ : nmax - 0 - 1 = Z.of_nat (nmax - 1)) ; last lia.
      by iFrame.
    }
    iModIntro.
    (* finally, use the user-given specification: *)
    iExists (λ σ _, gen_heap_interp σ), (λ _, True%I). iFrame.
    iApply (Hspec with "Hinv") ; auto.
  Qed.

  Theorem spec_trtranslation__nadequate {Σ} nmax φ e :
    (0 < nmax)%nat →
    (∀ `{timeReceiptHeapG Σ},
      TR_invariant nmax -∗
      {{{ True }}} «e» {{{ v, RET v ; ⌜φ (invtranslationV v)⌝ }}}
    ) →
    ∀ `{!timeReceiptHeapPreG Σ} σ,
      nadequate NotStuck (nmax-1) e σ φ.
  Proof.
    intros Inmax Hspec HpreG σ.
    eapply adequate_trtranslation__nadequate.
    intros Hloc. by eapply spec_trtranslation__adequate_translation.
  Qed.

  Theorem abstract_spec_trtranslation__nadequate {Σ} nmax φ e :
    (0 < nmax)%nat →
    (∀ `{heapGS Σ, Tick} (TR TRdup : nat → iProp Σ),
      TR_interface nmax TR TRdup -∗
      {{{ True }}} «e» {{{ v, RET v ; ⌜φ (invtranslationV v)⌝ }}}
    ) →
    ∀ {_ : timeReceiptHeapPreG Σ} σ,
      nadequate NotStuck (nmax-1) e σ φ.
  Proof.
    intros Inmax Hspec HpreG σ.
    eapply spec_trtranslation__nadequate; try done.
    clear HpreG. iIntros (HtrHeapG) "#Hinv".
    iApply Hspec. by iApply TR_implementation.
  Qed.

End Soundness.

(*
 * Proof-mode tactics for proving WP of translated expressions
 *)

Lemma tac_wp_tick `{timeReceiptHeapG Σ} Δ pe Δ1 Δ2 Δ' i max_tc s E K (v : val) Φ :
  ↑timeReceiptN ⊆ E →
  MaybeIntoLaterNEnvs 1 Δ Δ1 →

  envs_lookup i Δ = Some (pe, TR_invariant max_tc) →

  (∃ j pe' p, envs_lookup j Δ1 = Some (pe', TRdup p) ∧
              envs_simple_replace j pe' (Esnoc Enil j (TRdup (S p))) Δ1 = Some Δ2) ∨
  Δ1 = Δ2 →

  (∃ j n, envs_lookup j Δ2 = Some (false, TR n) ∧
          envs_simple_replace j false (Esnoc Enil j (TR (S n))) Δ2 = Some Δ') ∨
  Δ2 = Δ' →

  envs_entails Δ' (WP fill K v @ s; E {{ Φ }}) →
  envs_entails Δ (WP fill K (App tick v) @ s; E {{ Φ }}).
Proof.
  rewrite envs_entails_eq=>??? HTRdup HTR HWP.
  iIntros "HΔ".
  iAssert (TR_invariant max_tc) as "#Hinv".
  { destruct pe.
    iDestruct (envs_lookup_sound _ i true with "HΔ") as "[? _]"=>//.
    iDestruct (envs_lookup_sound _ i false with "HΔ") as "[? _]"=>//. }
  iDestruct (into_laterN_env_sound with "HΔ") as "HΔ1"=>//.
  iApply wp_bind.
  destruct HTR as [(j & n & HTR1 & HTR2)| ->],
           HTRdup as [(j' & pe'' & p & HTRDup1 & HTRDup2)| ->].
  - iDestruct (envs_simple_replace_singleton_sound with "HΔ1") as "[HTRdup HΔ2]"=>//.
    rewrite bi.intuitionistically_if_elim -bi.intuitionistically_intuitionistically_if.
    iDestruct "HTRdup" as "#>HTRdup".
    iApply (tick_spec with "[//] HTRdup")=>//. iIntros "!> [HTR #HTRdup']". iApply HWP.
    rewrite Nat.add_comm. iSpecialize ("HΔ2" with "[//]").
    iDestruct (envs_simple_replace_singleton_sound with "HΔ2") as "[HTR' HΔ']"=>//=.
    iCombine "HTR HTR'" as "HTR". iDestruct ("HΔ'" with "HTR") as "$".
  - iMod zero_TRdup as "HTRdup".
    iApply (tick_spec with "[//] HTRdup")=>//. iIntros "!> [HTR _]". iApply HWP.
    iDestruct (envs_simple_replace_singleton_sound with "HΔ1") as "[HTR' HΔ']"=>//=.
    iCombine "HTR HTR'" as "HTR". iDestruct ("HΔ'" with "HTR") as "$".
  - iDestruct (envs_simple_replace_singleton_sound with "HΔ1") as "[HTRdup HΔ']"=>//.
    rewrite bi.intuitionistically_if_elim -bi.intuitionistically_intuitionistically_if.
    iDestruct "HTRdup" as "#>HTRdup".
    iApply (tick_spec with "[//] HTRdup")=>//. iIntros "!> [_ #HTRdup']". iApply HWP.
    rewrite Nat.add_comm. iDestruct ("HΔ'" with "[//]") as "$".
  - iMod zero_TRdup as "HTRdup".
    iApply (tick_spec with "[//] HTRdup")=>//. iIntros "!> [_ #HTRdup']". by iApply HWP.
Qed.

Ltac wp_tick ::=
  iStartProof ;
  simpl_trans ;
  lazymatch goal with
  | |- envs_entails _ (wp ?s ?E ?e ?Q) =>
      first
        [ reshape_expr false e ltac:(fun K e' =>
            eapply (tac_wp_tick _ _ _ _ _ _ _ _ _ K)
          )
        | fail 1 "wp_tick: cannot find 'tick ?v' in" e ] ;
      [ try solve_ndisj
      | exact _
      | (* lookup invariant: *) (iAssumptionCore || fail "wp_tick: cannot find TR_invariant")
      | (* lookup TRdup: *) (
        left; eexists _, _, _; split;
        [iAssumptionCore | proofmode.reduction.pm_reflexivity]
        || right; reflexivity)
      | (* lookup TR:    *) (
        left; eexists _, _; split;
        [iAssumptionCore | proofmode.reduction.pm_reflexivity]
        || right; reflexivity)
      | wp_expr_simpl ]
  | |- envs_entails _ (twp ?s ?E ?e ?Q) =>
      fail "wp_tick is not implemented for twp"
  | _ => fail "wp_tick: not a 'wp'"
  end.


Require Crypto.Curves.Edwards.Pre.
Require Crypto.Util.Decidable.

Module E.
  Section TwistedEdwardsCurves.
    (* Twisted Edwards curves with complete addition laws. References:
    * <https://eprint.iacr.org/2008/013.pdf>
    * <http://ed25519.cr.yp.to/ed25519-20110926.pdf>
    * <https://eprint.iacr.org/2015/677.pdf>
    *)

    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@Algebra.Hierarchy.field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos BinNat.N.two)}
            {Feq_dec:Decidable.DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x) (at level 30).

    Context {a d: F}
            {nonzero_a : a <> 0}
            {square_a : exists sqrt_a, sqrt_a^2 = a}
            {nonsquare_d : forall x, x^2 <> d}.

    Definition point := { xy | let '(x, y) := xy in a*x^2 + y^2 = 1 + d*x^2*y^2 }.
    Definition coordinates (P:point) : (F*F) := let (xy, xy_onCurve_proof) := P in xy.
    Definition eq (P Q:point) :=
      match coordinates P, coordinates Q with
        (x1,y1), (x2,y2) => x1 = x2 /\ y1 = y2
      end.

    Program Definition zero : point := (0, 1).
    Next Obligation. eauto using Pre.onCurve_zero. Qed.

    Program Definition add (P1 P2:point) : point :=
      match coordinates P1, coordinates P2 return (F*F) with
        (x1, y1), (x2, y2) =>
        (((x1*y2  +  y1*x2)/(1 + d*x1*x2*y1*y2)) , ((y1*y2 - a*x1*x2)/(1 - d*x1*x2*y1*y2)))
      end.
    Next Obligation. do 2 match goal with P : point |- _ => destruct P as [[??]?] end; eapply Pre.onCurve_add; eauto. Qed.

    Fixpoint mul (n:nat) (P : point) : point :=
      match n with
      | O => zero
      | S n' => add P (mul n' P)
      end.
  End TwistedEdwardsCurves.
End E.

Declare Scope E_scope.
Delimit Scope E_scope with E.
Infix "=" := E.eq : E_scope.
Infix "+" := E.add : E_scope.
Infix "*" := E.mul : E_scope.


(** The Wild Category of Wild Categories, Wild Functors and Wild Natural Transformations **)
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import sem.signature.hit_signature.

Require Import Integers.WildCategories.WildCat.
Require Import Integers.WildCategories.DispWildCat.
Require Import Integers.WildCategories.WildFunctor.
Import WildFunctor.Notations.
Require Import Integers.WildCategories.WildNaturalTransformation.
Import WildNaturalTransformation.Notations.

Local Open Scope cat.
Local Open Scope bicategory_scope.
Local Open Scope mor_disp_scope.

Definition wild_cat_of_wild_cats : wild_cat.
Proof.
  use build_wild_cat.
  - exact wild_cat.
  - exact (λ C D, wild_functor C D).
  - exact (λ C D F G, wild_nat_trans F G).
  - exact (λ C, id_wild_functor C).
  - exact (λ C D E F G, F ⋯ G).
  - exact (λ C D F, id_wild_nat_trans F).
  - exact (λ C D F G H η γ, comp_wild_nat_trans η γ).
  - exact (λ C D E F G H η, lwhisker_wild_nat_trans F η).
  - exact (λ C D E F G H η, rwhisker_wild_nat_trans η H).
  - exact (λ C D F, lunitor_wild_nat_trans F).
  - exact (λ C D F, linvunitor_wild_nat_trans F).
  - exact (λ C D F, runitor_wild_nat_trans F).
  - exact (λ C D F, rinvunitor_wild_nat_trans F).
  - exact (λ C D E B F G H, lassociator_wild_nat_trans F G H).
  - exact (λ C D E B F G H, rassociator_wild_nat_trans F G H).
Defined.