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

 The enriched Kleisli category

 In this file we define an enrichment of the Kleisli category (that is
 not guaranteed to be univalent).

 Contents
 1. Data of the enrichment
 2. The laws of the enrichment
 3. The enrichment

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
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.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentMonad.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.KleisliCategory.

Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedKleisli.
  Context {V : monoidal_cat}
          {C : category}
          {E : enrichment C V}
          {M : Monad C}
          (EM : monad_enrichment E M).

  (**
   1. Data of the enrichment
   *)
  Definition Kleisli_cat_monad_enrichment_data
    : enrichment_data (Kleisli_cat_monad M) V.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _ ,, _).
    - exact (λ x y, E ⦃ x , M y ⦄).
    - exact (λ x, enriched_from_arr E (η M x)).
    - exact (λ x y z,
             endo_of_monad_enrichment EM y (M z) #⊗ identity _
             · enriched_comp E x (M y) (M(M z))
             · mon_linvunitor _
             · enriched_from_arr E (μ M z) #⊗ identity _
             · enriched_comp E x (M (M z)) (M z)).
    - exact (λ x y f, enriched_from_arr E (f · η M y)).
    - exact (λ x y f, enriched_to_arr E f).
  Defined.

  (**
   2. The laws of the enrichment
   *)
  Definition Kleisli_cat_monad_enrichment_laws
    : enrichment_laws Kleisli_cat_monad_enrichment_data.
  Proof.
    repeat split.
    - intros x y ; cbn.
      refine (enrichment_id_left _ _ _ @ _).
      etrans.
      {
        rewrite <- (enriched_from_arr_id E (M y)).
        rewrite <- (@Monad_law2 _ M y).
        rewrite enriched_from_arr_comp.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        rewrite !assoc.
        etrans.
        {
          do 4 apply maponpaths_2.
          refine (!_).
          apply tensor_comp_mor.
        }
        rewrite id_right.
        rewrite <- (functor_enrichment_from_arr EM).
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply tensor_split.
          }
          rewrite tensor_split'.
          rewrite !assoc'.
          apply maponpaths.
          apply enrichment_assoc'.
        }
        apply idpath.
      }
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        rewrite tensor_split.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      rewrite tensor_comp_id_r.
      apply maponpaths.
      cbn.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          refine (!_).
          apply tensor_id_id.
        }
        apply tensor_rassociator.
      }
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply tensor_comp_id_r.
      }
      refine (!(tensor_comp_id_r _ _) @ _).
      apply idpath.
    - intros x y ; cbn.
      rewrite !assoc'.
      refine (_ @ id_left _).
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply mon_runitor_rinvunitor.
      }
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 4 apply maponpaths_2.
          refine (!_).
          apply tensor_split.
        }
        rewrite !assoc.
        do 3 apply maponpaths_2.
        exact (unit_of_monad_enrichment EM x (M y)).
      }
      cbn.
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 3 apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths.
            refine (!_).
            apply tensor_id_id.
          }
          refine (!_).
          apply tensor_lassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply mon_lassociator_rassociator.
        }
        apply id_left.
      }
      pose (maponpaths
              (enriched_from_arr E)
              (@Monad_law1 _ M y))
        as p.
      rewrite enriched_from_arr_id in p.
      rewrite enriched_from_arr_comp in p.
      refine (_ @ mon_linvunitor_lunitor _).
      apply maponpaths.
      refine (_ @ !(enrichment_id_left _ _ _)).
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply tensor_comp_id_r.
          }
          refine (!_).
          apply tensor_comp_id_r.
        }
        refine (!_).
        apply tensor_comp_id_r.
      }
      apply maponpaths_2.
      refine (_ @ p).
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        rewrite tensor_split.
        apply idpath.
      }
      rewrite !assoc.
      apply maponpaths_2.
      refine (!_).
      apply tensor_linvunitor.
    - intros w x y z ; cbn.
      (*
       The equation basically says that for all

         f : w --> M x
         g : x --> M y
         h : y --> M z

       we have

         (f · #M ((g · #M h) · μ M z)) · μ M z
         =
         ((f · #M g) · μ M y) · #M h · μ M z
       *)
      rewrite !assoc'.
      (*
       (f · #M ((g · #M h) · μ M z)) · μ M z
       =
       f · (#M ((g · #M h) · μ M z) · μ M z)
       *)
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      refine (!_).
      (*
       ((f · #M g) · μ M y) · #M h · μ M z
       =
       ((f · #M g) · μ M y) · (#M h · μ M z)
       *)
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            exact (!(tensor_comp_id_r _ _)).
          }
          exact (!(tensor_comp_id_r _ _)).
        }
        refine (!(tensor_split) _ _ @ _).
        apply tensor_split'.
      }
      (*
       ((f · #M g) · μ M y) · (#M h · μ M z)
       =
       (f · #M g) · (μ M y · (#M h · μ M z))
       *)
      etrans.
      {
        rewrite !assoc'.
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply tensor_rassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply mon_inv_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      rewrite !assoc'.
      (*
       (f · #M g) · (μ M y · (#M h · μ M z))
       =
       f · (#M g · (μ M y · (#M h · μ M z)))
       *)
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths_2.
            exact (!(tensor_comp_id_r _ _)).
          }
          etrans.
          {
            apply maponpaths_2.
            exact (!(tensor_comp_id_r _ _)).
          }
          exact (!(tensor_comp_id_r _ _)).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply tensor_comp_id_l.
          }
          rewrite !assoc'.
          apply maponpaths.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        do 2 apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc.
      apply maponpaths_2.
      rewrite !assoc'.
      (*
       Simplify so that `w` does not occur in the equation
       *)
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      rewrite !assoc'.
      etrans.
      {
        do 3 apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        do 2 apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        exact (!(tensor_comp_id_r _ _)).
      }
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          exact (!(tensor_id_id _ _)).
        }
        apply tensor_rassociator.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        apply tensor_rassociator.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 3 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          exact (!(tensor_id_id _ _)).
        }
        apply tensor_rassociator.
      }
      etrans.
      {
        rewrite !assoc.
        etrans.
        {
          do 4 apply maponpaths_2.
          apply mon_lassociator_rassociator.
        }
        rewrite id_left.
        etrans.
        {
          do 2 apply maponpaths_2.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          apply maponpaths_2.
          exact (!(tensor_comp_id_r _ _)).
        }
        exact (!(tensor_comp_id_r _ _)).
      }
      apply maponpaths_2.
      clear w.
      (*
       We simplified the equation, and now we need to show that for all

         g : x --> M y
         h : y --> M z

       we have

         #M ((g · #M h) · μ M z) · μ M z
         =
         #M g · (μ M y · (#M h · μ M z))
       *)
      rewrite !assoc'.
      refine (!_).
      (*
         #M ((g · #M h) · μ M z) · μ M z
         =
         (#M (g · #M h) · #M (μ M z)) · μ M z
       *)
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc.
        do 3 apply maponpaths_2.
        apply (functor_enrichment_comp EM).
      }
      rewrite !assoc'.
      (*
         (#M (g · #M h) · #M (μ M z)) · μ M z
         =
         #M (g · #M h) · (#M (μ M z) · μ M z)
       *)
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      (*
         #M (g · #M h) · (#M (μ M z) · μ M z)
         =
         (#M g · #M(#M h)) · (#M (μ M z) · μ M z)
       *)
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 6 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 5 apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        do 4 apply maponpaths_2.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_left.
        apply maponpaths.
        apply (functor_enrichment_comp EM).
      }
      (*
         (#M g · #M(#M h)) · (#M (μ M z) · μ M z)
         =
         #M g · (#M(#M h) · (#M (μ M z) · μ M z))
       *)
      etrans.
      {
        rewrite !assoc'.
        do 3 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_l_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          do 3 apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          do 2 apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        do 5 apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          apply tensor_split.
        }
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          do 2 apply maponpaths.
          refine (!(tensor_split' _ _) @ _).
          apply tensor_split.
        }
        rewrite !assoc.
        apply maponpaths_2.
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply tensor_linvunitor.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!(tensor_comp_mor _ _ _ _) @ _).
        rewrite id_left.
        apply tensor_split.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        refine (!(tensor_split' _ _) @ _).
        apply tensor_split.
      }
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        refine (!_).
        apply tensor_comp_id_r.
      }
      refine (!_).
      etrans.
      {
        do 6 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            refine (!_).
            apply mon_linvunitor_triangle.
          }
          rewrite !assoc'.
          etrans.
          {
            apply maponpaths.
            apply mon_lassociator_rassociator.
          }
          apply id_right.
        }
        rewrite !assoc'.
        exact (!(tensor_comp_id_r _ _)).
      }
      etrans.
      {
        exact (!(tensor_comp_id_r _ _)).
      }
      apply maponpaths_2.
      clear x.
      (*
       We simplified the equation, and now we need to show that for all

         h : y --> M z

       we have

         μ M y · (#M h · μ M z)
         =
         #M(#M h) · (#M (μ M z) · μ M z)
       *)
      assert (enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (# M (μ M z))
              · enriched_comp E (M (M (M z))) (M (M z)) (M z)
              =
              enriched_from_arr E (μ M z) #⊗ enriched_from_arr E (μ M (M z))
              · enriched_comp E (M (M (M z))) (M (M z)) (M z))
        as p.
      {
        refine (!(id_left _) @ _ @ id_left _).
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_lunitor_linvunitor.
        }
        etrans.
        {
          rewrite !assoc'.
          apply maponpaths.
          pose (p := maponpaths
                       (enriched_from_arr E)
                       (@Monad_law3 _ M z)).
          rewrite !enriched_from_arr_comp in p.
          cbn in p.
          rewrite !assoc.
          exact p.
        }
        rewrite !assoc.
        do 2 apply maponpaths_2.
        apply mon_lunitor_linvunitor.
      }
      rewrite (functor_enrichment_from_arr EM) in p.
      (**
         #M(#M h) · (#M (μ M z) · μ M z)
         =
         #M(#M h) · (μ M (M z) · μ M z)
       *)
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          do 3 apply maponpaths_2.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          do 2 apply maponpaths_2.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          apply maponpaths_2.
          exact (!(tensor_comp_id_r _ _)).
        }
        etrans.
        {
          exact (!(tensor_comp_id_r _ _)).
        }
        apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          exact (!(tensor_split _ _)).
        }
        exact p.
      }
      clear p.
      (*
         #M(#M h) · (μ M (M z) · μ M z)
         =
         (#M(#M h) · μ M (M z)) · μ M z
       *)
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_r.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc.
      }
      refine (!_).
      (*
       μ M y · (#M h · μ M z)
       =
       (μ M y · #M h) · μ M z
       *)
      etrans.
      {
        do 3 apply maponpaths.
        apply enrichment_assoc.
      }
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        do 4 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        refine (!(tensor_split _ _) @ _).
        apply tensor_split'.
      }
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            apply tensor_split'.
          }
          rewrite !assoc.
          apply maponpaths_2.
          rewrite mon_linvunitor_I_mon_rinvunitor_I.
          refine (!_).
          apply tensor_rinvunitor.
        }
        rewrite !assoc'.
        apply tensor_comp_id_r.
      }
      rewrite !assoc'.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            rewrite !assoc.
            do 3 apply maponpaths_2.
            refine (!_).
            apply tensor_id_id.
          }
          etrans.
          {
            apply maponpaths_2.
            apply tensor_lassociator.
          }
          rewrite !assoc'.
          apply maponpaths.
          refine (!_).
          apply tensor_comp_id_l.
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          refine (!_).
          apply mon_rinvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          etrans.
          {
            apply maponpaths_2.
            apply mon_rassociator_lassociator.
          }
          apply id_left.
        }
        exact (!(tensor_comp_id_l _ _)).
      }
      refine (!(tensor_comp_id_l _ _) @ _).
      refine (!_).
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths_2.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_lassociator.
        }
        rewrite !assoc'.
        etrans.
        {
          do 2 apply maponpaths.
          exact (!(tensor_comp_id_l _ _)).
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_comp_id_r.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            rewrite !assoc.
            apply maponpaths_2.
            apply tensor_lassociator.
          }
          rewrite !assoc'.
          apply maponpaths.
          exact (!(tensor_comp_id_l _ _)).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_inv_triangle.
        }
        exact (!(tensor_comp_id_l _ _)).
      }
      apply maponpaths.
      (*
       We simplified the equation, and now we need to show that for all

         h : y --> M z

       we have

         #M(#M h) · μ M (M z)
         =
         μ M y · #M h
       *)
      pose (p := mu_of_monad_enrichment EM y (M z)).
      cbn in p.
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        exact (!(tensor_split' _ _)).
      }
      rewrite !assoc.
      refine (!p @ _) ; clear p.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply tensor_rinvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      exact (!(tensor_split' _ _)).
    - intros x y f ; cbn.
      rewrite enriched_to_from_arr.
      etrans.
      {
        apply maponpaths.
        apply bind_η.
      }
      apply id_right.
    - intros x y f ; cbn.
      rewrite enriched_from_arr_comp.
      rewrite enriched_from_to_arr.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          apply bind_η.
        }
        apply enriched_from_arr_id.
      }
      rewrite tensor_split.
      rewrite !assoc'.
      rewrite <- enrichment_id_left.
      rewrite tensor_lunitor.
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        apply mon_linvunitor_lunitor.
      }
      apply id_left.
    - intros x ; cbn.
      rewrite enriched_to_from_arr.
      apply idpath.
    - intros x y z f g ; cbn.
      unfold bind.
      use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn.
      rewrite enriched_from_to_arr.
      rewrite enriched_from_arr_comp.
      rewrite !assoc'.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc.
      apply maponpaths_2.
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths.
            refine (!_).
            apply tensor_id_id.
          }
          refine (!_).
          apply tensor_lassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_lassociator_rassociator.
        }
        apply id_left.
      }
      rewrite <- !tensor_comp_mor.
      rewrite !id_left.
      rewrite id_right.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          exact (@Monad_law2 _ M y).
        }
        apply id_right.
      }
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply (@Monad_law2 _ M z).
        }
        apply id_right.
      }
      rewrite enriched_from_arr_comp.
      rewrite !assoc.
      apply maponpaths_2.
      etrans.
      {
        apply maponpaths_2.
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      apply maponpaths.
      etrans.
      {
        refine (!_).
        apply tensor_comp_mor.
      }
      rewrite !id_left, id_right.
      apply maponpaths.
      rewrite (functor_enrichment_from_arr EM g).
      apply idpath.
  Qed.

  (**
   3. The enrichment
   *)
  Definition Kleisli_cat_monad_enrichment
    : enrichment (Kleisli_cat_monad M) V.
  Proof.
    simple refine (_ ,, _).
    - exact Kleisli_cat_monad_enrichment_data.
    - exact Kleisli_cat_monad_enrichment_laws.
  Defined.

  Definition Left_Kleisli_functor_enrichment_laws
    : @is_functor_enrichment
        _ _ _
        (Left_Kleisli_functor M)
        E
        Kleisli_cat_monad_enrichment
        (λ x y : C, postcomp_arr E x (η M y)).
  Proof.
    repeat split.
    - intro x.
      exact (enriched_id_postcomp_arr E (η M x)).
    - cbn.
      intros x y z.
      etrans.
      {
        apply enriched_comp_postcomp_arr.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        apply tensor_split'.
      }
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      etrans.
      {
        do 4 apply maponpaths_2.
        exact (!(tensor_split _ _)).
      }
      unfold postcomp_arr.
      etrans.
      {
        do 4 apply maponpaths_2.
        apply tensor_comp_l_id_r.
      }
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_id_l.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply enrichment_assoc'.
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            do 2 apply maponpaths_2.
            apply tensor_id_id.
          }
          refine (!(tensor_split _ _) @ _).
          apply tensor_split'.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply enrichment_assoc'.
      }
      rewrite !assoc.
      refine (_ @ id_left _).
      apply maponpaths_2.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 3 apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            refine (!(tensor_id_id _ _) @ _).
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 4 apply maponpaths_2.
          apply mon_lassociator_rassociator.
        }
        rewrite id_left.
        rewrite !assoc'.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !assoc.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            exact (!(tensor_id_id _ _)).
          }
          apply tensor_rassociator.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !assoc.
          do 2 apply maponpaths_2.
          apply tensor_rassociator.
        }
        rewrite !assoc.
        do 3 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          exact (!(tensor_id_id _ _)).
        }
        apply tensor_rassociator.
      }
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          refine (!_).
          apply tensor_comp_id_r.
        }
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply tensor_comp_id_r.
        }
        refine (!_).
        apply tensor_comp_id_r.
      }
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply tensor_comp_l_id_l.
        }
        rewrite !assoc'.
        apply maponpaths.
        apply tensor_rassociator.
      }
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        refine (!_).
        apply tensor_comp_id_r.
      }
      rewrite !assoc.
      etrans.
      {
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          apply mon_inv_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      refine (!(tensor_comp_id_r _ _) @ _).
      refine (_ @ tensor_id_id _ _).
      apply maponpaths_2.
      rewrite !assoc'.
      pose (unit_of_monad_enrichment EM y (M z)).
      cbn in p.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          do 2 apply maponpaths.
          apply enrichment_assoc.
        }
        rewrite !assoc.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          rewrite !assoc'.
          apply maponpaths.
          apply tensor_lassociator.
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            apply tensor_id_id.
          }
          refine (!(tensor_split' _ _) @ _).
          apply tensor_split.
        }
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      rewrite !assoc.
      etrans.
      {
        do 3 apply maponpaths_2.
        exact p.
      }
      clear p.
      pose (p := maponpaths (enriched_from_arr E) (@Monad_law1 _ M z)).
      rewrite enriched_from_arr_id in p.
      rewrite enriched_from_arr_comp in p.
      cbn in p.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_linvunitor.
        }
        rewrite !assoc'.
        apply maponpaths.
        etrans.
        {
          rewrite !assoc.
          apply maponpaths_2.
          refine (!(tensor_split _ _) @ _).
          apply tensor_comp_l_id_r.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply enrichment_assoc'.
        }
        rewrite !assoc.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply tensor_rassociator.
        }
        rewrite !assoc'.
        apply maponpaths.
        rewrite !assoc.
        apply maponpaths_2.
        refine (!_).
        apply tensor_comp_id_r.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !assoc.
        do 2 apply maponpaths_2.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply mon_linvunitor_triangle.
        }
        rewrite !assoc'.
        etrans.
        {
          apply maponpaths.
          apply mon_lassociator_rassociator.
        }
        apply id_right.
      }
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        etrans.
        {
          refine (!_).
          apply tensor_comp_id_r.
        }
        rewrite !assoc.
        apply maponpaths_2.
        exact p.
      }
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    - cbn.
      intros x y f.
      rewrite !assoc'.
      etrans.
      {
        do 2 apply maponpaths.
        exact (@η_bind _ M _ _ (η M y)).
      }
      refine (!_).
      apply enriched_from_arr_postcomp.
  Qed.

  Definition Left_Kleisli_functor_enrichment
    : functor_enrichment
        (Left_Kleisli_functor M)
        E
        Kleisli_cat_monad_enrichment.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, postcomp_arr E x (η M y)).
    - exact Left_Kleisli_functor_enrichment_laws.
  Defined.
End EnrichedKleisli.


Require Import HahnBase ZArith List Basic.

Set Implicit Arguments.
Unset Strict Implicit.

(** This file contains a soundness proof for CSL (with multiple resources)
  as presented by O'Hearn and Brookes including the data-race freedom property
  of CSL.  For simplicity, there is a slight difference regarding variable
  side-conditions: we do not allow resource-owned variables. *)

(** * Language syntax and semantics *)

(** We define the syntax and the operational semantics of the programming
language of O'Hearn and Brookes. *)

Definition var   := Z.
Definition rname := Z.
Definition stack := var -> Z.
Definition state := (stack * heap)%type.

Inductive exp :=
  | Evar  (x : var)
  | Enum  (n : Z)
  | Eplus (e1: exp) (e2: exp).

Inductive bexp :=
  | Beq  (e1: exp) (e2: exp)
  | Band (b1: bexp) (b2: bexp)
  | Bnot (b: bexp).

Inductive cmd :=
  | Cskip
  | Cassign (x: var) (e: exp)
  | Cread   (x: var) (e: exp)
  | Cwrite  (e1: exp) (e2: exp)
  | Calloc  (x: var) (e: exp)
  | Cdispose (e: exp)
  | Cseq   (c1: cmd) (c2: cmd)
  | Cpar   (c1: cmd) (c2: cmd)
  | Cif    (b: bexp) (c1: cmd) (c2: cmd)
  | Cwhile (b: bexp) (c: cmd)
  | Cresource (r: rname) (c: cmd)
  | Cwith     (r: rname) (b: bexp) (c: cmd)
  | Cinwith   (r: rname) (c: cmd).

(** Arithmetic expressions ([exp]) consist of variables, constants, and
arithmetic operations. Boolean expressions ([bexp]) consist of comparisons
between arithmetic expressions.  Commands ([cmd]) include the empty command,
variable assignments, memory reads, writes, allocations and deallocations,
sequential and parallel composition, conditionals, while loops, resource
declaration and conditional critical regions (CCRs).  The last command form
represents a partially executed CCR and does not appear in user programs.
This restriction is captured by the following definition: *)

Fixpoint user_cmd c :=
  match c with
    | Cskip         => True
    | Cassign x E   => True
    | Cread x E     => True
    | Cwrite E E'   => True
    | Calloc x E    => True
    | Cdispose E    => True
    | Cseq C1 C2    => user_cmd C1 /\ user_cmd C2
    | Cpar C1 C2    => user_cmd C1 /\ user_cmd C2
    | Cif B C1 C2   => user_cmd C1 /\ user_cmd C2
    | Cwhile B C    => user_cmd C
    | Cresource r C => user_cmd C
    | Cwith r B C   => user_cmd C
    | Cinwith r C   => False
  end.

(** The following function returns a list of locks that a command is
currently holding in some arbitrary fixed order. *)

Fixpoint locked c :=
  match c with
    | Cskip         => nil
    | Cassign x e   => nil
    | Cread x e     => nil
    | Cwrite e e'   => nil
    | Calloc x e    => nil
    | Cdispose e    => nil
    | Cseq c1 c2    => locked c1
    | Cpar c1 c2    => locked c1 ++ locked c2
    | Cif b c1 c2   => nil
    | Cwhile b c    => nil
    | Cresource r c => removeAll Z.eq_dec (locked c) r
    | Cwith r b c   => nil
    | Cinwith r c   => r :: locked c
  end.

(** The following function returns a list of locks that a command has
access to (either has acquired or may acquire in the future). *)

Fixpoint locks c :=
  match c with
    | Cskip         => nil
    | Cassign x e   => nil
    | Cread x e     => nil
    | Cwrite e e'   => nil
    | Calloc x e    => nil
    | Cdispose e    => nil
    | Cseq c1 c2    => locks c1 ++ locks c2
    | Cpar c1 c2    => locks c1 ++ locks c2
    | Cif b c1 c2   => locks c1 ++ locks c2
    | Cwhile b c    => locks c
    | Cresource r c => removeAll Z.eq_dec (locks c) r
    | Cwith r b c   => r :: locks c
    | Cinwith r c   => r :: locks c
  end.

(** ** Semantics of expressions *)

(** Denotational semantics for arithmetic and boolean expressions. *)

Fixpoint edenot e s :=
  match e with
    | Evar v      => s v
    | Enum n      => n
    | Eplus e1 e2 => (edenot e1 s + edenot e2 s)%Z
  end.

Fixpoint bdenot b s : bool :=
  match b with
    | Beq e1 e2  => if Z.eq_dec (edenot e1 s) (edenot e2 s) then true else false
    | Band b1 b2 => bdenot b1 s && bdenot b2 s
    | Bnot b     => negb (bdenot b s)
  end.

(** ** Semantics of commands *)

(** The semantics for [Cwrite e e'] is a bit odd in that if [e] is not
    allocated, then it can allocate it and do the assignment.  This is
    for illustration purposes only.  Requiring that [h (edenot e s) <>
    None] does not change the proof. *)

Inductive red: cmd -> state -> cmd -> state -> Prop :=
| red_Seq1: forall c ss, red (Cseq Cskip c) ss c ss
| red_Seq2: forall c1 ss c1' ss' c2
  (R: red c1 ss c1' ss'),
  red (Cseq c1 c2) ss (Cseq c1' c2) ss'
| red_If1: forall b c1 c2 ss
  (B: bdenot b (fst ss) = true),
  red (Cif b c1 c2) ss c1 ss
| red_If2: forall b c1 c2 ss
  (B: bdenot b (fst ss) = false),
  red (Cif b c1 c2) ss c2 ss
| red_Par1: forall c1 c2 ss c1' ss'
  (R: red c1 ss c1' ss')
  (D: disjoint (locked c1') (locked c2)),
  red (Cpar c1 c2) ss (Cpar c1' c2) ss'
| red_Par2: forall c1 c2 ss c2' ss'
  (R: red c2 ss c2' ss')
  (D: disjoint (locked c1) (locked c2')),
  red (Cpar c1 c2) ss (Cpar c1 c2') ss'
| red_Par3: forall ss, red (Cpar Cskip Cskip) ss Cskip ss
| red_Loop: forall b c ss,
  red (Cwhile b c) ss (Cif b (Cseq c (Cwhile b c)) Cskip) ss
| red_Res1: forall r c ss c' ss'
  (R: red c ss c' ss'),
  red (Cresource r c) ss (Cresource r c') ss'
| red_Res2: forall r ss, red (Cresource r Cskip) ss Cskip ss
| red_With1: forall r b c ss
  (B: bdenot b (fst ss)),
  red (Cwith r b c) ss (Cinwith r c) ss
| red_With2:  forall r c ss c' ss'
  (R: red c ss c' ss')
  (NIN: ~ In r (locked c')),
  red (Cinwith r c) ss (Cinwith r c') ss'
| red_With3: forall r ss, red (Cinwith r Cskip) ss Cskip ss
| red_Assign: forall x e ss ss' s h
   (EQ1: ss = (s, h))
   (EQ2: ss' = (upd s x (edenot e s), h)),
   red (Cassign x e) ss Cskip ss'
| red_Read: forall x e ss ss' s h v
   (EQ1: ss = (s, h))
   (RD: h (edenot e s) = Some v)
   (EQ2: ss' = (upd s x v, h)),
   red (Cread x e) ss Cskip ss'
| red_Write: forall e1 e2 ss ss' s h
   (EQ1: ss = (s, h))
   (EQ2: ss' = (s, upd h (edenot e1 s) (Some (edenot e2 s)))),
   red (Cwrite e1 e2) ss Cskip ss'
| red_Alloc: forall x e ss ss' s h v
   (EQ1: ss = (s, h))
   (NIN: h v = None)
   (EQ2: ss' = (upd s x v, upd h v (Some (edenot e s)))),
   red (Calloc x e) ss Cskip ss'
| red_Free: forall e ss ss' s h
   (EQ1: ss = (s, h))
   (EQ2: ss' = (s, upd h (edenot e s) None)),
   red (Cdispose e) ss Cskip ss'.

(** ** Abort semantics *)

(** Below, we define the sets of memory accesses and memory writes
  that a command performs in one step. These are used to define what a
  race condition is. Note that we do not count memory allocation as a
  memory access because the memory cell allocated is fresh. *)

Fixpoint accesses c s :=
  match c with
    | Cskip => nil
    | (Cassign x e)   => nil
    | (Cread x e)     => edenot e s :: nil
    | (Cwrite e e')   => edenot e s :: nil
    | (Calloc x e)    => nil
    | (Cdispose e)    => edenot e s :: nil
    | (Cseq c1 c2)    => accesses c1 s
    | (Cpar c1 c2)    => accesses c1 s ++ accesses c2 s
    | (Cif b c1 c2)   => nil
    | (Cwhile b c)    => nil
    | (Cresource r c) => accesses c s
    | (Cwith r b c)   => nil
    | (Cinwith r c)   => accesses c s
  end.

Fixpoint writes c s :=
  match c with
    | Cskip => nil
    | (Cassign x e)   => nil
    | (Cread x e)     => nil
    | (Cwrite e e')   => edenot e s :: nil
    | (Calloc x e)    => nil
    | (Cdispose e)    => edenot e s :: nil
    | (Cseq c1 c2)    => writes c1 s
    | (Cpar c1 c2)    => writes c1 s ++ writes c2 s
    | (Cif b c1 c2)   => nil
    | (Cwhile b c)    => nil
    | (Cresource r c) => writes c s
    | (Cwith r b c)   => nil
    | (Cinwith r c)   => writes c s
  end.

(** A command aborts in a given state whenever it can access
  unallocated memory or has a race condition in its first execution
  step. The soundness statement of the logic asserts that these
  transitions never occur. *)

Inductive aborts : cmd -> state -> Prop :=
| aborts_Seq : forall c1 c2 ss (A: aborts c1 ss), aborts (Cseq c1 c2) ss
| aborts_Par1: forall c1 c2 ss (A: aborts c1 ss), aborts (Cpar c1 c2) ss
| aborts_Par2: forall c1 c2 ss (A: aborts c2 ss), aborts (Cpar c1 c2) ss
| aborts_Race1: forall c1 c2 ss
    (ND: ~ disjoint (accesses c1 (fst ss)) (writes c2 (fst ss))),
    aborts (Cpar c1 c2) ss
| aborts_Race2: forall c1 c2 ss
    (ND: ~ disjoint (writes c1 (fst ss)) (accesses c2 (fst ss))),
    aborts (Cpar c1 c2) ss
| aborts_Res: forall r c ss (A: aborts c ss), aborts (Cresource r c) ss
| aborts_Atom: forall r c ss (A: aborts c ss), aborts (Cinwith r c) ss
| aborts_Read: forall x e ss
    (NIN: snd ss (edenot e (fst ss)) = None),
    aborts (Cread x e) ss
| aborts_Write: forall e1 e2 ss
    (NIN: snd ss (edenot e1 (fst ss)) = None),
    aborts (Cwrite e1 e2) ss
| aborts_Free: forall e ss
    (NIN: snd ss (edenot e (fst ss)) = None),
    aborts (Cdispose e) ss.

(** ** Well-formed commands *)

(** Well-formed commands are intuitively those that can arise from a user
command by a reduction sequence.  In particular, they can have partially
executed CCRs only at reduction positions and their partially executed CCRs
must satisfy mutual exclusion.  *)

Fixpoint wf_cmd c :=
  match c with
    | Cskip         => True
    | Cassign x e   => True
    | Cread x e     => True
    | Cwrite e e'   => True
    | Calloc x e    => True
    | Cdispose e    => True
    | Cseq c1 c2    => wf_cmd c1 /\ wf_cmd c2
    | Cpar c1 c2    => wf_cmd c1 /\ wf_cmd c2 /\ disjoint (locked c1) (locked c2)
    | Cif b c1 c2   => user_cmd c1 /\ user_cmd c2
    | Cwhile b c    => user_cmd c
    | Cresource r c => wf_cmd c
    | Cwith r b c   => user_cmd c
    | Cinwith r c   => wf_cmd c /\ ~ In r (locked c)
  end.

(** Some basic properties: all user commands are well formed;
  well-formedness is preserved under reduction; user commands cannot
  immediately release a lock (they must have acquired it first). *)

Lemma user_cmdD: forall c, user_cmd c -> wf_cmd c /\ locked c = nil.
Proof.
  by induction c; simpl; intuition;
     repeat match goal with H: _ = nil |- _ => rewrite H end.
Qed.

Lemma user_cmd_locked: forall c, user_cmd c -> locked c = nil.
Proof.
  by induction c; simpl; intuition;
     repeat match goal with H: _ = nil |- _ => rewrite H end.
Qed.
Hint Immediate user_cmd_locked.

Lemma user_cmd_wf: forall c, user_cmd c -> wf_cmd c.
Proof. pose proof user_cmdD; firstorder. Qed.
Hint Immediate user_cmd_wf.

Lemma locked_locks: forall r c, In r (locked c) -> In r (locks c).
Proof.
  induction c; simpl; rewrite ?in_app_iff, ?In_removeAll in *; intuition.
Qed.

Lemma red_wf_cmd:
  forall c ss c' ss'
    (R: red c ss c' ss')
    (WF: wf_cmd c),
    wf_cmd c'.
Proof.
  induction 1; simpl in *; intros; des; clarify; intuition.
  by rewrite (user_cmd_locked WF) in H; inv H.
Qed.

Lemma disjoint_locked :
  forall C, wf_cmd C -> disjoint_list (locked C).
Proof.
  induction C; ins; desf; auto using disjoint_list_removeAll, disjoint_list_app.
Qed.

(** ** Free variables, updated variables and substitutions *)

(** The free variables of expressions, boolean expressions, assertions,
    commands and environments are defined as expected: *)

Fixpoint fvE e :=
  match e with
    | (Evar v)      => v :: nil
    | (Enum n)      => nil
    | (Eplus e1 e2) => fvE e1 ++ fvE e2
  end.

Fixpoint fvB b :=
  match b with
    | Beq e1 e2   => fvE e1 ++ fvE e2
    | Band b1 b2  => fvB b1 ++ fvB b2
    | Bnot b      => fvB b
  end.

Fixpoint fvC c :=
  match c with
    | Cskip           => nil
    | (Cassign x e)   => x :: fvE e
    | (Cread x e)     => x :: fvE e
    | (Cwrite e e')   => fvE e ++ fvE e'
    | (Calloc x e)    => x :: fvE e
    | (Cdispose e)    => fvE e
    | (Cseq c1 c2)    => fvC c1 ++ fvC c2
    | (Cpar c1 c2)    => fvC c1 ++ fvC c2
    | (Cif b c1 c2)   => fvB b ++ fvC c1 ++ fvC c2
    | (Cwhile b c)    => fvB b ++ fvC c
    | (Cresource r c) => fvC c
    | (Cwith r b c)   => fvB b ++ fvC c
    | (Cinwith r c)   => fvC c
  end.

(** Below, we define the set of syntactically updated variables
  of a command. This set overapproximates the set of variables that
  are actually updated during the command's execution. *)

Fixpoint wrC c :=
  match c with
    | Cskip           => nil
    | (Cassign x e)   => x :: nil
    | (Cread x e)     => x :: nil
    | (Cwrite e e')   => nil
    | (Calloc x e)    => x :: nil
    | (Cdispose e)    => nil
    | (Cseq c1 c2)    => wrC c1 ++ wrC c2
    | (Cpar c1 c2)    => wrC c1 ++ wrC c2
    | (Cif b c1 c2)   => wrC c1 ++ wrC c2
    | (Cwhile b c)    => wrC c
    | (Cresource r c) => wrC c
    | (Cwith r b c)   => wrC c
    | (Cinwith r c)   => wrC c
  end.

(** We also define the operation of substituting an expression for
a variable in expressions and assertions. *)

Fixpoint subE x e e0 :=
  match e0 with
    | Evar y      => (if Z.eq_dec x y then e else Evar y)
    | Enum n      => Enum n
    | Eplus e1 e2 => Eplus (subE x e e1) (subE x e e2)
  end.

Fixpoint subB x e b :=
  match b with
    | Beq e1 e2  => Beq (subE x e e1) (subE x e e2)
    | Band b1 b2 => Band (subB x e b1) (subB x e b2)
    | Bnot b     => Bnot (subB x e b)
  end.

Lemma subE_assign:
 forall x e e' s, edenot (subE x e e') s = edenot e' (upd s x (edenot e s)).
Proof.
unfold upd; induction e'; simpl in *; intros; clarify; desf; eauto.
by rewrite IHe'1, IHe'2.
Qed.

Lemma subB_assign:
  forall x e b s, bdenot (subB x e b) s = bdenot b (upd s x (edenot e s)).
Proof.
  induction b; simpl; intros; clarify; repeat rewrite subE_assign; try congruence.
Qed.

(** Definition of two stacks agreeing on a set of variables *)

Definition agrees (X : list rname) (s s' : stack) := forall x, In x X -> s x = s' x.

Lemma agrees_union:
  forall X Y s s', agrees (X ++ Y) s s' <-> (agrees X s s' /\ agrees Y s s').
Proof.
  unfold agrees; intuition; eapply in_app_iff in H; intuition.
Qed.

Lemma agreesC: forall X x y, agrees X x y -> agrees X y x.
Proof. unfold agrees; intuition (symmetry; eauto). Qed.

Hint Immediate agreesC.

Lemma agrees_tl: forall X Y x y, agrees (X :: Y) x y -> agrees Y x y.
Proof. red; intros; eapply H; vauto. Qed.

Lemma agrees_app1: forall X Y x y, agrees (X ++ Y) x y -> agrees X x y.
Proof. red; intros; eapply H, in_app_iff; vauto. Qed.

Lemma agrees_app2: forall X Y x y, agrees (X ++ Y) x y -> agrees Y x y.
Proof. red; intros; eapply H, in_app_iff; vauto. Qed.

Hint Immediate agrees_app1 agrees_app2.

Lemma agrees_imp: forall X Y x y, agrees X x y -> (forall z, In z Y -> In z X) -> agrees Y x y.
Proof. red; intros; eapply H; eauto. Qed.

(** ** Basic properties of the semantics *)

(** The lemmas in this subsection are Propositions 1 and 2 in the paper. *)

Lemma prop1_E: forall e s s', agrees (fvE e) s s' -> edenot e s = edenot e s'.
Proof.
 induction e; simpl; intros; clarify.
 by apply H; vauto.
 by erewrite IHe1, IHe2; eauto.
Qed.

Lemma prop1_B: forall b s s', agrees (fvB b) s s' -> bdenot b s = bdenot b s'.
Proof.
  induction b; simpl; intros; clarify; try rewrite agrees_union in *; f_equal; intuition.
  by rewrite (prop1_E H0), (prop1_E H1).
Qed.

Corollary prop1_E2 :
  forall x E (NIN: ~ In x (fvE E)) s v, edenot E (upd s x v) = edenot E s.
Proof. ins; apply prop1_E; red; unfold upd; ins; desf. Qed.

Corollary prop1_B2 :
  forall x B (NIN: ~ In x (fvB B)) s v, bdenot B (upd s x v) = bdenot B s.
Proof. ins; apply prop1_B; red; unfold upd; ins; desf. Qed.

(** Properties of memory accesses: *)

Lemma writes_accesses:
  forall C s a, In a (writes C s) -> In a (accesses C s).
Proof. induction C; ins; rewrite in_app_iff in *; intuition. Qed.

Lemma accesses_agrees:
  forall C s s' (A: agrees (fvC C) s s'), accesses C s = accesses C s'.
Proof.
  induction C; ins; eauto; f_equal; eauto; eapply prop1_E; eauto.
  by red; ins; eapply A; vauto.
Qed.

Lemma writes_agrees :
  forall C s s' (A: agrees (fvC C) s s'), writes C s = writes C s'.
Proof.
  induction C; ins; eauto; f_equal; eauto using prop1_E.
Qed.

(** Proposition 2 in the paper, describing how [fvC] and [wrC]
interact with execution steps. *)

Lemma prop2:
 forall C ss C' ss' (STEP: red C ss C' ss'),
      (forall x, In x (fvC C') -> In x (fvC C))
   /\ (forall x, In x (wrC C') -> In x (wrC C))
   /\ (forall x, In x (locks C') -> In x (locks C))
   /\ (forall x, ~ In x (wrC C) -> fst ss' x = fst ss x).
Proof.
  induction 1; ins; intuition; repeat rewrite in_app_iff in *; intuition; clarify;
  unfold upd; simpl; rewrite ?In_removeAll in *; desf; eauto; exfalso; eauto.
Qed.


Require Import Ascii.
Require Import String.
Require Import FJ_tactics.
Require Import List.
Require Import Functors.
Require Import FunctionalExtensionality.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.

Section EffState.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Let DType := DType D.

   Variable V : Set -> Set.
   Context {Fun_V : Functor V}.
   Let Value := Value V.

  Variable (MT : Set -> Set).
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  (* Context {Fail_MT : FailMonad MT}. *)

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {State_M : StateM ME (list Value)}.

  Section WFValue_Sec.

  (* ============================================== *)
  (* WELL-FORMED REFERENCE VALUES                   *)
  (* ============================================== *)

    Variable TypContext : Set.
    Context {TypContextCE : ConsExtensionC TypContext}.

    (** Typing rules for unit values **)

    Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
    Context {funWFV : iFunctor WFV}.

    (* ============================================== *)
    (* WELL-FORMED MONADIC STATE VALUES               *)
    (* ============================================== *)

    (** SuperFunctor for Well-Formed Monadic Value Relation with
       Typing Environment. **)

    Class WF_EnvC (TypContext : Set) : Type :=
      {WF_Env : list Value -> TypContext -> Prop}.

    Context {TypContext_WFE : WF_EnvC TypContext}.

    Inductive WFValueM_State (A : WFValueM_i D V MT ME TypContext -> Prop) : WFValueM_i D V MT ME TypContext -> Prop :=
    | WFVM_Get : forall Sigma (k : list Value -> ME Value) T,
      (forall env, WF_Env env Sigma ->
        A (mk_WFValueM_i D V MT ME _ Sigma (k env) T)) ->
      WFValueM_State A (mk_WFValueM_i D V MT ME _ Sigma (do env <- get; k env) T)
    | WFVM_Put : forall Sigma Sigma' env k T,
      WF_Env env Sigma' -> ConsExtension Sigma' Sigma ->
      A (mk_WFValueM_i _ _ _ _ _ Sigma' k T) ->
      WFValueM_State A (mk_WFValueM_i _ _ _ _ _ Sigma (put env >> k) T).

    Definition ind_alg_WFVM_State (P : WFValueM_i D V MT ME TypContext -> Prop)
      (H_Get : forall Sigma k T,
        (forall env, WF_Env env Sigma ->
          P (mk_WFValueM_i _ _ _ _ _ Sigma (k env) T)) ->
        P (mk_WFValueM_i _ _ _ _ _ Sigma (do env <- get; k env) T))
      (H_Put : forall Sigma Sigma' env k T,
        WF_Env env Sigma' -> ConsExtension Sigma' Sigma ->
        P (mk_WFValueM_i _ _ _ _ _ Sigma' k T) ->
        P (mk_WFValueM_i _ _ _ _ _ Sigma (put env >> k) T))
      (i : WFValueM_i D V MT ME _)
      (e : WFValueM_State P i)
      :
      P i :=
      match e in WFValueM_State _ i return P i with
        | WFVM_Get Sigma k T WF_k =>
          H_Get Sigma k T WF_k
        | WFVM_Put Sigma Sigma' env k T WF_env Sub_Sig_Sig' WF_k =>
          H_Put Sigma Sigma' env k T WF_env Sub_Sig_Sig' WF_k
      end.

    Definition WFVM_State_ifmap
      (A B : WFValueM_i D V MT ME _ -> Prop)
      (i : WFValueM_i D V MT ME _)
      (f : forall i, A i -> B i)
      (WFVM_a : WFValueM_State A i)
      :
      WFValueM_State B i :=
      match WFVM_a in WFValueM_State _ i return WFValueM_State B i with
        | WFVM_Get Sigma k T WF_k =>
          WFVM_Get B Sigma k T (fun env WF_env => f _ (WF_k env WF_env))
        | WFVM_Put Sigma Sigma' env k T WF_env Sub_Sig_Sig' WF_k =>
          WFVM_Put B Sigma Sigma' env k T WF_env Sub_Sig_Sig' (f _ WF_k)
      end.

    Global Instance iFun_wfvm_State : iFunctor WFValueM_State.
      constructor 1 with (ifmap := WFVM_State_ifmap).
      (* ifmap_fusion *)
      destruct a; simpl; intros; reflexivity.
      (* ifmap_id *)
      destruct a; simpl; intros; auto;
        apply f_equal; repeat (apply functional_extensionality_dep; intros); auto.
    Defined.

    Class SigTypContextC (TypContext : Set) : Set :=
      {SigLookup : TypContext -> nat -> option DType;
       SigInsert : DType -> TypContext -> TypContext}.

    Class SigConsExtensionC (TypContext : Set)
      (ConsExt : ConsExtensionC TypContext)
      (SigTyp : SigTypContextC TypContext) : Type :=
      {
        ConsExtension_SigLookup : forall Sigma Sigma',
          ConsExtension Sigma' Sigma ->
          forall n T, SigLookup Sigma n = Some T ->
            SigLookup Sigma' n = Some T;
        ConsExtension_SigInsert : forall Sigma T,
          ConsExtension (SigInsert T Sigma) Sigma}.

    Class Sig_WF_EnvC (TypContext : Set)
      (WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop)
      (WF_Env' : WF_EnvC TypContext)
      (SigTyp : SigTypContextC TypContext) : Type :=
    {
      WF_EnvLookup : forall env Sigma T n,
        WF_Env env Sigma ->
        SigLookup Sigma n = Some T ->
        exists v, lookup env n = Some v /\
          WFValueC _ _ _ WFV Sigma v T;
      WF_EnvInsertLookup : forall env Sigma T,
        WF_Env env Sigma ->
        SigLookup (SigInsert T Sigma) (length env) = Some T;
      WF_EnvInsert : forall Sigma env v T,
        WFValueC _ _ _ WFV (SigInsert T Sigma) v T ->
        WF_Env env Sigma ->
        WF_Env (insert _ v env) (SigInsert T Sigma);
      WF_EnvReplace : forall Sigma env v T n,
        SigLookup Sigma n = Some T ->
        WFValueC _ _ _ WFV Sigma v T ->
        WF_Env env Sigma ->
        WF_Env (replace_el n v env) Sigma}.

  End WFValue_Sec.

  Section BindRule.

    Variable TypContext : Set.
    Context {TypContextCE : ConsExtensionC TypContext}.
    Context {TypContext_WFE : WF_EnvC TypContext}.

    Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
    Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext -> Prop.
    Context {Sub_WFVM_State_WFVM : Sub_iFunctor (WFValueM_State TypContext) WFVM}.

    Global Instance wfvm_bind_State' :
      iPAlgebra wfvm_bind_Name (wfvm_bind_P D V MT ME _ WFV WFVM) (WFValueM_State _).
    Proof.
      constructor; unfold iAlgebra; intros.
      apply ind_alg_WFVM_State with
        (TypContextCE := TypContextCE) (TypContext_WFE := TypContext_WFE); try eassumption;
        unfold wfvm_bind_P; simpl; intros.
        (* get *)
      apply (inject_i (subGF := Sub_WFVM_State_WFVM)).
      rewrite <- associativity.
      constructor.
      intros.
      apply H0; auto.
        (* put *)
      apply (inject_i (subGF := Sub_WFVM_State_WFVM)).
      unfold wbind.
      repeat rewrite <- associativity.
      constructor 2 with (Sigma' := Sigma'); auto.
      apply H2; auto.
      intros; eapply WFVM_ke_kt; eauto; eapply ConsExtension_trans; eauto.
    Qed.

  End BindRule.

End EffState.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^216 - 2^108 - 1
Base: 21.6
***)

Definition curve : CurveParameters :=
  {|
    sz := 10%nat;
    base := 21 + 3/5;
    bitwidth := 32;
    s := 2^216;
    c := [(1, 1); (2^108, 1)];
    carry_chains := Some [[4; 9]; [5; 0; 6; 1; 7; 2; 8; 3; 9; 4]; [5; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Section process.
  Context {input : Type}.
  Context {world : Type}.

  Definition action := world -> world.

  CoInductive process :=
  | Step : (input -> action * process) -> process.

  Definition step := input -> action * process.
End process.

Arguments action : clear implicits.
Arguments process : clear implicits.
Arguments step : clear implicits.

Section stackProcess.

  Context {input : Type}.
  Context {world : Type}.

  Inductive stackWorld :=
  | stackDone : stackWorld
  | stackPush : input -> action stackWorld
  | stackLift : action world -> action stackWorld.

  Definition stackProcess := process input stackWorld.
  Definition stackStep := step input stackWorld.

  Definition stackTransition (m : input) (pf : stackStep) :=
    (fst (pf m) stackDone, snd (pf m)).

  Inductive emptiesStack : stackWorld * stackProcess -> stackProcess -> Prop :=
  | emptiesStackDone p : emptiesStack (stackDone, p) p
  | emptiesStackPush m sw pf p2 p3 :
      emptiesStack (stackTransition m pf) p2 ->
      emptiesStack (sw, p2) p3 ->
      emptiesStack (stackPush m sw, Step pf) p3
  | emptiesStackLift a sw p p2 :
      emptiesStack (sw, p) p2 ->
      emptiesStack (stackLift a sw, p) p2.

  CoInductive emptiesStackForever : stackProcess -> Prop :=
  | emptiesStackStep pf:
      (forall (i : input), exists p',
         emptiesStack (stackTransition i pf) p' /\
         emptiesStackForever p') ->
      emptiesStackForever (Step pf).

  Inductive stepStackProcessTerminates : stackWorld * stackProcess -> Prop :=
  | stepStackProcessDone p : stepStackProcessTerminates (stackDone, p)
  | stepStackProcessPush m sw pf p2 :
      stepStackProcessTerminates (stackTransition m pf) ->
      emptiesStack (stackTransition m pf) p2 ->
      stepStackProcessTerminates (sw, p2) ->
      stepStackProcessTerminates (stackPush m sw, Step pf)
  | stepStackProcessLift a sw p p2 :
      stepStackProcessTerminates (sw, p) ->
      emptiesStack (sw, p) p2 ->
      stepStackProcessTerminates (stackLift a sw, p).

  Theorem mkStepStackProcessTerminates swp p' (e : emptiesStack swp p') : stepStackProcessTerminates swp.
    induction e; econstructor; eauto.
  Qed.

  Fixpoint stepStackProcess swp (h : stepStackProcessTerminates swp) :
    action world * sig (unique (emptiesStack swp)).
  destruct swp as [[| m sw' | a sw'] p].
  {
    split.
    { exact (@id world). }
    {
      exists p.
      split.
      { constructor. }
      {
        inversion 1.
        reflexivity.
      }
    }
  }
  {
    destruct p as [pf].
    pose (sap1 := pf m).
    pose (sw := fst sap1 stackDone).
    assert (stepStackProcessTerminates (sw, snd sap1)) as e1 by (inversion h; assumption).
    destruct (stepStackProcess (sw, snd sap1) e1) as [a2 [p2 [e2 u2]]].
    assert (stepStackProcessTerminates (sw', p2)) as e3.
    {
      inversion h as [| ? ? ? p' |].
      rewrite (u2 p'); assumption.
    }
    destruct (stepStackProcess (sw', p2) e3) as [a3 [p3 [e4 u4]]].
    split.
    { exact (fun w => a2 (a3 w)). }
    {
      exists p3.
      split.
      { econstructor; eassumption. }
      {
        intros p3' e5.
        apply u4.
        inversion e5 as [| ? ? ? p' |].
        rewrite (u2 p'); assumption.
      }
    }
  }
  {
    assert (stepStackProcessTerminates (sw', p)) as e1 by (inversion h; assumption).
    destruct (stepStackProcess (sw', p) e1) as [a2 [p2 [e2 u2]]].
    split.
    { exact (fun w => a (a2 w)). }
    {
      exists p2.
      split.
      { constructor. assumption. }
      {
        intros p2' h1.
        apply u2.
        inversion h1.
        assumption.
      }
    }
  }
  Defined.

  CoFixpoint runStackProcess (p : stackProcess) (h : emptiesStackForever p) : process input world.
  Proof.
    refine (Step (fun i =>
                    match p as p return emptiesStackForever p -> _ with
                      | Step pf => fun h' => let sap1 := pf i in
                                             let sw := fst sap1 stackDone in
                                             let stepped := stepStackProcess (sw, snd sap1) _ in
                                             (fst stepped, runStackProcess (proj1_sig (snd stepped)) _)
                    end h));
    clear runStackProcess p h.
    {
      inversion h' as [? h1]; subst.
      destruct (h1 i) as [? [? ?]]; clear h1.
      eapply mkStepStackProcessTerminates.
      eassumption.
    }
    {
      inversion h' as [? h1]; subst.
      destruct (h1 i) as [? [? ?]].
      erewrite (proj2 (proj2_sig (snd stepped))); eassumption.
    }
  Defined.

End stackProcess.

Arguments stackWorld : clear implicits.
Arguments stackProcess : clear implicits.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^243 - 9
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 32;
    bitwidth := 32;
    s := 2^243;
    c := [(1, 9)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


From Undecidability.TM Require Import ProgrammingTools.
From Undecidability Require Import CaseNat CaseList List.App.

From Undecidability.L.Complexity Require Import UpToCNary.

Local Arguments skipn { A } !n !l.
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

Local Arguments Encode_list : simpl never.
Local Arguments Encode_nat : simpl never.

Section bla.
  Import FinTypes.
  (* Most likely: we need to make Z__case return domains... *)
  (*Polymorphic Lemma leUpToC_finCases_nary domain (Y:FinTypesDef.finType) Z__case (cases : forall (y:Y), Z__case y -> Rtuple domain) (f : Rarrow domain nat) (F : Rtuple domain -> nat) :
    (forall x, exists y (z : Z__case y), cases y z = x)
    -> (forall y, (fun z => App f (cases y z)) <=c (fun z => F (cases y z)))
    -> Uncurry f <=c F.
  Proof.
    prove_nary leUpToC_finCases.
  Qed.*)

  Polymorphic Lemma leUpToC_clean domain (f F: Rtuple domain -> nat):
    Fun' f <=c Fun' F
    -> f <=c F.
  Proof.
    prove_nary id.
  Qed.
End bla.

Module ConcatRepeat.
  Section concatRepeat.

    Variable sig sigX : finType.
    Variable (X : Type) (cX : codable sigX X).
    Variable (retr1 : Retract (sigList sigX) sig) (retr2 : Retract sigNat sig).

    (*
    Tapes:
  t0: list to repeat
  t1: n
  t2: res
     *)

    Definition Rel__step : pRel sig^+ (option unit) 3 :=
      fun tin '(yout,tout) =>
        forall (cs : list X) (n:nat) ( xs : list X) ,
          tin[@Fin0] ≃ cs ->
          tin[@Fin1] ≃ n ->
          tin[@Fin2] ≃ xs ->
          match yout, n with
          | (Some tt), 0 => (* break *)
            tout[@Fin0] ≃ cs /\
            isVoid tout[@Fin1] /\
            tout[@Fin2] ≃ xs
          | None, S n => (* continue *)
            tout[@Fin0] ≃ cs /\
            tout[@Fin1] ≃ n /\
            tout[@Fin2] ≃ cs++xs
          | _, _ => False
          end.

    Definition M__step : pTM sig^+ (option unit) 3 :=
      If (LiftTapes (ChangeAlphabet CaseNat _) [|Fin1|])
         (Return (LiftTapes (ChangeAlphabet (App' _) _) [|Fin0; Fin2|]) None)
         (Return (LiftTapes (Reset _) [|Fin1|]) (Some tt)).

    Lemma Realise__step : M__step ⊨ Rel__step .
    Proof.
      eapply Realise_monotone.
      {unfold M__step. TM_Correct. now apply App'_Realise. }
      intros t (y,t') H. cbn.
      intros cs n xs Hcs Hn Hxs. cbn in H.
      destruct H as [H|H].
      -destruct H as (?&(HCase&HCaseRem)&->&tt1&HApp&HAppRem). clear tt1.
       modpon HCase. destruct n. easy. TMSimp. modpon HApp.
       repeat eapply conj. 1-3:now contains_ext.
      -destruct H as (?&(HCase&HCaseRem)&->&tt1&HReset&HResetRem). clear tt1.
       modpon HCase. destruct n. 2:easy. TMSimp. modpon HReset.
       repeat eapply conj. 1,3:now contains_ext. now isVoid_mono.
    Qed.

    Definition Rel : pRel sig^+ unit 3 :=
      ignoreParam (
          fun tin tout =>
            forall (cs : list X) (n:nat) ( xs : list X) ,
              tin[@Fin0] ≃ cs ->
              tin[@Fin1] ≃ n ->
              tin[@Fin2] ≃ xs ->
              tout[@Fin0] ≃ cs /\
              isVoid tout[@Fin1] /\
              tout[@Fin2] ≃ concat (repeat cs n)++xs
        ).

    Definition M : pTM sig^+ unit 3 := While M__step.

    Lemma Realise : M ⊨ Rel .
    Proof.
      eapply Realise_monotone.
      {unfold M. TM_Correct. apply Realise__step. }
      eapply WhileInduction;intros;hnf;intros cs n xs Hcs Hn Hxs.
      -hnf in HLastStep. modpon HLastStep. destruct yout,n. 2:easy.
       TMSimp. easy.
      -hnf in HStar. modpon HStar. destruct n. easy. TMSimp.
       modpon HLastStep. replace (cs ++ concat (repeat cs n)) with (concat (repeat cs (n+1))).
       +rewrite repeat_add_app, concat_app;cbn;autorewrite with list;cbn. easy.
       +rewrite Nat.add_comm. reflexivity.
    Qed.

    Definition Ter__step time : tRel sig^+ 3 :=
      fun tin k => exists (cs : list X) (n:nat) ( xs : list X) ,
          tin[@Fin0] ≃ cs /\ tin[@Fin1] ≃ n /\ tin[@Fin2] ≃ xs /\ time (n,size cs) <= k.

    Lemma _Terminates__step : { time : UpToC (fun '(n,l) => (if n =? 0 then 0 else l) + 1)
                                     & projT1 M__step ↓ Ter__step time}.
    Proof.
      eexists_UpToC time. [time]:refine (fun '(n,l) => if n =? 0 then _ else _).
      eapply TerminatesIn_monotone.
      { unfold M__step. TM_Correct. now apply App'_Terminates with (cX:=cX). }
      {
        intros tin k (cs&n&xs&Hcs&Hn&Hxs&Hk). cbn. eexists. eexists (if n =? 0 then _ else _).
        infTer 3. rewrite <- Hk.
        2:{ clear Hk time.
            intros tout b (HCaseNat&HRem). modpon HCaseNat.
            destruct b. all:destruct (Nat.eqb_spec n 0) as [Hn0|Hn0]. all:try now (destruct n;exfalso).
            2:{rewrite Hn0 in HCaseNat. exists 0. split. 2:reflexivity. simpl_surject. TMSimp. contains_ext. }
            unfold App'_T;cbn. eexists cs, xs. TMSimp. split. 2:split. 3:reflexivity.
            all:simpl_surject. all:contains_ext.
        }
        unfold CaseNat_steps,Reset_steps.
        unfold time.
        destruct Nat.eqb. reflexivity.
        rewrite (correct__leUpToC (App'_steps_nice _)).
        set (size cs) as l. reflexivity.
      }
      unfold time.
      apply leUpToC_finCases with
          (cases := fun (b:bool) => match b return (if b then nat*nat else nat) -> _ with
                                false => fun l => (0,l)
                              | true => fun '(n,l) => (S n, l)
                              end).
      { intros [[ |n] l]. now (exists false; eauto). now (exists true;eexists (_,_);eauto). }
      intros []. nary apply leUpToC_clean.
      2:{ cbn [fst snd]. rewrite Nat.eqb_refl. smpl_upToC_solve. }
      cbn [Nat.eqb]. smpl_upToC_solve.
    Qed.

    Definition Terminates__step := projT2 _Terminates__step.

    Definition Ter time : tRel sig^+ 3 :=
      fun tin k => exists (cs : list X) (n:nat) ( xs : list X) ,
          tin[@Fin0] ≃ cs /\ tin[@Fin1] ≃ n /\ tin[@Fin2] ≃ xs /\ time (size cs,n) <= k.

    Lemma _Terminates : {time : UpToC (fun '(l,n) => n * l + 1)
                                & projT1 M ↓ Ter time }.
    Proof.
      evar (c1 : nat). evar (c2 : nat).
      exists_UpToC (fun '(l,n) => n * l * c1 + c2). unfold M.
      eapply TerminatesIn_monotone.
      -TM_Correct. now apply Realise__step. now apply Terminates__step.
      -apply WhileCoInduction. unfold Ter.
       intros tin k (cs&n&xs&Hcs&Hn&Hxs&Hk).
       eexists. unfold Ter__step. split.
       { exists cs,n,xs. repeat simple apply conj. 1-3:eassumption. rewrite UpToC_le. reflexivity. }
       unfold Rel__step. intros ymid tmid Hstep. modpon Hstep.
       destruct ymid as [[]| ],n. all:try now exfalso.
       +rewrite Nat.eqb_refl. rewrite <- Hk, Nat.mul_0_l, Nat.mul_1_r,!Nat.add_0_l. unfold c2. reflexivity.
       +TMSimp.
        eexists. split.
        *repeat simple eapply ex_intro. repeat simple apply conj. 1-3:contains_ext.  reflexivity.
        * rewrite <- Hk. ring_simplify. set (c' := c__leUpToC).
          assert (size cs > 0). 1:{rewrite Encode_list_hasSize. destruct cs;cbn;nia.  }
          replace c1 with (2 + 2*c').  2:now unfold c',c1. nia.
      - smpl_upToC_solve.
    Qed.

    Definition Terminates := projT2 _Terminates.

  End concatRepeat.

End ConcatRepeat.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section OneLeaderLogPerTerm.

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

  Definition one_leaderLog_per_term (net : network) : Prop :=
    forall h h' t ll ll',
      In (t, ll) (leaderLogs (fst (nwState net h))) ->
      In (t, ll') (leaderLogs (fst (nwState net h'))) ->
      h = h' /\ ll = ll'.

  (* convenience *)
  Definition one_leaderLog_per_term_log (net : network) : Prop :=
    forall h h' t ll ll',
      In (t, ll) (leaderLogs (fst (nwState net h))) ->
      In (t, ll') (leaderLogs (fst (nwState net h'))) ->
      ll = ll'.

  (* convenience *)
  Definition one_leaderLog_per_term_host (net : network) : Prop :=
    forall h h' t ll ll',
      In (t, ll) (leaderLogs (fst (nwState net h))) ->
      In (t, ll') (leaderLogs (fst (nwState net h'))) ->
      h = h'.

  Class one_leaderLog_per_term_interface : Prop :=
    {
      one_leaderLog_per_term_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          one_leaderLog_per_term net;
      one_leaderLog_per_term_log_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          one_leaderLog_per_term_log net;
      one_leaderLog_per_term_host_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          one_leaderLog_per_term_host net
    }.
End OneLeaderLogPerTerm.


Require Import Coq.Program.Basics.
Require Import Coq.Strings.String.
Require Import Setoid.
Require Import ZArith.
Require Import Coq.Program.Equality.
Require Import Lia.
Require Import Ascii.

Require Import FinProof.All.

Require Import UMLang.All.
Require Import UMLang.LocalClassGenerator.ClassGenerator.
Require Import UMLang.GlobalClassGenerator.ClassGenerator.

Require Import UrsusStdLib.Solidity.All.
Require Import UrsusStdLib.Solidity.unitsNotations.
Require Import UrsusTVM.Solidity.All.

Import UrsusNotations.
Local Open Scope xlist_scope.
Local Open Scope record.
Local Open Scope program_scope.
Local Open Scope glist_scope.
Local Open Scope ursus_scope.
Local Open Scope usolidity_scope.

From elpi Require Import elpi.

Local Open Scope struct_scope.
Local Open Scope N_scope.
Local Open Scope string_scope.
Require Import SetcodeMultisig.

Require Import UMLang.ExecGenerator.
Require Import UMLang.ExecGen.GenFlags.
Require Import UMLang.ExecGen.ExecGenDefs.
Require Import FinProof.CommonInstances.

Require Import CommonQCEnvironment.
Require Import SetcodeMultisig_LocalState.
Require Import CommonForProps.

Definition STS_1 l (dest :  address) (value :  uint128) (bounce :  boolean) (flags :  uint8) (payload :  cell_) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  correctState l ->
  isError (eval_state (Uinterpreter (sendTransaction rec def dest value bounce flags payload)) l) = false ->
  length_ custodians = 1.

Definition STS_2 l (dest :  address) (value :  uint128) (bounce :  boolean) (flags :  uint8) (payload :  cell_) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  correctState l ->
  isError (eval_state (Uinterpreter (sendTransaction rec def dest value bounce flags payload)) l) = false ->
  hmapIsMember msgPubkey custodians = true.

Definition STS_3_1 l (dest :  address) (value :  uint128) (bounce :  boolean) (flags :  uint8) (payload :  cell_) : Prop :=
  let custodians := toValue (eval_state (sRReader (m_custodians_right rec def) ) l) in
  let msgPubkey := toValue (eval_state (sRReader || msg->pubkey() ||) l) in
  correctState l ->
  length_ custodians = 1 ->
  hmapIsMember msgPubkey custodians = true ->
  isError (eval_state (Uinterpreter (sendTransaction rec def dest value bounce flags payload)) l) = false.

Definition equalExceptMessagesLocalBalanceAccepted (l l': LedgerLRecord rec) :=
  ledgerEqb {$$ {$$ {$$ l with Ledger_VMState :=
  {$$ {$$
   getPruvendoRecord Ledger_VMState l
   with VMState_ι_accepted := true $$} : @field_type (LedgerLRecord rec) _ _ Ledger_VMState with
   VMState_ι_balance := getPruvendoRecord VMState_ι_balance
     (getPruvendoRecord Ledger_VMState l')

 $$}
$$} with Ledger_LocalState := getPruvendoRecord Ledger_LocalState l'
$$} with Ledger_MessagesState := getPruvendoRecord Ledger_MessagesState l'
$$} l'.

Definition STS_3_2 (l: LedgerLRecord rec) (dest :  address) (value :  uint128) (bounce :  boolean) (flags :  uint8) (payload :  cell_) : Prop :=
  let l' := exec_state (Uinterpreter (sendTransaction rec def dest value bounce flags payload)) l in
  let FLAG_IGNORE_ERRORS := uint2N (toValue (eval_state (sRReader (FLAG_IGNORE_ERRORS_right rec def) ) l)) in
  let flags' := Build_XUBInteger (N.lor (uint2N flags) FLAG_IGNORE_ERRORS) in
  let mes := (EmptyMessage IDefault (value, (bounce, (flags', (payload, default))))) in
  let messageQueueDefault := (toValue (eval_state (sRReader (ULtoRValue ( IDefault_left rec def ))) l')) in
  correctState l ->
  isError (eval_state (Uinterpreter (sendTransaction rec def dest value bounce flags payload)) l) = false ->
  isOnlyMessage messageQueueDefault = true /\
  isMessageSent mes dest 0 messageQueueDefault = true /\
  equalExceptMessagesLocalBalanceAccepted l l' = true.


Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.RelationPairs_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ShallowEmbedded.PredicatePropositionalLogic.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.
Require Import Logic.SeparationLogic.Sound.Sound_Flat.

Instance Pred_sL (A: Type) {J: Join A}: SeparationLanguage (Pred_L A) :=
  Build_SeparationLanguage (Pred_L A) WeakSemantics.sepcon WeakSemantics.wand.

Instance Pred_s'L (A: Type) {J: Join A}: SeparationEmpLanguage (Pred_L A) :=
  Build_SeparationEmpLanguage (Pred_L A) (Pred_sL A) (@WeakSemantics.emp _ eq J).

Instance Pred_fsSM (A: Type) {J: Join A}: @FlatSemantics.SeparatingSemantics (Pred_L A) (Pred_sL A) (Build_Model A) (unit_kMD _) tt eq J (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_feSM (A: Type) {J: Join A}: @FlatSemantics.EmpSemantics (Pred_L A) (Pred_sL A) (Pred_s'L A) (Build_Model A) (unit_kMD _) tt eq J (Pred_SM A).
Proof.
  apply Same_set_refl.
Qed.

Instance Pred_sGamma (A: Type) {J: Join A} {SA: SeparationAlgebra A}: SeparationLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_sepcon_comm (Pred_L A) _ _ (Build_Model A) (unit_kMD _) tt eq J SA (Pred_SM A) (Pred_kminSM A) (Pred_fsSM A) x y).
  + intros x y.
    exact (@sound_sepcon_assoc (Pred_L A) _ _ _ (Build_Model A) (unit_kMD _) tt eq J SA (Pred_SM A) (Pred_kminSM A) (Pred_kpSM A) (Pred_fsSM A) x y).
  + intros x y z.
    exact (@sound_wand_sepcon_adjoint (Pred_L A) _ _ (Build_Model A) (unit_kMD _) tt eq (eq_preorder _) J (Pred_SM A) (Pred_kminSM A) (Pred_fsSM A) x y z).
Qed.

Instance Pred_gcsGamma (A: Type) {J: Join A} {SA: SeparationAlgebra A} {incrSA: @IncreasingSeparationAlgebra A eq J}: GarbageCollectSeparationLogic (Pred_L A) (Pred_Gamma A).
Proof.
  intros.
  constructor.
  intros x y.
  exact (@sound_sepcon_elim1 (Pred_L A) _ _ (Build_Model A) (unit_kMD _) tt eq J SA (Pred_SM A) (Pred_kiSM A) (Pred_kminSM A) (Pred_fsSM A) incrSA x y).
Qed.

Instance Pred_EmpsGamma (A: Type) {J: Join A} {SA: SeparationAlgebra A} {USA: @UnitalSeparationAlgebra A eq J}: EmpSeparationLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  intros x.
  exact (@sound_sepcon_emp (Pred_L A) _ _ _ (Build_Model A) (unit_kMD _) tt eq J SA(Pred_SM A) (Pred_kiSM A) (Pred_kminSM A) (Pred_kpSM A) (Pred_fsSM A) _ (Pred_feSM A) USA x).
Qed.