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

 The bicategory of monads and lax morphisms

 We define the bicategory of monads and lax morphisms.

 Note: this is a different bicategory from the one defined in Monads.v.
 The bicategory defined in that file has 1-cells that preserve the unit
 and multiplication up to invertible 2-cell. The formal theory of monads
 as described by Street, makes use of the bicategory defined in this
 file.

 Contents
 1. The bicategory
 2. The univalence
 3. Projections and constructions
 4. Invertible 2-cells
 5. Equivalences of monads
 6. Underlying pseudofunctor

 ***********************************************************************)
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.Univalence.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Prod.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Sigma.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.EndoMap.

Local Open Scope cat.

Section Monad.
  Context (B : bicat).

  (**
   1. The bicategory
   *)
  Definition disp_add_unit_cat_ob_mor
    : disp_cat_ob_mor (end_bicat B).
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ mx, id₁ _ ==> pr2 mx).
    - exact (λ mx my ηx ηy f,
             linvunitor _ • (ηx ▹ (pr1 f))
             =
             rinvunitor _ • (pr1 f ◃ ηy) • pr2 f).
  Defined.

  Definition disp_add_unit_cat_id_comp
    : disp_cat_id_comp _ disp_add_unit_cat_ob_mor.
  Proof.
    refine (_ ,, _).
    - intros mx ηx ; cbn in *.
      rewrite !vassocl.
      rewrite lunitor_V_id_is_left_unit_V_id.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      rewrite lunitor_runitor_identity.
      rewrite !vassocr.
      rewrite runitor_rinvunitor.
      rewrite id2_left.
      apply idpath.
    - intros mx my mz f g ηx ηy ηz ηf ηg ; cbn in *.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      rewrite <- rwhisker_rwhisker_alt.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_vcomp.
      rewrite ηf.
      rewrite <- !rwhisker_vcomp.
      apply maponpaths_2.
      rewrite <- rinvunitor_triangle.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite <- ηg.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lwhisker_hcomp.
      rewrite triangle_l_inv.
      rewrite <- rwhisker_hcomp.
      apply idpath.
  Qed.

  Definition disp_add_unit_cat_data
    : disp_cat_data (end_bicat B).
  Proof.
    simple refine (_ ,, _).
    - exact disp_add_unit_cat_ob_mor.
    - exact disp_add_unit_cat_id_comp.
  Defined.

  Definition disp_add_unit
    : disp_bicat (end_bicat B).
  Proof.
    use disp_cell_unit_bicat.
    exact disp_add_unit_cat_data.
  Defined.

  Definition disp_univalent_2_1_disp_add_unit
    : disp_univalent_2_1 disp_add_unit.
  Proof.
    use disp_cell_unit_bicat_univalent_2_1.
    intros.
    apply cellset_property.
  Qed.

  Definition disp_univalent_2_0_disp_add_unit
             (HB : is_univalent_2_1 B)
    : disp_univalent_2_0 disp_add_unit.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - use total_is_univalent_2_1.
      + exact HB.
      + apply disp_univalent_2_1_disp_end.
    - intros ; apply cellset_property.
    - intro ; apply cellset_property.
    - intros ex ef eg pq.
      pose (p := maponpaths (λ z, runitor _ • z • runitor _) (pr1 pq)).
      cbn in p.
      rewrite lunitor_V_id_is_left_unit_V_id in p.
      rewrite !vassocr in p.
      rewrite !runitor_rinvunitor in p.
      rewrite !id2_left in p.
      rewrite !vassocl in p.
      rewrite rinvunitor_runitor in p.
      rewrite id2_right in p.
      rewrite vcomp_lunitor, vcomp_runitor in p.
      rewrite runitor_lunitor_identity in p.
      pose (q := maponpaths (λ z, linvunitor _ • z) p).
      cbn in q.
      rewrite !vassocr in q.
      rewrite !linvunitor_lunitor in q.
      rewrite !id2_left in q.
      exact q.
  Qed.

  Definition disp_univalent_2_disp_add_unit
             (HB : is_univalent_2_1 B)
    : disp_univalent_2 disp_add_unit.
  Proof.
    split.
    - apply disp_univalent_2_0_disp_add_unit.
      exact HB.
    - apply disp_univalent_2_1_disp_add_unit.
  Qed.

  Definition disp_add_mu_cat_ob_mor
    : disp_cat_ob_mor (end_bicat B).
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ mx, pr2 mx · pr2 mx ==> pr2 mx).
    - exact (λ mx my μx μy f,
             lassociator _ _ _
             • (pr2 f ▹ _)
             • rassociator _ _ _
             • (_ ◃ pr2 f)
             • lassociator _ _ _
             • (μx ▹ _)
             =
             (_ ◃ μy)
             • pr2 f).
  Defined.

  Definition disp_add_mu_cat_id_comp
    : disp_cat_id_comp _ disp_add_mu_cat_ob_mor.
  Proof.
    refine (_ ,, _).
    - intros mx μx ; cbn in *.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- rinvunitor_triangle.
      apply maponpaths_2.
      refine (_ @ id2_left _).
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite lunitor_lwhisker.
      rewrite rwhisker_vcomp.
      rewrite rinvunitor_runitor.
      rewrite id2_rwhisker.
      apply idpath.
    - intros mx my mz mf mg μx μy μz μf μg ; cbn in *.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      rewrite !vassocl in μf.
      rewrite !vassocl in μg.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite <- μg.
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocl.
        apply idpath.
      }
      clear μg.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      etrans.
      {
        rewrite !vassocr.
        rewrite rassociator_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite <- μf.
        rewrite <- !rwhisker_vcomp.
        apply idpath.
      }
      clear μf.
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lassociator_lassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocr.
      apply maponpaths_2.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite <- rassociator_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      apply rassociator_rassociator.
  Qed.

  Definition disp_add_mu_cat_data
    : disp_cat_data (end_bicat B).
  Proof.
    simple refine (_ ,, _).
    - exact disp_add_mu_cat_ob_mor.
    - exact disp_add_mu_cat_id_comp.
  Defined.

  Definition disp_add_mu
    : disp_bicat (end_bicat B).
  Proof.
    use disp_cell_unit_bicat.
    exact disp_add_mu_cat_data.
  Defined.

  Definition disp_univalent_2_1_disp_add_mu
    : disp_univalent_2_1 disp_add_mu.
  Proof.
    use disp_cell_unit_bicat_univalent_2_1.
    intros.
    apply cellset_property.
  Qed.

  Definition disp_univalent_2_0_disp_add_mu
             (HB : is_univalent_2_1 B)
    : disp_univalent_2_0 disp_add_mu.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - use total_is_univalent_2_1.
      + exact HB.
      + apply disp_univalent_2_1_disp_end.
    - intros ; apply cellset_property.
    - intro ; apply cellset_property.
    - intros ex ef eg pq.
      pose (p := pr1 pq).
      cbn in p.
      rewrite <- !lwhisker_vcomp, <- !rwhisker_vcomp in p.
      rewrite !vassocl in p.
      use (vcomp_lcancel (lunitor _)) ; [ is_iso | ].
      rewrite <- !vcomp_lunitor.
      use (vcomp_rcancel (rinvunitor _)) ; [ is_iso | ].
      rewrite !vassocl.
      refine (_ @ p).
      rewrite !vassocr.
      rewrite lunitor_triangle.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_r_inv.
      rewrite <- lwhisker_hcomp.
      rewrite lwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite rinvunitor_triangle.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      apply idpath.
  Qed.

  Definition disp_univalent_2_disp_add_mu
             (HB : is_univalent_2_1 B)
    : disp_univalent_2 disp_add_mu.
  Proof.
    split.
    - apply disp_univalent_2_0_disp_add_mu.
      exact HB.
    - apply disp_univalent_2_1_disp_add_mu.
  Qed.

  Definition disp_mnd_data
    : disp_bicat B
    := sigma_bicat
         B
         _
         (disp_dirprod_bicat disp_add_unit disp_add_mu).

  Definition disp_2cells_isaprop_disp_mnd_data
    : disp_2cells_isaprop disp_mnd_data.
  Proof.
    use disp_2cells_isaprop_sigma.
    - apply disp_2cells_isaprop_end_bicat.
    - use disp_2cells_isaprop_prod ; apply disp_2cells_isaprop_cell_unit_bicat.
  Qed.

  Definition disp_locally_sym_disp_mnd_data
    : disp_locally_sym disp_mnd_data.
  Proof.
    intros x y f g τ mx my mf mg mτ.
    simple refine ((_ ,, (tt ,, tt))) ; cbn.
    pose (p := pr1 mτ) ; cbn in p.
    use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
    rewrite !vassocl.
    use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
    exact (!p).
  Qed.

  Definition disp_locally_groupoid_disp_mnd_data
    : disp_locally_groupoid disp_mnd_data.
  Proof.
    use make_disp_locally_groupoid.
    - exact disp_locally_sym_disp_mnd_data.
    - apply disp_2cells_isaprop_disp_mnd_data.
  Defined.

  Definition disp_univalent_2_1_disp_mnd_data
    : disp_univalent_2_1 disp_mnd_data.
  Proof.
    use sigma_disp_univalent_2_1_with_props.
    - apply disp_2cells_isaprop_end_bicat.
    - use disp_2cells_isaprop_prod.
      + apply disp_2cells_isaprop_cell_unit_bicat.
      + apply disp_2cells_isaprop_cell_unit_bicat.
    - apply disp_univalent_2_1_disp_end.
    - use is_univalent_2_1_dirprod_bicat.
      + apply disp_univalent_2_1_disp_add_unit.
      + apply disp_univalent_2_1_disp_add_mu.
  Defined.

  Definition disp_univalent_2_0_disp_mnd_data
             (HB : is_univalent_2 B)
    : disp_univalent_2_0 disp_mnd_data.
  Proof.
    use sigma_disp_univalent_2_0_with_props.
    - exact HB.
    - apply disp_2cells_isaprop_end_bicat.
    - use disp_2cells_isaprop_prod.
      + apply disp_2cells_isaprop_cell_unit_bicat.
      + apply disp_2cells_isaprop_cell_unit_bicat.
    - apply disp_univalent_2_1_disp_end.
    - use is_univalent_2_1_dirprod_bicat.
      + apply disp_univalent_2_1_disp_add_unit.
      + apply disp_univalent_2_1_disp_add_mu.
    - apply disp_locally_groupoid_end_bicat.
    - use disp_locally_groupoid_prod.
      + apply disp_locally_groupoid_cell_unit_bicat.
      + apply disp_locally_groupoid_cell_unit_bicat.
    - apply disp_univalent_2_0_disp_end.
      exact (pr2 HB).
    - use is_univalent_2_0_dirprod_bicat.
      + use total_is_univalent_2_1.
        * exact (pr2 HB).
        * apply disp_univalent_2_1_disp_end.
      + apply disp_univalent_2_disp_add_unit.
        exact (pr2 HB).
      + apply disp_univalent_2_disp_add_mu.
        exact (pr2 HB).
  Defined.

  Definition disp_univalent_2_disp_mnd_data
             (HB : is_univalent_2 B)
    : disp_univalent_2 disp_mnd_data.
  Proof.
    split.
    - apply disp_univalent_2_0_disp_mnd_data.
      exact HB.
    - apply disp_univalent_2_1_disp_mnd_data.
  Defined.

  Definition mnd_data
    : bicat
    := total_bicat disp_mnd_data.

  Definition is_mnd
             (m : mnd_data)
    : UU
    := let X := pr1 m in
       let f := pr12 m in
       let η := pr122 m in
       let μ := pr222 m in
       (linvunitor f • (η ▹ f) • μ = id2 f)
       ×
       (rinvunitor f • (f ◃ η) • μ = id2 f)
       ×
       (rassociator _ _ _ • (f ◃ μ) • μ
        =
        (μ ▹ f) • μ).

  Definition isaprop_is_mnd
             (m : mnd_data)
    : isaprop (is_mnd m).
  Proof.
    repeat (apply isapropdirprod) ; apply cellset_property.
  Qed.

  Definition disp_mnd
    : disp_bicat B
    := sigma_bicat
         B
         _
         (disp_fullsubbicat _ is_mnd).

  Definition disp_2cells_isaprop_disp_mnd
    : disp_2cells_isaprop disp_mnd.
  Proof.
    use disp_2cells_isaprop_sigma.
    - apply disp_2cells_isaprop_disp_mnd_data.
    - apply disp_2cells_isaprop_fullsubbicat.
  Qed.

  Definition disp_locally_sym_disp_mnd
    : disp_locally_sym disp_mnd.
  Proof.
    intros x y f g τ mx my mf mg mτ.
    simple refine ((_ ,, (tt ,, tt)) ,, tt) ; cbn.
    pose (p := pr11 mτ) ; cbn in p.
    use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
    rewrite !vassocl.
    use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
    exact (!p).
  Qed.

  Definition disp_locally_groupoid_disp_mnd
    : disp_locally_groupoid disp_mnd.
  Proof.
    use make_disp_locally_groupoid.
    - exact disp_locally_sym_disp_mnd.
    - apply disp_2cells_isaprop_disp_mnd.
  Defined.

  Definition disp_univalent_2_1_disp_mnd
    : disp_univalent_2_1 disp_mnd.
  Proof.
    use sigma_disp_univalent_2_1_with_props.
    - apply disp_2cells_isaprop_disp_mnd_data.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_univalent_2_1_disp_mnd_data.
    - apply disp_fullsubbicat_univalent_2_1.
  Defined.

  Definition disp_univalent_2_0_disp_mnd
             (HB : is_univalent_2 B)
    : disp_univalent_2_0 disp_mnd.
  Proof.
    use sigma_disp_univalent_2_0_with_props.
    - exact HB.
    - apply disp_2cells_isaprop_disp_mnd_data.
    - apply disp_2cells_isaprop_fullsubbicat.
    - apply disp_univalent_2_1_disp_mnd_data.
    - apply disp_fullsubbicat_univalent_2_1.
    - apply disp_locally_groupoid_disp_mnd_data.
    - apply disp_locally_groupoid_fullsubbicat.
    - apply disp_univalent_2_0_disp_mnd_data.
      exact HB.
    - use disp_univalent_2_0_fullsubbicat.
      + apply total_is_univalent_2.
        * apply disp_univalent_2_disp_mnd_data.
          exact HB.
        * exact HB.
      + intro.
        repeat (use isapropdirprod) ; apply cellset_property.
  Defined.

  Definition mnd
    : bicat
    := total_bicat disp_mnd.

  (**
   2. The univalence
   *)
  Definition is_univalent_2_1_mnd
             (HB : is_univalent_2_1 B)
    : is_univalent_2_1 mnd.
  Proof.
    apply total_is_univalent_2_1.
    - exact HB.
    - apply disp_univalent_2_1_disp_mnd.
  Defined.

  Definition is_univalent_2_0_mnd
             (HB : is_univalent_2 B)
    : is_univalent_2_0 mnd.
  Proof.
    apply total_is_univalent_2_0.
    - exact (pr1 HB).
    - apply disp_univalent_2_0_disp_mnd.
      exact HB.
  Defined.

  Definition is_univalent_2_mnd
             (HB : is_univalent_2 B)
    : is_univalent_2 mnd.
  Proof.
    split.
    - exact (is_univalent_2_0_mnd HB).
    - exact (is_univalent_2_1_mnd (pr2 HB)).
  Defined.
End Monad.

(**
 3. Projections and constructions
 *)
Section MonadProjections.
  Context {B : bicat}
          (m : mnd B).

  Definition ob_of_mnd
    : B
    := pr1 m.

  Definition endo_of_mnd
    : ob_of_mnd --> ob_of_mnd
    := pr112 m.

  Definition unit_of_mnd
    : id₁ _ ==> endo_of_mnd
    := pr1 (pr212 m).

  Definition mult_of_mnd
    : endo_of_mnd · endo_of_mnd ==> endo_of_mnd
    := pr2 (pr212 m).

  Definition mnd_unit_left
    : linvunitor _ • (unit_of_mnd ▹ _) • mult_of_mnd = id2 _
    := pr122 m.

  Definition mnd_unit_right
    : rinvunitor _ • (_ ◃ unit_of_mnd) • mult_of_mnd = id2 _
    := pr1 (pr222 m).

  Definition mnd_mult_assoc
    : rassociator _ _ _ • (_ ◃ mult_of_mnd) • mult_of_mnd
      =
      (mult_of_mnd ▹ _) • mult_of_mnd
    := pr2 (pr222 m).

  Definition mnd_mult_assoc'
    : (_ ◃ mult_of_mnd) • mult_of_mnd
      =
      lassociator _ _ _ • (mult_of_mnd ▹ _) • mult_of_mnd.
  Proof.
    rewrite !vassocl.
    use vcomp_move_L_pM ; [ is_iso | ].
    cbn.
    rewrite !vassocr.
    exact mnd_mult_assoc.
  Qed.
End MonadProjections.

Definition make_mnd_data
           {B : bicat}
           (x : B)
           (f : x --> x)
           (η : id₁ _ ==> f)
           (μ : f · f ==> f)
  : mnd_data B
  := x ,, (f ,, (η ,, μ)).

Definition make_mnd
           {B : bicat}
           (m : mnd_data B)
           (Hm : is_mnd B m)
  : mnd B
  := pr1 m ,, (pr2 m ,, Hm).

Section MonadMapProjections.
  Context {B : bicat}
          {m₁ m₂ : mnd B}
          (f : m₁ --> m₂).

  Definition mor_of_mnd_mor
    : ob_of_mnd m₁ --> ob_of_mnd m₂
    := pr1 f.

  Definition mnd_mor_endo
    : mor_of_mnd_mor · endo_of_mnd m₂ ==> endo_of_mnd m₁ · mor_of_mnd_mor
    := pr112 f.

  Definition mnd_mor_unit
    : linvunitor _ • (unit_of_mnd m₁ ▹ _)
      =
      rinvunitor _ • (_ ◃ unit_of_mnd m₂) • mnd_mor_endo
    := pr1 (pr212 f).

  Definition mnd_mor_mu
    : lassociator _ _ _
      • (mnd_mor_endo ▹ _)
      • rassociator _ _ _
      • (_ ◃ mnd_mor_endo)
      • lassociator _ _ _
      • (mult_of_mnd m₁ ▹ _)
      =
      (_ ◃ mult_of_mnd m₂)
      • mnd_mor_endo
    := pr2 (pr212 f).
End MonadMapProjections.

Definition mnd_mor_data
           {B : bicat}
           (m₁ m₂ : mnd B)
  : UU
  := ∑ (f : ob_of_mnd m₁ --> ob_of_mnd m₂),
     f · endo_of_mnd m₂
     ==>
     endo_of_mnd m₁ · f.

Definition make_mnd_mor_data
           {B : bicat}
           {m₁ m₂ : mnd B}
           (f : ob_of_mnd m₁ --> ob_of_mnd m₂)
           (f_e : f · endo_of_mnd m₂
                  ==>
                  endo_of_mnd m₁ · f)
  : mnd_mor_data m₁ m₂
  := f ,, f_e.

Definition mnd_mor_laws
           {B : bicat}
           {m₁ m₂ : mnd B}
           (f : mnd_mor_data m₁ m₂)
  : UU
  := (linvunitor _ • (unit_of_mnd m₁ ▹ _)
      =
      rinvunitor _ • (_ ◃ unit_of_mnd m₂) • (pr2 f))
     ×
     (lassociator _ _ _
      • (pr2 f ▹ _)
      • rassociator _ _ _
      • (_ ◃ pr2 f)
      • lassociator _ _ _
      • (mult_of_mnd m₁ ▹ _)
      =
      (_ ◃ mult_of_mnd m₂)
      • pr2 f).

Definition make_mnd_mor_laws
           {B : bicat}
           {m₁ m₂ : mnd B}
           (f : mnd_mor_data m₁ m₂)
           (fη : linvunitor _ • (unit_of_mnd m₁ ▹ _)
                 =
                 rinvunitor _ • (_ ◃ unit_of_mnd m₂) • pr2 f)
           (fμ : lassociator _ _ _
                 • (pr2 f ▹ _)
                 • rassociator _ _ _
                 • (_ ◃ pr2 f)
                 • lassociator _ _ _
                 • (mult_of_mnd m₁ ▹ _)
                 =
                 (_ ◃ mult_of_mnd m₂)
                 • pr2 f)
  : mnd_mor_laws f
  := fη ,, fμ.

Definition make_mnd_mor
           {B : bicat}
           {m₁ m₂ : mnd B}
           (f : mnd_mor_data m₁ m₂)
           (Hf : mnd_mor_laws f)
  : m₁ --> m₂
  := pr1 f ,, (pr2 f ,, Hf) ,, tt.

Section MonadCellProjections.
  Context {B : bicat}
          {m₁ m₂ : mnd B}
          {f₁ f₂ : m₁ --> m₂}
          (τ : f₁ ==> f₂).

  Definition cell_of_mnd_cell
    : mor_of_mnd_mor f₁ ==> mor_of_mnd_mor f₂
    := pr1 τ.

  Definition mnd_cell_endo
    : mnd_mor_endo f₁ • (_ ◃ cell_of_mnd_cell)
      =
      (cell_of_mnd_cell ▹ _) • mnd_mor_endo f₂
    := pr112 τ.
End MonadCellProjections.

Definition mnd_cell_data
           {B : bicat}
           {m₁ m₂ : mnd B}
           (f₁ f₂ : m₁ --> m₂)
  : UU
  := mor_of_mnd_mor f₁ ==> mor_of_mnd_mor f₂.

Definition is_mnd_cell
           {B : bicat}
           {m₁ m₂ : mnd B}
           {f₁ f₂ : m₁ --> m₂}
           (τ : mnd_cell_data f₁ f₂)
  : UU
  := mnd_mor_endo f₁ • (_ ◃ τ)
     =
     (τ ▹ _) • mnd_mor_endo f₂.

Definition make_mnd_cell
           {B : bicat}
           {m₁ m₂ : mnd B}
           {f₁ f₂ : m₁ --> m₂}
           (τ : mnd_cell_data f₁ f₂)
           (τ_e : is_mnd_cell τ)
  : f₁ ==> f₂
  := τ ,, ((τ_e ,, (tt ,, tt)) ,, tt).

Definition eq_mnd_cell
           {B : bicat}
           {m₁ m₂ : mnd B}
           {f₁ f₂ : m₁ --> m₂}
           {τ₁ τ₂ : f₁ ==> f₂}
           (p : cell_of_mnd_cell τ₁ = cell_of_mnd_cell τ₂)
  : τ₁ = τ₂.
Proof.
  use subtypePath.
  {
    intro ; simpl.
    apply isapropdirprod ; [ | apply isapropunit ].
    apply isapropdirprod ; [ apply cellset_property | ].
    apply isapropdirprod ; apply isapropunit.
  }
  exact p.
Qed.

(**
 4. Invertible 2-cells
 *)
Section IsInvertibleMndCell.
  Context {B : bicat}
          {m₁ m₂ : mnd B}
          {f₁ f₂ : m₁ --> m₂}
          {τ : f₁ ==> f₂}
          (Hτ : is_invertible_2cell (cell_of_mnd_cell τ)).

  Definition is_invertible_mnd_2cell_inverse
    : f₂ ==> f₁.
  Proof.
    use make_mnd_cell.
    - exact (Hτ^-1).
    - abstract
        (cbn ;
         use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
         rewrite !vassocr ;
         use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
         refine (!_) ;
         exact (mnd_cell_endo τ)).
  Defined.

  Definition is_invertible_mnd_2cell
    : is_invertible_2cell τ.
  Proof.
    use make_is_invertible_2cell.
    - exact is_invertible_mnd_2cell_inverse.
    - abstract
        (use eq_mnd_cell ; cbn ;
         apply vcomp_rinv).
    - abstract
        (use eq_mnd_cell ; cbn ;
         apply vcomp_linv).
  Defined.
End IsInvertibleMndCell.

Definition from_invertible_mnd_2cell
           {B : bicat}
           {m₁ m₂ : mnd B}
           {f₁ f₂ : m₁ --> m₂}
           {τ : f₁ ==> f₂}
           (Hτ : is_invertible_2cell τ)
  : is_invertible_2cell (cell_of_mnd_cell τ).
Proof.
  use make_is_invertible_2cell.
  - exact (pr1 (Hτ^-1)).
  - abstract
      (exact (maponpaths pr1 (vcomp_rinv Hτ))).
  - abstract
      (exact (maponpaths pr1 (vcomp_linv Hτ))).
Defined.

(**
 5. Equivalences of monads
 *)
Section ToEquivalence.
  Context {B : bicat}
          {x : B}
          {mx mx' : disp_mnd B x}
          (m₁ := x,, mx : mnd B)
          (m₂ := x,, mx' : mnd B)
          (Hl : mx -->[ id₁ x ] mx').

  Let l : m₁ --> m₂ := id₁ x ,, Hl.

  Context (Hγ : is_invertible_2cell (mnd_mor_endo l)).

  Definition to_equivalence_mnd_help_right_adj_data
    : mnd_mor_data m₂ m₁.
  Proof.
    use make_mnd_mor_data.
    - exact (id₁ x).
    - exact (lunitor _
             • rinvunitor _
             • Hγ^-1
             • lunitor _
             • rinvunitor _).
  Defined.

  Definition to_equivalence_mnd_help_right_adj_laws
    : mnd_mor_laws to_equivalence_mnd_help_right_adj_data.
  Proof.
    split.
    - cbn.
      rewrite !vassocl.
      rewrite lunitor_V_id_is_left_unit_V_id.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rinvunitor_natural.
        rewrite <- rwhisker_hcomp.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lunitor_runitor_identity.
      rewrite runitor_rinvunitor.
      rewrite id2_left.
      apply maponpaths.
      do 2 (use vcomp_move_R_Mp ; [ is_iso | ]) ; cbn.
      rewrite linvunitor_natural.
      rewrite rinvunitor_natural.
      rewrite <- lwhisker_hcomp, <- rwhisker_hcomp.
      rewrite lunitor_V_id_is_left_unit_V_id.
      refine (_ @ mnd_mor_unit l).
      rewrite <- lunitor_V_id_is_left_unit_V_id.
      apply idpath.
    - cbn.
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocr.
      do 3 (use vcomp_move_L_Mp ; [ is_iso | ]) ; cbn.
      rewrite !vassocl.
      etrans.
      {
        do 13 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_runitor.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite linvunitor_natural.
        rewrite <- lwhisker_hcomp.
        rewrite !vassocl.
        apply maponpaths.
        exact (!(mnd_mor_mu l)).
      }
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite vcomp_lunitor.
        rewrite !vassocl.
        rewrite rinvunitor_natural.
        rewrite <- rwhisker_hcomp.
        apply idpath.
      }
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite <- rinvunitor_triangle.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            rewrite !vassocr.
            do 12 apply maponpaths_2.
            rewrite rwhisker_hcomp.
            rewrite <- triangle_r_inv.
            rewrite <- lwhisker_hcomp.
            apply idpath.
          }
          rewrite lwhisker_vcomp.
          rewrite linvunitor_lunitor.
          rewrite lwhisker_id2.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocl.
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite rinvunitor_triangle.
        rewrite rinvunitor_runitor.
        rewrite id2_left.
        rewrite linvunitor_assoc.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      cbn.
      rewrite !vassocr.
      rewrite !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite !lwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        do 2 apply maponpaths_2.
        apply maponpaths.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lunitor_linvunitor.
            apply id2_left.
          }
          apply vcomp_linv.
        }
        apply id2_right.
      }
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite rwhisker_hcomp.
        rewrite <- triangle_r_inv.
        rewrite <- lwhisker_hcomp.
        apply idpath.
      }
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      refine (_ @ id2_right _).
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_linvunitor.
        apply id2_left.
      }
      apply vcomp_linv.
  Qed.

  Definition to_equivalence_mnd_help_right_adj
    : m₂ --> m₁.
  Proof.
    use make_mnd_mor.
    - exact to_equivalence_mnd_help_right_adj_data.
    - exact to_equivalence_mnd_help_right_adj_laws.
  Defined.

  Definition to_equivalence_mnd_help_equiv_unit_data
    : mnd_cell_data
        (id₁ m₁)
        (l · to_equivalence_mnd_help_right_adj)
    := linvunitor _.

  Definition to_equivalence_mnd_help_equiv_unit_is_mnd_cell
    : is_mnd_cell to_equivalence_mnd_help_equiv_unit_data.
  Proof.
    unfold is_mnd_cell, to_equivalence_mnd_help_equiv_unit_data ; cbn.
    rewrite !vassocr.
    refine (!_).
    rewrite <- linvunitor_assoc.
    rewrite lwhisker_hcomp.
    rewrite <- linvunitor_natural.
    rewrite !vassocl.
    rewrite linvunitor_assoc.
    rewrite !vassocl.
    etrans.
    {
      do 6 apply maponpaths.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 4 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_hcomp.
      rewrite <- rinvunitor_natural.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_linvunitor.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_linv.
      rewrite id2_left.
      apply idpath.
    }
    do 2 apply maponpaths.
    rewrite <- rinvunitor_triangle.
    rewrite !vassocl.
    rewrite lassociator_rassociator.
    rewrite id2_right.
    rewrite lunitor_V_id_is_left_unit_V_id.
    apply idpath.
  Qed.

  Definition to_equivalence_mnd_help_equiv_unit
    : id₁ m₁ ==> l · to_equivalence_mnd_help_right_adj.
  Proof.
    use make_mnd_cell.
    - exact to_equivalence_mnd_help_equiv_unit_data.
    - exact to_equivalence_mnd_help_equiv_unit_is_mnd_cell.
  Defined.

  Definition to_equivalence_mnd_help_equiv_counit_data
    : mnd_cell_data
        (to_equivalence_mnd_help_right_adj · l)
        (id₁ m₂)
    := lunitor _.

  Definition to_equivalence_mnd_help_equiv_counit_is_mnd_cell
    : is_mnd_cell to_equivalence_mnd_help_equiv_counit_data.
  Proof.
    unfold is_mnd_cell, to_equivalence_mnd_help_equiv_counit_data ; cbn.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite <- lunitor_triangle.
    rewrite !vassocr.
    rewrite rassociator_lassociator.
    rewrite id2_left.
    rewrite !vassocl.
    apply maponpaths.
    rewrite lunitor_lwhisker.
    rewrite rwhisker_vcomp.
    rewrite rwhisker_vcomp.
    rewrite rinvunitor_runitor.
    rewrite id2_right.
    rewrite !rwhisker_vcomp.
    use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
    rewrite !vassocl.
    rewrite vcomp_runitor.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite runitor_rinvunitor.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite vcomp_rinv.
    apply id2_left.
  Qed.

  Definition to_equivalence_mnd_help_equiv_counit
    : to_equivalence_mnd_help_right_adj · l ==> id₁ m₂.
  Proof.
    use make_mnd_cell.
    - exact to_equivalence_mnd_help_equiv_counit_data.
    - exact to_equivalence_mnd_help_equiv_counit_is_mnd_cell.
  Defined.

  Definition to_equivalence_mnd_help_equiv_data
    : left_adjoint_data l
    := to_equivalence_mnd_help_right_adj
       ,,
       (to_equivalence_mnd_help_equiv_unit
       ,,
       to_equivalence_mnd_help_equiv_counit).

  Definition to_equivalence_mnd_help_equiv_axioms
    : left_equivalence_axioms to_equivalence_mnd_help_equiv_data.
  Proof.
    split ; use is_invertible_mnd_2cell ; cbn.
    - unfold to_equivalence_mnd_help_equiv_unit_data.
      is_iso.
    - unfold to_equivalence_mnd_help_equiv_counit_data.
      is_iso.
  Defined.

  Definition to_equivalence_mnd_help_equiv
    : left_equivalence l
    := to_equivalence_mnd_help_equiv_data
       ,,
       to_equivalence_mnd_help_equiv_axioms.
End ToEquivalence.

Definition to_equivalence_mnd_help
           {B : bicat}
           (HB : is_univalent_2_0 B)
           {x y : B}
           (l : adjoint_equivalence x y)
           {mx : disp_mnd B x}
           {my : disp_mnd B y}
           (m₁ := x ,, mx : mnd B)
           (m₂ := y ,, my : mnd B)
           (Hl : mx -->[ l ] my)
           (ml := pr1 l ,, Hl : m₁ --> m₂)
           (Hγ : is_invertible_2cell (mnd_mor_endo ml))
  : left_adjoint_equivalence ml.
Proof.
  revert x y l mx my m₁ m₂ Hl ml Hγ.
  use (J_2_0 HB).
  intros x mx mx' m₁ m₂ Hl ml Hγ.
  use equiv_to_adjequiv.
  exact (to_equivalence_mnd_help_equiv Hl Hγ).
Defined.

Definition to_equivalence_mnd
           {B : bicat}
           (HB : is_univalent_2_0 B)
           {m₁ m₂ : mnd B}
           (l : m₁ --> m₂)
           (Hl : left_adjoint_equivalence (pr1 l))
           (Hγ : is_invertible_2cell (mnd_mor_endo l))
  : left_adjoint_equivalence l.
Proof.
  exact (to_equivalence_mnd_help
           HB
           (pr1 l ,, Hl)
           (pr2 l)
           Hγ).
Defined.

(**
 6. Underlying pseudofunctor
 *)
Definition und_mnd
           (B : bicat)
  : psfunctor (mnd B) B
  := pr1_psfunctor _.


Module M0.

Inductive foo (A : Type) := Foo {
  foo0 : option (bar A);
  foo1 : nat;
  foo2 := foo1 = 0;
  foo3 : foo2;
}

with bar (A : Type) := Bar {
  bar0 : A;
  bar1 := 0;
  bar2 : bar1 = 0;
  bar3 : nat -> foo A;
}.

End M0.

Module M1.

Set Primitive Projections.

Inductive foo (A : Type) := Foo {
  foo0 : option (bar A);
  foo1 : nat;
  foo2 := foo1 = 0;
  foo3 : foo2;
}

with bar (A : Type) := Bar {
  bar0 : A;
  bar1 := 0;
  bar2 : bar1 = 0;
  bar3 : nat -> foo A;
}.

End M1.

Module M2.

Set Primitive Projections.

CoInductive foo (A : Type) := Foo {
  foo0 : option (bar A);
  foo1 : nat;
  foo2 := foo1 = 0;
  foo3 : foo2;
}

with bar (A : Type) := Bar {
  bar0 : A;
  bar1 := 0;
  bar2 : bar1 = 0;
  bar3 : nat -> foo A;
}.

End M2.


Require Import Fiat.QueryStructure.Automation.MasterPlan.
Require Import Fiat.QueryStructure.Automation.MasterPlan.
Require Import Bedrock.Memory.

Instance : Query_eq (Word.word n) :=
  { A_eq_dec := @Word.weq n }.
Opaque Word.weq.
Opaque Word.natToWord.
Opaque Word.wlt_dec.
Definition WordMax (w w' : W) :=
  if Word.wlt_dec w w' then w' else w.
Definition MaxW (rows : Comp (list W)) : Comp (option W) :=
  FoldAggregateOption WordMax rows.
Definition SumW rows := FoldAggregate (@Word.wplus 32) (Word.natToWord 32 0) rows.

Definition Market := W.
Definition StockType := W.
Definition StockCode := W.
Definition Date      := W.
Definition Timestamp := W.

Definition TYPE := "TYPE".
Definition MARKET := "MARKET".
Definition STOCK_CODE := "STOCK_CODE".
Definition FULL_NAME := "FULL_NAME".

Definition DATE := "DATE".
Definition TIME := "TIME".
Definition PRICE := "PRICE".
Definition VOLUME := "VOLUME".

Definition STOCKS := "STOCKS".
Definition TRANSACTIONS := "TRANSACTIONS".

Definition StocksSchema :=
  Query Structure Schema
    [ relation STOCKS has
              schema <STOCK_CODE :: W,
                      FULL_NAME :: W,
                      MARKET :: W,
                      TYPE :: W>
              where (UniqueAttribute ``STOCK_CODE); (* uniqueness, really *)
      relation TRANSACTIONS has
              schema <STOCK_CODE :: W,
                      DATE :: W,
                      TIME :: W,
                      PRICE :: W,
                      VOLUME :: W> ]
    enforcing [attribute STOCK_CODE for TRANSACTIONS references STOCKS].

Definition StocksSpec : ADT _ :=
  Def ADT {
    rep := QueryStructure StocksSchema,
    Def Constructor0 "Init" : rep := empty,,

    Def Method1 "AddStock" (r : rep) (stock: StocksSchema#STOCKS) : rep * bool :=
        Insert stock into r!STOCKS,

    Def Method1 "AddTransaction" (r : rep) (transaction : StocksSchema#TRANSACTIONS) : rep * bool :=
        Insert transaction into r!TRANSACTIONS,

    Def Method2 "TotalVolume" (r : rep) (code : StockCode) (date : Date) : rep * W :=
          sum <- SumW (For (transaction in r!TRANSACTIONS)
                           Where (transaction!STOCK_CODE = code)
                           Where (transaction!DATE = date)
                           Return transaction!VOLUME);
    ret (r, sum),

    Def Method2 "MaxPrice" (r : rep) (code : StockCode) (date : Date) : rep * option W :=
      max <- MaxW (For (transaction in r!TRANSACTIONS)
                       Where (transaction!STOCK_CODE = code)
                       Where (transaction!DATE = date)
                       Return transaction!PRICE);
     ret (r, max),

    Def Method2 "TotalActivity" (r : rep) (code : StockCode) (date : Date) : rep * W :=
       count <- Count (For (transaction in r!TRANSACTIONS)
                           Where (transaction!STOCK_CODE = code)
                           Where (transaction!DATE = date)
                           Return ());
     ret (r, Word.natToWord 32 count),

    Def Method2 "LargestTransaction" (r : rep) (type : StockType) (date : Date) : rep * option W :=
        max <- MaxW (For (stock in r!STOCKS) (transaction in r!TRANSACTIONS)
                         Where (stock!TYPE = type)
                         Where (transaction!DATE = date)
                         Where (stock!STOCK_CODE = transaction!STOCK_CODE)
                         Return (Word.wmult transaction!PRICE transaction!VOLUME));
     ret (r, max)
}%methDefParsing.

Definition SharpenedStocks :
  MostlySharpened StocksSpec.
Proof.
  start sharpening ADT.
  simpl; pose_string_hyps; pose_heading_hyps.
  start_honing_QueryStructure'.
  hone method "AddStock".
  { setoid_rewrite UniqueAttribute_symmetry.
    setoid_rewrite (@refine_uniqueness_check_into_query' StocksSchema Fin.F1 _ _ _ _).
    setoid_rewrite refine_Count.
    simplify with monad laws; simpl in *; subst.
    setoid_rewrite refine_pick_eq'.
    setoid_rewrite refine_bind_unit.
    setoid_rewrite refine_If_Then_Else_Duplicate.
    finish honing. }
  GenerateIndexesForAll EqExpressionAttributeCounter
  ltac:(fun attrlist =>
          let attrlist' := eval compute in (PickIndexes _ (CountAttributes' attrlist)) in
              make_simple_indexes attrlist'
                                  ltac:(LastCombineCase6 BuildEarlyEqualityIndex)
                                         ltac:(LastCombineCase5 BuildLastEqualityIndex)).
  + plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + setoid_rewrite refine_For_rev; simplify with monad laws.
    plan EqIndexUse createEarlyEqualityTerm createLastEqualityTerm
         EqIndexUse_dep createEarlyEqualityTerm_dep createLastEqualityTerm_dep.
  + hone method "AddStock".
    { simpl in *; subst.
      simplify with monad laws.
      unfold ilist2_hd at 1; simpl.
      repeat setoid_rewrite rev_length.
      repeat setoid_rewrite map_length.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      repeat setoid_rewrite refine_If_Then_Else_Bind.
      repeat setoid_rewrite refineEquiv_bind_bind.
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
      unfold H1; eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      finish honing.
    }
    hone method "AddTransaction".
    { simpl in *; subst.
      setoid_rewrite refine_Count; simplify with monad laws.
      setoid_rewrite app_nil_r;
        setoid_rewrite map_map; simpl.
      unfold ilist2_hd at 1; simpl.
      setoid_rewrite rev_length.
      setoid_rewrite map_length.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      repeat setoid_rewrite refine_If_Then_Else_Bind.
      repeat setoid_rewrite refineEquiv_bind_bind.
      repeat setoid_rewrite refineEquiv_bind_unit; simpl.
      unfold H1.
      eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      finish honing.
    }
    hone method "TotalVolume".
    { simpl in *; subst; simplify with monad laws.
      unfold H1; eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      rewrite app_nil_r, map_map; unfold ilist2_hd; simpl.
      finish honing.
    }
    hone method "MaxPrice".
    { simpl in *; subst; simplify with monad laws.
      unfold H1; eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      rewrite app_nil_r, map_map; unfold ilist2_hd; simpl.
      finish honing.
    }
    hone method "TotalActivity".
    { simpl in *; subst.
      setoid_rewrite refine_Count; simplify with monad laws.
      unfold H1; eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      rewrite app_nil_r, map_map; unfold ilist2_hd; simpl.
      rewrite rev_length, map_length.
      finish honing.
    }
    hone method "LargestTransaction".
    { simpl in *; subst; simplify with monad laws.
      unfold H1; eapply refine_under_bind; intros; set_evars.
      rewrite (CallBagFind_fst H0); simpl.
      etransitivity.
      eapply refine_under_bind_both.
      eapply (@Join_Comp_Lists_eq StocksSchema Index (Fin.FS Fin.F1)).
      intros; finish honing.
      simplify with monad laws.
      unfold H2; apply refine_under_bind; set_evars.
      intros.
      apply Join_Comp_Lists_eq' in H4; rewrite H4.
      setoid_rewrite refine_pick_eq'; simplify with monad laws.
      simpl.
      finish honing.
    }
    simpl; eapply reflexivityT.
  + unfold CallBagFind, CallBagInsert.
    pose_headings_all.
    match goal with
    | |- appcontext[ @BuildADT (IndexedQueryStructure ?Schema ?Indexes) ] =>
      FullySharpenQueryStructure Schema Indexes
    end.

Time Defined.
(* 2590MB  *)

Time Definition StocksImpl :=
  Eval simpl in (fst (projT1 SharpenedStocks)).
Print StocksImpl.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Common.CommonDefinitions.
Require Export depoolContract.Scenarios.Common.RoundDefinitions.
Require Export depoolContract.Scenarios.Correctness.StakeValueCorrect.
Require Export depoolContract.Scenarios.Correctness.LedgerCorrect.

Definition _roundCorrectNonNegative (r : RoundsBase_ι_Round) :=
    0 <= RoundsBase_ι_Round_ι_supposedElectedAt r /\
    0 <= RoundsBase_ι_Round_ι_unfreeze r /\
    0 <= RoundsBase_ι_Round_ι_participantQty r /\
    0 <= RoundsBase_ι_Round_ι_stake r /\
    0 <= RoundsBase_ι_Round_ι_rewards r /\
    0 <= RoundsBase_ι_Round_ι_unused r /\
    0 <= RoundsBase_ι_Round_ι_stakeHeldFor r /\
    0 <= RoundsBase_ι_Round_ι_recoveredStake r /\
    0 <= RoundsBase_ι_Round_ι_validatorStake r /\
    0 <= RoundsBase_ι_Round_ι_validatorRemainingStake r /\
    0 <= RoundsBase_ι_Round_ι_handledStakesAndRewards r.

Definition _roundCorrectStakeIsTheMost (r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_unused r +
    RoundsBase_ι_Round_ι_recoveredStake r
    <= RoundsBase_ι_Round_ι_stake r.

Definition _roundCorrectStakeSum (r : RoundsBase_ι_Round) :=
    fold_left Z.add (map stakeSum (map snd (RoundsBase_ι_Round_ι_stakes r))) 0 =
    RoundsBase_ι_Round_ι_stake r.

Definition _roundCorrectStakes (l : Ledger)(r : RoundsBase_ι_Round) :=
    Forall (StakeValueCorrectLocally l) (map snd (RoundsBase_ι_Round_ι_stakes r)).

Definition _roundValidatorRemainingStake (r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_validatorRemainingStake r <=
    RoundsBase_ι_Round_ι_unused r + RoundsBase_ι_Round_ι_recoveredStake r.

Definition _roundNoDupStakes (r : RoundsBase_ι_Round) :=
    NoDup (map fst (RoundsBase_ι_Round_ι_stakes r)).

Definition _roundValidatorRemainingStakeLessOrEqualValidatorStake
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_validatorRemainingStake r <= stakeSum (validatorStake l r).

Definition _roundCorrectPrepoolingAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_step (roundPre0 l) = RoundsBase_ι_RoundStepP_ι_PrePooling /\
        (RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_PrePooling ->
        roundIn l r ->
        poolClosed l = false ->
        r = roundPre0 l
        ) /\
    RoundsBase_ι_Round_ι_completionReason (roundPre0 l) =
        RoundsBase_ι_CompletionReasonP_ι_Undefined.

Definition _roundCorrectPoolingAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) := poolClosed l = false -> (
    RoundsBase_ι_Round_ι_step (round0 l) = RoundsBase_ι_RoundStepP_ι_Pooling /\
        (RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_Pooling ->
        roundIn l r ->
        poolClosed l = false ->
        r = round0 l
        )) /\
    RoundsBase_ι_Round_ι_completionReason (round0 l) =
        RoundsBase_ι_CompletionReasonP_ι_Undefined.

Definition _roundCorrectWaitingValidatorRequestAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest ->
    roundIn l r ->
    (r = round1 l
            /\
    RoundsBase_ι_Round_ι_completionReason r =
        RoundsBase_ι_CompletionReasonP_ι_Undefined).

Definition _roundCorrectWaitingIfStakeAcceptedAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted ->
    roundIn l r ->
    (r = round1 l
            /\
    RoundsBase_ι_Round_ι_completionReason r =
        RoundsBase_ι_CompletionReasonP_ι_Undefined).

Definition _roundCorrectWaitingValidatorStartAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart ->
    roundIn l r ->
    ((r = round1 l \/ r = round2 l)
            /\
    RoundsBase_ι_Round_ι_completionReason r =
        RoundsBase_ι_CompletionReasonP_ι_Undefined).

Definition _roundCorrectWaitingIfValidatorWinsElectionsAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    RoundsBase_ι_Round_ι_step r = RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections ->
    roundIn l r ->
    ((r = round1 l \/ r = round2 l)
            /\
    RoundsBase_ι_Round_ι_completionReason r =
        RoundsBase_ι_CompletionReasonP_ι_Undefined).

Definition _roundCorrectStepsAndCompletionReasons
    (l : Ledger)(r : RoundsBase_ι_Round) :=
    _roundCorrectPrepoolingAndCompletionReasons l r /\
    _roundCorrectPoolingAndCompletionReasons l r /\
    _roundCorrectWaitingValidatorRequestAndCompletionReasons l r /\
    _roundCorrectWaitingIfStakeAcceptedAndCompletionReasons l r /\
    _roundCorrectWaitingValidatorStartAndCompletionReasons l r /\
    _roundCorrectWaitingIfValidatorWinsElectionsAndCompletionReasons l r.

Definition roundCorrectLocally (l : Ledger)(r : RoundsBase_ι_Round) :=
    _roundCorrectNonNegative r /\
    _roundCorrectStakeIsTheMost r /\
    _roundCorrectStakeSum r /\
    _roundCorrectStakes l r /\
    _roundValidatorRemainingStake r /\
    _roundNoDupStakes r /\
    _roundValidatorRemainingStakeLessOrEqualValidatorStake l r /\
    ledgerCorrectLocally l /\
    _roundCorrectStepsAndCompletionReasons l r.

Definition roundCorrectGlobally (l : Ledger) :=
    StakeValueCorrectGlobally l /\ (
    forall r,
    roundIn l r /\
    roundCorrectLocally l r).


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

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Definition grid := (map.Map.map Z Z).

(* Why3 assumption *)
Definition valid_chunk (g:(map.Map.map Z Z)) (i:Z) (start:(map.Map.map Z Z))
  (offsets:(map.Map.map Z Z)): Prop := let s := (map.Map.get start i) in
  forall (o1:Z) (o2:Z), (((0%Z <= o1)%Z /\ (o1 < 9%Z)%Z) /\
  (((0%Z <= o2)%Z /\ (o2 < 9%Z)%Z) /\ ~ (o1 = o2))) -> let i1 :=
  (s + (map.Map.get offsets o1))%Z in let i2 := (s + (map.Map.get offsets
  o2))%Z in ((((1%Z <= (map.Map.get g i1))%Z /\ ((map.Map.get g
  i1) <= 9%Z)%Z) /\ ((1%Z <= (map.Map.get g i2))%Z /\ ((map.Map.get g
  i2) <= 9%Z)%Z)) -> ~ ((map.Map.get g i1) = (map.Map.get g i2))).

(* Why3 assumption *)
Definition is_index (i:Z): Prop := (0%Z <= i)%Z /\ (i < 81%Z)%Z.

(* Why3 assumption *)
Definition valid (g:(map.Map.map Z Z)): Prop := forall (i:Z), (is_index i) ->
  ((valid_chunk g i
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z
  7%Z) 8%Z 8%Z) 9%Z 0%Z) 10%Z 1%Z) 11%Z 2%Z) 12%Z 3%Z) 13%Z 4%Z) 14%Z 5%Z)
  15%Z 6%Z) 16%Z 7%Z) 17%Z 8%Z) 18%Z 0%Z) 19%Z 1%Z) 20%Z 2%Z) 21%Z 3%Z) 22%Z
  4%Z) 23%Z 5%Z) 24%Z 6%Z) 25%Z 7%Z) 26%Z 8%Z) 27%Z 0%Z) 28%Z 1%Z) 29%Z 2%Z)
  30%Z 3%Z) 31%Z 4%Z) 32%Z 5%Z) 33%Z 6%Z) 34%Z 7%Z) 35%Z 8%Z) 36%Z 0%Z) 37%Z
  1%Z) 38%Z 2%Z) 39%Z 3%Z) 40%Z 4%Z) 41%Z 5%Z) 42%Z 6%Z) 43%Z 7%Z) 44%Z 8%Z)
  45%Z 0%Z) 46%Z 1%Z) 47%Z 2%Z) 48%Z 3%Z) 49%Z 4%Z) 50%Z 5%Z) 51%Z 6%Z) 52%Z
  7%Z) 53%Z 8%Z) 54%Z 0%Z) 55%Z 1%Z) 56%Z 2%Z) 57%Z 3%Z) 58%Z 4%Z) 59%Z 5%Z)
  60%Z 6%Z) 61%Z 7%Z) 62%Z 8%Z) 63%Z 0%Z) 64%Z 1%Z) 65%Z 2%Z) 66%Z 3%Z) 67%Z
  4%Z) 68%Z 5%Z) 69%Z 6%Z) 70%Z 7%Z) 71%Z 8%Z) 72%Z 0%Z) 73%Z 1%Z) 74%Z 2%Z)
  75%Z 3%Z) 76%Z 4%Z) 77%Z 5%Z) 78%Z 6%Z) 79%Z 7%Z) 80%Z 8%Z)
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 9%Z) 2%Z 18%Z) 3%Z 27%Z) 4%Z 36%Z) 5%Z 45%Z) 6%Z 54%Z)
  7%Z 63%Z) 8%Z 72%Z)) /\ ((valid_chunk g i
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 0%Z) 4%Z 0%Z) 5%Z 0%Z) 6%Z 0%Z) 7%Z
  0%Z) 8%Z 0%Z) 9%Z 9%Z) 10%Z 9%Z) 11%Z 9%Z) 12%Z 9%Z) 13%Z 9%Z) 14%Z 9%Z)
  15%Z 9%Z) 16%Z 9%Z) 17%Z 9%Z) 18%Z 18%Z) 19%Z 18%Z) 20%Z 18%Z) 21%Z 18%Z)
  22%Z 18%Z) 23%Z 18%Z) 24%Z 18%Z) 25%Z 18%Z) 26%Z 18%Z) 27%Z 27%Z) 28%Z
  27%Z) 29%Z 27%Z) 30%Z 27%Z) 31%Z 27%Z) 32%Z 27%Z) 33%Z 27%Z) 34%Z 27%Z)
  35%Z 27%Z) 36%Z 36%Z) 37%Z 36%Z) 38%Z 36%Z) 39%Z 36%Z) 40%Z 36%Z) 41%Z
  36%Z) 42%Z 36%Z) 43%Z 36%Z) 44%Z 36%Z) 45%Z 45%Z) 46%Z 45%Z) 47%Z 45%Z)
  48%Z 45%Z) 49%Z 45%Z) 50%Z 45%Z) 51%Z 45%Z) 52%Z 45%Z) 53%Z 45%Z) 54%Z
  54%Z) 55%Z 54%Z) 56%Z 54%Z) 57%Z 54%Z) 58%Z 54%Z) 59%Z 54%Z) 60%Z 54%Z)
  61%Z 54%Z) 62%Z 54%Z) 63%Z 63%Z) 64%Z 63%Z) 65%Z 63%Z) 66%Z 63%Z) 67%Z
  63%Z) 68%Z 63%Z) 69%Z 63%Z) 70%Z 63%Z) 71%Z 63%Z) 72%Z 72%Z) 73%Z 72%Z)
  74%Z 72%Z) 75%Z 72%Z) 76%Z 72%Z) 77%Z 72%Z) 78%Z 72%Z) 79%Z 72%Z) 80%Z
  72%Z)
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z
  7%Z) 8%Z 8%Z)) /\ (valid_chunk g i
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 3%Z) 4%Z 3%Z) 5%Z 3%Z) 6%Z 6%Z) 7%Z
  6%Z) 8%Z 6%Z) 9%Z 0%Z) 10%Z 0%Z) 11%Z 0%Z) 12%Z 3%Z) 13%Z 3%Z) 14%Z 3%Z)
  15%Z 6%Z) 16%Z 6%Z) 17%Z 6%Z) 18%Z 0%Z) 19%Z 0%Z) 20%Z 0%Z) 21%Z 3%Z) 22%Z
  3%Z) 23%Z 3%Z) 24%Z 6%Z) 25%Z 6%Z) 26%Z 6%Z) 27%Z 27%Z) 28%Z 27%Z) 29%Z
  27%Z) 30%Z 30%Z) 31%Z 30%Z) 32%Z 30%Z) 33%Z 33%Z) 34%Z 33%Z) 35%Z 33%Z)
  36%Z 27%Z) 37%Z 27%Z) 38%Z 27%Z) 39%Z 30%Z) 40%Z 30%Z) 41%Z 30%Z) 42%Z
  33%Z) 43%Z 33%Z) 44%Z 33%Z) 45%Z 27%Z) 46%Z 27%Z) 47%Z 27%Z) 48%Z 30%Z)
  49%Z 30%Z) 50%Z 30%Z) 51%Z 33%Z) 52%Z 33%Z) 53%Z 33%Z) 54%Z 54%Z) 55%Z
  54%Z) 56%Z 54%Z) 57%Z 57%Z) 58%Z 57%Z) 59%Z 57%Z) 60%Z 60%Z) 61%Z 60%Z)
  62%Z 60%Z) 63%Z 54%Z) 64%Z 54%Z) 65%Z 54%Z) 66%Z 57%Z) 67%Z 57%Z) 68%Z
  57%Z) 69%Z 60%Z) 70%Z 60%Z) 71%Z 60%Z) 72%Z 54%Z) 73%Z 54%Z) 74%Z 54%Z)
  75%Z 57%Z) 76%Z 57%Z) 77%Z 57%Z) 78%Z 60%Z) 79%Z 60%Z) 80%Z 60%Z)
  (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.set (map.Map.const (-1%Z)%Z:(map.Map.map
  Z Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 9%Z) 4%Z 10%Z) 5%Z 11%Z) 6%Z 18%Z) 7%Z
  19%Z) 8%Z 20%Z)))).

(* Why3 assumption *)
Definition full (g:(map.Map.map Z Z)): Prop := forall (i:Z), (is_index i) ->
  ((1%Z <= (map.Map.get g i))%Z /\ ((map.Map.get g i) <= 9%Z)%Z).

(* Why3 assumption *)
Definition included (g1:(map.Map.map Z Z)) (g2:(map.Map.map Z Z)): Prop :=
  forall (i:Z), ((is_index i) /\ ((1%Z <= (map.Map.get g1 i))%Z /\
  ((map.Map.get g1 i) <= 9%Z)%Z)) -> ((map.Map.get g2 i) = (map.Map.get g1
  i)).

(* Why3 assumption *)
Definition is_solution_for (sol:(map.Map.map Z Z)) (data:(map.Map.map Z
  Z)): Prop := (included data sol) /\ ((full sol) /\ (valid sol)).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition distinct_pair (g:(map.Map.map Z Z)) (s:Z) (offsets:(map.Map.map Z
  Z)) (o1:Z) (o2:Z): Prop := let i1 := (s + (map.Map.get offsets o1))%Z in
  let i2 := (s + (map.Map.get offsets o2))%Z in ((~ (o1 = o2)) ->
  ((((1%Z <= (map.Map.get g i1))%Z /\ ((map.Map.get g i1) <= 9%Z)%Z) /\
  ((1%Z <= (map.Map.get g i2))%Z /\ ((map.Map.get g i2) <= 9%Z)%Z)) ->
  ~ ((map.Map.get g i1) = (map.Map.get g i2)))).

(* Why3 assumption *)
Definition distinct_pairs (g:(map.Map.map Z Z)) (s:Z) (offsets:(map.Map.map Z
  Z)) (o1:Z) (o2:Z): Prop := forall (a:Z) (b:Z), (((0%Z <= a)%Z /\
  (a < o1)%Z) /\ ((0%Z <= b)%Z /\ (b < o2)%Z)) -> (distinct_pair g s offsets
  a b).

Axiom distinct_pairs_to_valid_chunk : forall (g:(map.Map.map Z Z)) (i:Z)
  (start:(map.Map.map Z Z)) (offsets:(map.Map.map Z Z)), (distinct_pairs g
  (map.Map.get start i) offsets 9%Z 9%Z) -> (valid_chunk g i start offsets).

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v:(map.Map.map Z a))).

(* Why3 assumption *)
Definition is_grid (g:(map.Map.map Z Z)): Prop := forall (k:Z),
  ((1%Z <= (map.Map.get g k))%Z /\ ((map.Map.get g k) <= 9%Z)%Z) \/
  ((map.Map.get g k) = (-1%Z)%Z).

(* Why3 assumption *)
Definition partial (g:(map.Map.map Z Z)) (i:Z): Prop := (forall (k:Z),
  ((0%Z <= k)%Z /\ (k < i)%Z) -> ((1%Z <= (map.Map.get g k))%Z /\
  ((map.Map.get g k) <= 9%Z)%Z)) /\ forall (k:Z), (is_index k) ->
  (((1%Z <= (map.Map.get g k))%Z /\ ((map.Map.get g k) <= 9%Z)%Z) \/
  ((map.Map.get g k) = (-1%Z)%Z)).

Axiom partial_1 : forall (g:(map.Map.map Z Z)) (i:Z), (i < 81%Z)%Z ->
  ((partial g i) -> ((~ ((map.Map.get g i) = (-1%Z)%Z)) -> (partial g
  (i + 1%Z)%Z))).

(* Why3 assumption *)
Definition same_chunk (start:(map.Map.map Z Z)) (i:Z) (j:Z): Prop :=
  ((map.Map.get start i) = (map.Map.get start j)).

Axiom same_chunk_injective : forall (start:(map.Map.map Z Z)) (i:Z) (j:Z),
  (~ (same_chunk start i j)) -> ~ (i = j).

Axiom update_not_same_chunk : forall (g:(map.Map.map Z Z)) (i:Z) (x:Z)
  (start:(map.Map.map Z Z)), forall (j:Z), ((is_index i) /\ ((is_index j) /\
  ~ (same_chunk start i j))) -> ((map.Map.get (map.Map.set g i x)
  j) = (map.Map.get g j)).

(* Why3 goal *)
Theorem valid_chunk_update_neq : forall (g:(map.Map.map Z Z)) (i:Z) (x:Z)
  (start:(map.Map.map Z Z)) (offsets:(map.Map.map Z Z)), forall (j:Z),
  (valid_chunk g j start offsets) -> (((is_index i) /\ ((is_index j) /\
  ~ (same_chunk start i j))) -> (valid_chunk (map.Map.set g i x) j start
  offsets)).
intros g i x start offsets j h1 (h2,(h3,h4)).
unfold valid_chunk.
intros o1 o2. intros.
rewrite (update_not_same_chunk _ _ _ start).
rewrite (update_not_same_chunk _ _ _ start).
apply h1. auto.
rewrite (update_not_same_chunk _ _ _ start) in H0.
rewrite (update_not_same_chunk _ _ _ start) in H0.
auto.

Qed.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Fiat.Common.ilist2
        Fiat.Common.StringBound
        Coq.Program.Program
        Fiat.QueryStructure.Specification.Representation.Heading2
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.QueryStructure.Specification.Representation.Notations.

(* A tuple is a heterogeneous list indexed by a heading. *)
Definition Tuple2 {heading : RawHeading2} :=
  ilist2 (B := id) (AttrList2 heading).

Definition DecTuple2 {n} attrs
  := @Tuple2 (BuildHeading2 (n := n) attrs).

(* Notations for tuple field. *)

Record Component2 (Heading : Attribute2) :=
  { value2 : attrType2 Heading }.

(* Notation-friendly tuple definition. *)

Fixpoint BuildTuple2
         {n}
         (attrs : Vector.t Attribute2 n)
  : ilist2 (B := Component2) attrs -> DecTuple2 attrs :=
  match attrs return ilist2 (B := Component2) attrs -> DecTuple2 attrs with
  | Vector.nil => fun components => inil2
  | Vector.cons attr n' attrs' =>
    fun components =>
      icons2 (B := id) (value2 (ilist2_hd components))
            (BuildTuple2 attrs' (ilist2_tl components))
  end.

Definition GetAttribute2 {heading}
: @Tuple2 heading -> forall attr : Attributes2 heading, Domain2 heading attr := ith2.

Definition GetAttribute2' {n} {attrs}
  : @DecTuple2 n attrs ->
    forall attr : @BoundedString _ (Vector.map attrName2 attrs),
      Domain2 (BuildHeading2 attrs) (ibound (indexb attr)) :=
  fun t idx => ith2 t (ibound (indexb idx)).

Definition SetAttribute2 {heading}
: @Tuple2 heading ->
  forall attr : Attributes2 heading,
    Domain2 heading attr -> @Tuple2 heading :=
  fun tup attr dom => replace_Index2 _ tup attr dom.

Definition SetAttribute2' {n} {attrs}
  : @DecTuple2 n attrs ->
    forall attr : @BoundedString _ (Vector.map attrName2 attrs),
      Domain2 (HeadingRaw2 (BuildHeading2 attrs)) (ibound (indexb attr))
      -> @DecTuple2 n attrs :=
  fun tup attr dom => SetAttribute2 tup (ibound (indexb attr)) dom.

Notation "id :: value" :=
  (Build_Component2 {| attrName2 := id;
                       attrType2 := _ |}
                    value) : Component2_scope.

Bind Scope Component2_scope with Component2.
Delimit Scope Component2_scope with Component2.
Delimit Scope Tuple2_scope with Tuple2.
(* Notation for tuples built from [BuildTuple2]. *)


(* * Constructors and Deconstructors for Pair Types *)

From Undecidability.TM Require Import ProgrammingTools.

Set Default Proof Using "Type".
(* TODO: ~> base *)
Lemma pair_eq (A B : Type) (a1 a2 : A) (b1 b2 : B) :
  (a1, b1) = (a2, b2) ->
  a1 = a2 /\ b1 = b2.
Proof. intros H. now inv H. Qed.

Lemma tl_length (X : Type) (xs : list X) :
  length (tl xs) = pred (length xs).
Proof. destruct xs; cbn; auto. Qed.

Local Arguments skipn { A } !n !l.

Section CasePair.

  (* ** Deconstructor *)

  Variable (sigX sigY: finType) (X Y: Type) (cX: codable sigX X) (cY: codable sigY Y).

  Local Notation sigPair := (sigPair sigX sigY).

  Definition stopAfterFirst : sigPair^+ -> bool :=
    fun x => match x with
          | inr (sigPair_Y y) => true
          | inl STOP => true
          | _ => false
          end.

  Definition stopAtStart : sigPair^+ -> bool :=
    fun x => match x with
          | inl START => true
          | _ => false
          end.

  Definition CasePair_size0 {sigX X : Type} {cX : codable sigX X} (x : X) (s0 : nat) := s0 + size x.

  Definition CasePair_size1 {sigX X : Type} {cX : codable sigX X} (x : X) (s1 : nat) := s1 - (size x) - 1.

  Definition CasePair_Rel : pRel sigPair^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall (p : X * Y) (s0 s1 : nat),
            tin[@Fin0] ≃(;s0) p ->
            isVoid_size tin[@Fin1] s1 ->
            tout[@Fin0] ≃(;CasePair_size0 (fst p) s0) snd p /\
            tout[@Fin1] ≃(;CasePair_size1 (fst p) s1) fst p
      ).

  Definition CasePair : pTM sigPair^+ unit 2 :=
    LiftTapes (WriteMove (inl STOP) Lmove) [|Fin1|];;
    LiftTapes (MoveToSymbol stopAfterFirst id;; Move Lmove) [|Fin0|];;
    CopySymbols_L stopAtStart;;
    LiftTapes (MoveToSymbol stopAfterFirst id;; Move Lmove;; Write (inl START)) [|Fin0|].

  Lemma CasePair_Realise : CasePair ⊨ CasePair_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold CasePair. TM_Correct. }
    {
      intros tin ((), tout) H.
      intros (x,y) s0 s1 HEncXY HRight.
      destruct HEncXY as (ls&HEncXY&Hs0).
      TMSimp; clear_trivial_eqs. rename H2 into HCopy. cbn in *.
      rewrite map_map, map_app, <- app_assoc in HCopy.
      (* We need a case distinction, whether the encoding of [y] is empty, because [MoveToSymbol] either stops in a symbol of [cY y] or on [inl STOP]. However, both parts of the proof have identical proof scripts. *)
      destruct (cY y) eqn:EY; cbn in *.
      - rewrite MoveToSymbol_correct_midtape in HCopy; cbn in *; auto.
        erewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        + apply pair_eq in HCopy as (HCopy1, HCopy2). TMSimp.
          rewrite MoveToSymbol_correct_midtape; cbn; auto.
          all: rewrite map_id, rev_involutive, List.map_map.
          2:{ now intros ? (?&<-&?) % in_map_iff. }
          split.
          * hnf. eexists. split. simpl_tape. cbn. rewrite EY. cbn. f_equal.
            { rewrite tl_length; simpl_list; cbn. unfold CasePair_size0, size. lia. }
          * hnf. eexists. simpl_tape. rewrite rev_involutive, List.map_map. cbn. f_equal. rewrite (isVoid_size_right HRight). cbn. f_equal. split. now rewrite List.map_map.
            { simpl_list. rewrite skipn_length, tl_length. unfold CasePair_size1, size. pose proof (isVoid_size_left HRight). lia. }
        + rewrite List.map_map. now intros ? (?&<-&?) % in_rev % in_map_iff.
        + rewrite List.map_map. now intros ? (?&<-&?) % in_map_iff.
      - rewrite MoveToSymbol_correct_midtape in HCopy; cbn in *; auto.
        erewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
        + apply pair_eq in HCopy as (HCopy1, HCopy2). TMSimp.
          rewrite MoveToSymbol_correct_midtape; cbn; auto.
          all: rewrite map_id, rev_involutive, List.map_map.
          2:{ now intros ? (?&<-&?) % in_map_iff. }
          split.
          * hnf. eexists. split. simpl_tape. cbn. rewrite EY. cbn. f_equal.
            { rewrite tl_length; simpl_list; cbn. unfold CasePair_size0, size. lia. }
          * hnf. eexists. simpl_tape. rewrite rev_involutive, List.map_map. cbn. f_equal. rewrite (isVoid_size_right HRight). cbn. f_equal. split. now rewrite List.map_map.
            { simpl_list. rewrite skipn_length, tl_length. unfold CasePair_size1, size. pose proof (isVoid_size_left HRight). lia. }
        + rewrite List.map_map. now intros ? (?&<-&?) % in_rev % in_map_iff.
        + rewrite List.map_map. now intros ? (?&<-&?) % in_map_iff.
    }
  Qed.

  Local Arguments plus : simpl never. Local Arguments mult : simpl never.
  Local Arguments size : simpl never.

  Definition CasePair_steps {sigX X : Type} {cX : codable sigX X} (x : X) :=
    34 + 16 * size x.

  Definition CasePair_T : tRel sigPair^+ 2 :=
    fun tin k => exists (p : X * Y), tin[@Fin0] ≃ p /\ CasePair_steps (fst p) <= k.

  Lemma CasePair_Terminates : projT1 CasePair ↓ CasePair_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold CasePair. TM_Correct. }
    {
      intros tin k ((x&y)&HEncP&Hk). unfold CasePair_steps in *. cbn in *.
      exists 1, (32 + 16 * size x). repeat split; try lia.
      intros tmid () ?; TMSimp.
      exists (10 + 4 * size x), (21 + 12 * size x). repeat split; try lia.
      {
        exists (8 + 4 * size x), 1. repeat split; try lia.
        destruct HEncP as (ls&->). cbn. destruct (cY y) eqn:EY.
        - rewrite app_nil_r. rewrite MoveToSymbol_steps_midtape; cbn; auto. now rewrite !map_length.
        - rewrite map_map, map_app, <- app_assoc. cbn.
          rewrite MoveToSymbol_steps_midtape; cbn; auto. now rewrite !map_length.
      }
      intros tmid1 (). intros ?; TMSimp.
      exists (8 + 8 * size x), (12 + 4 * size x). repeat split; try lia.
      {
        destruct HEncP as (ls&->). cbn. destruct (cY y) eqn:EY.
        - rewrite app_nil_r. rewrite MoveToSymbol_correct_midtape; cbn; auto.
          + rewrite CopySymbols_L_steps_moveleft; cbn; auto. now rewrite rev_length, !map_length.
          + rewrite !List.map_map. now intros ? (?&<-&?) % in_map_iff.
        - rewrite map_map, map_app, <- app_assoc. cbn.
          rewrite MoveToSymbol_correct_midtape; cbn; auto.
          + rewrite CopySymbols_L_steps_moveleft; cbn; auto. now rewrite rev_length, !map_length.
          + rewrite List.map_map. now intros ? (?&<-&?) % in_map_iff.
      }
      intros tmid2 () HCopy.
      exists (8 + 4 * size x), 3. repeat split; try lia.
      {
        destruct HEncP as (ls&HEncP); TMSimp. cbn in *. destruct (cY y) eqn:EY.
        - rewrite app_nil_r in HCopy. rewrite MoveToSymbol_correct_midtape in HCopy; cbn in *; auto.
          + rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
            * inv HCopy; TMSimp. rewrite MoveToSymbol_steps_midtape; cbn; auto. now rewrite !rev_length, !map_length.
            * rewrite List.map_map. now intros ? (?&<-&?) % in_rev % in_map_iff.
          + rewrite !List.map_map. now intros ? (?&<-&?) % in_map_iff.
        - rewrite map_map, map_app, <- app_assoc in HCopy. cbn in *. rewrite MoveToSymbol_correct_midtape in HCopy; cbn in *; auto.
          + rewrite CopySymbols_L_correct_moveleft in HCopy; cbn; auto.
            * inv HCopy; TMSimp. rewrite MoveToSymbol_steps_midtape; cbn; auto. now rewrite !rev_length, !map_length.
            * rewrite List.map_map. now intros ? (?&<-&?) % in_rev % in_map_iff.
          + rewrite List.map_map. now intros ? (?&<-&?) % in_map_iff.
      }
      intros tmid3 _ _. exists 1, 1. split. lia. split. lia. intros _ _ _. lia.
    }
  Qed.

  (* ** Constructor *)

  Definition Constr_pair_size {sigX X : Type} {cX : codable sigX X} (x : X) (s1 : nat) := s1 - size x.

  Definition Constr_pair_Rel : pRel sigPair^+ unit 2 :=
    ignoreParam (
        fun tin tout =>
          forall (x : X) (y : Y) (s0 s1 : nat),
            tin[@Fin0] ≃(;s0) x ->
            tin[@Fin1] ≃(;s1) y ->
            tout[@Fin0] ≃(;s0) x /\
            tout[@Fin1] ≃(;Constr_pair_size x s1) (x, y)
      ).

  Definition Constr_pair : pTM sigPair^+ unit 2 :=
    LiftTapes (MoveRight _;; Move Lmove) [|Fin0|];;
    CopySymbols_L stopAtStart.

  Lemma Constr_pair_Realise : Constr_pair ⊨ Constr_pair_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Constr_pair. TM_Correct.
      - apply MoveRight_Realise with (X := X).
    }
    {
      intros tin ((), tout) H. intros x y s0 s1 HEncX HEncY.
      TMSimp; clear_trivial_eqs. rename H into HMoveRight; rename H0 into HCopy.
      modpon HMoveRight. destruct HMoveRight as (ls&HMoveRight&Hs); TMSimp.
      rewrite CopySymbols_L_correct_moveleft in HCopy; cbn in *; auto.
      - apply pair_eq in HCopy as (HCopy1&HCopy2). TMSimp. split.
        + repeat econstructor. cbn. f_equal. now rewrite map_rev, rev_involutive. lia.
        + repeat econstructor. cbn. f_equal. simpl_tape.
          destruct HEncY as (ls'&HEncY&Hs'); TMSimp_goal.
          rewrite map_map, map_rev, rev_involutive. cbn.
          * now rewrite !map_map, map_app, <- app_assoc, !map_map.
          * simpl_list. rewrite skipn_length. unfold Constr_pair_size.
            destruct HEncY as (ls'&HEncY&Hs'). TMSimp. unfold size. lia.
      - rewrite map_rev, List.map_map. now intros ? (?&<-&?) % in_rev % in_map_iff.
    }
  Qed.

  Definition Constr_pair_steps {sigX X : Type} {cX : codable sigX X} (x : X) : nat := 19 + 12 * size x.

  Definition Constr_pair_T : tRel sigPair^+ 2 :=
    fun tin k => exists (x : X), tin[@Fin0] ≃ x /\ Constr_pair_steps x <= k.

  Lemma Constr_pair_Terminates : projT1 Constr_pair ↓ Constr_pair_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Constr_pair. TM_Correct.
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Realise with (X := X).
      - apply MoveRight_Terminates with (X := X).
    }
    {
      intros tin k (x & HEncX & Hk). unfold Constr_pair_steps in *. cbn in *.
      exists (10 + 4 * size x), (8 + 8 * size x). repeat split; try lia.
      {
        exists (8 + 4 * size x), 1. repeat split; try lia.
        eexists. repeat split; eauto.
      }
      intros tmid () ?; TMSimp. modpon H. destruct H as (ls&->&Hs). cbn.
      rewrite CopySymbols_L_steps_moveleft; cbn; auto. now rewrite map_length, rev_length, map_length.
    }
  Qed.

  (* [Snd] simply discard the first element *)

  Definition Snd_size {sigX X : Type} {cX : codable sigX X} (x : X) (s : nat) := s + size x.

  Definition Snd_Rel : pRel sigPair^+ unit 1 :=
    ignoreParam (fun tin tout => forall (p : X*Y) (s : nat), tin[@Fin0] ≃(;s) p -> tout[@Fin0] ≃(; Snd_size (fst p) s) snd p).

  Definition Snd : pTM sigPair^+ unit 1 :=
    MoveToSymbol stopAfterFirst id;;
    Move Lmove;;
    Write (inl START).

  Lemma Snd_Realise : Snd ⊨ Snd_Rel.
  Proof.
    eapply Realise_monotone.
    { unfold Snd. TM_Correct. }
    {
      intros tin ((), tout) H. intros (x,y) s HEncXY.
      destruct HEncXY as (ls&HEncXY).
      TMSimp; clear_trivial_eqs.
      destruct (cY y) eqn:EY.
      - rewrite app_nil_r.
        rewrite MoveToSymbol_correct_midtape; cbn; auto.
        + cbn. simpl_tape. repeat econstructor. cbn. rewrite EY. cbn. f_equal.
          { rewrite tl_length. simpl_list. cbn. unfold Snd_size, size. lia. }
        + rewrite !List.map_map. now intros ? (?&<-&?) % in_map_iff.
      - cbn. rewrite map_map, map_app, <- app_assoc; cbn.
        rewrite MoveToSymbol_correct_midtape; cbn; auto.
        + simpl_tape. repeat econstructor. f_equal. cbn. now rewrite EY.
          { rewrite tl_length. simpl_list. cbn. unfold Snd_size, size. lia. }
        + rewrite List.map_map. now intros ? (?&<-&?) % in_map_iff.
    }
  Qed.

  Definition Snd_steps {sigX X : Type} {cX : codable sigX X} (x : X) := 12 + 4 * size x.

  Definition Snd_T : tRel sigPair^+ 1 :=
    fun tin k => exists p : X*Y, tin[@Fin0] ≃ p /\ Snd_steps (fst p) <= k.

  Lemma Snd_Terminates : projT1 Snd ↓ Snd_T.
  Proof.
    eapply TerminatesIn_monotone.
    { unfold Snd. TM_Correct. }
    {
      intros tin k ((x,y)&HEncP&Hk). unfold Snd_steps in *; cbn in *.
      exists (8+4*size x), 3. repeat split; try lia.
      {
        destruct HEncP as (ls&->). destruct (cY y) eqn:EY; cbn in *.
        - rewrite MoveToSymbol_steps_midtape; cbn; auto. rewrite EY. cbn.
          rewrite map_map, map_length, app_length, map_length. cbn. unfold size. lia.
        - rewrite map_map, map_app, <- app_assoc, EY. cbn.
          rewrite MoveToSymbol_steps_midtape; cbn; auto. now rewrite !map_length.
      }
      intros ? _ _. exists 1, 1. split. reflexivity. split. reflexivity. intros _ _ _. reflexivity.
    }
  Qed.

  (* Case and Cons doesn't allocate new memory *)
  Goal forall (x : X) (s : nat), Constr_pair_size x (CasePair_size0 x s) = s.
  Proof. intros. unfold Constr_pair_size, CasePair_size0. lia. Qed.

End CasePair.

(* ** Compatibility of running time and size functions with mapping of encodings *)

Arguments Constr_pair_size {sigX X cX} : simpl never.
Arguments CasePair_size0   {sigX X cX} : simpl never.
Arguments CasePair_size1   {sigX X cX} : simpl never.

Arguments Constr_pair_steps {sigX X cX} : simpl never.
Arguments CasePair_steps    {sigX X cX} : simpl never.
Arguments CasePair_steps    {sigX X cX} : simpl never.

(* ** Tactic Support *)

Ltac smpl_TM_CasePair :=
  once lazymatch goal with
  | [ |- CasePair _ _ ⊨ _ ] => apply CasePair_Realise
  | [ |- projT1 (CasePair _ _) ↓ _ ] => apply CasePair_Terminates

  | [ |- Constr_pair _ _ ⊨ _ ] => apply Constr_pair_Realise
  | [ |- projT1 (Constr_pair _ _) ↓ _] => apply Constr_pair_Terminates

  | [ |- Snd _ _ ⊨ _ ] => apply Snd_Realise
  | [ |- projT1 (Snd _ _) ↓ _] => apply Snd_Terminates
  end.

Smpl Add smpl_TM_CasePair : TM_Correct.

From Undecidability.TM.Hoare Require Import HoareLogic HoareRegister HoareTactics.
Section CasePair.

  Variable (X Y : Type) (sigX sigY : finType) (codX : codable sigX X) (codY : codable sigY Y).

  Definition Constr_pair_sizefun (x : X) : Vector.t (nat->nat) 2 :=
    [|id; Constr_pair_size x|].

  Lemma Constr_pair_SpecT_size (x : X) (y : Y) (ss : Vector.t nat 2) :
    TripleT (≃≃(([], withSpace  [|Contains _ x; Contains _ y |] ss)))
            (Constr_pair_steps x) (Constr_pair sigX sigY)
            (fun _ => ≃≃(([], withSpace  [|Contains _ x; Contains _ (x,y)|]
                                    (appSize (Constr_pair_sizefun x) ss)))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply Constr_pair_Realise.
    - apply Constr_pair_Terminates.
    - intros tin [] yout H HEnc.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1. simpl_vector in *; cbn in *.
      modpon H. simpl_vector in *. tspec_solve.
    - intros tin k HEnc Hk.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1. simpl_vector in *; cbn in *.
      unfold Constr_pair_T. eauto.
  Qed.

  Definition CasePair_size (p : X*Y) : Vector.t (nat->nat) 2 :=
    [| CasePair_size0 (fst p); CasePair_size1 (fst p) |].

  Lemma CasePair_SpecT_size (p : X*Y) (ss : Vector.t nat 2) :
    TripleT (≃≃(([], withSpace  [|Contains _ p; Void |] ss)))
            (CasePair_steps (fst p)) (CasePair sigX sigY)
            (fun _ => ≃≃(([], withSpace  [|Contains _ (snd p); Contains _ (fst p)|]
                                    (appSize (CasePair_size p) ss)))).
  Proof. unfold withSpace.
    eapply Realise_TripleT.
    - apply CasePair_Realise.
    - apply CasePair_Terminates.
    - intros tin [] tout H HEnc. cbn in *.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1. simpl_vector in *; cbn in *.
      modpon H. simpl_vector in *. tspec_solve.
    - intros tin k HEnc Hk.
      specialize (HEnc Fin0) as HEnc0; specialize (HEnc Fin1) as HEnc1. simpl_vector in *; cbn in *.
      unfold CasePair_T. eauto.
  Qed.

End CasePair.

Ltac hstep_Pair :=
  match goal with
  | [ |- TripleT ?P ?k (Constr_pair _ _) ?Q ] => eapply (Constr_pair_SpecT_size _ _ _ _)
  | [ |- TripleT ?P ?k (CasePair    _ _) ?Q ] => eapply (CasePair_SpecT_size _ _ _)
  end.

Smpl Add hstep_Pair : hstep_Spec.


Require Import Bool List String PeanoNat FinFun.
Require Import Common FMap Syntax Semantics SemFacts Invariant.

Set Implicit Arguments.

Open Scope list.

Section Simulation.
  Context `{dv: DecValue}
          {SystemI StateI LabelI SystemS StateS LabelS: Type}
          `{HasInit SystemI StateI} `{@HasLabel dv LabelI}
          `{HasInit SystemS StateS} `{@HasLabel dv LabelS}.
  Variables (stepI: Step SystemI StateI LabelI) (stepS: Step SystemS StateS LabelS)
            (sim: StateI -> StateS -> Prop).

  Local Infix "≈" := sim (at level 30).

  Variables (impl: SystemI) (spec: SystemS).

  Definition Simulates :=
    forall ist1 sst1,
      ist1 ≈ sst1 ->
      forall ilbl ist2,
        stepI impl ist1 ilbl ist2 ->
        exists slbl sst2,
          getLabel ilbl = getLabel slbl /\
          stepS spec sst1 slbl sst2 /\
          ist2 ≈ sst2.

  Hypothesis (Hsim: Simulates).

  Lemma simulation_steps:
    forall ist1 sst1,
      ist1 ≈ sst1 ->
      forall ihst ist2,
        steps stepI impl ist1 ihst ist2 ->
        exists sst2 shst,
          steps stepS spec sst1 shst sst2 /\
          behaviorOf ihst = behaviorOf shst /\
          ist2 ≈ sst2.
  Proof.
    induction 2; simpl; intros;
      [exists sst1, nil; repeat split; auto; constructor|].

    specialize (IHsteps H3).
    destruct IHsteps as [sst2 [shst [? [? ?]]]].

    eapply Hsim in H5; [|exact H8].

    destruct H5 as [slbl [sst3 ?]]; dest.
    eexists; eexists (_ :: _); repeat split; eauto.
    - econstructor; eauto.
    - simpl; congruence.
  Qed.

  Hypothesis (Hsimi: sim (initsOf impl) (initsOf spec)).

  Theorem simulation_implies_refinement:
    (steps stepI) # (steps stepS) |-- impl ⊑ spec.
  Proof.
    unfold Simulates, Refines; intros.
    inv H3.
    eapply simulation_steps in H4; [|exact Hsimi].
    destruct H4 as [sst2 [shst [? [? ?]]]].
    econstructor; eauto.
  Qed.

End Simulation.

Section InvSim.
  Context `{dv: DecValue}
          {SystemI StateI LabelI SystemS StateS LabelS: Type}
          `{HasInit SystemI StateI} `{@HasLabel dv LabelI}
          `{HasInit SystemS StateS} `{@HasLabel dv LabelS}.
  Variables (stepI: Step SystemI StateI LabelI) (stepS: Step SystemS StateS LabelS)
            (ginv: StateI -> Prop)
            (sim: StateI -> StateS -> Prop).

  Local Infix "≈" := sim (at level 30).

  Variables (impl: SystemI) (spec: SystemS).

  Definition InvSim :=
    forall ist1 sst1,
      Reachable (steps stepI) impl ist1 ->
      ist1 ≈ sst1 ->
      ginv ist1 ->
      forall ilbl ist2,
        stepI impl ist1 ilbl ist2 -> ginv ist2 ->
        exists slbl sst2,
          getLabel ilbl = getLabel slbl /\
          stepS spec sst1 slbl sst2 /\
          ist2 ≈ sst2.

  Hypotheses (Hsim: InvSim)
             (Hinv: InvStep impl stepI ginv)
             (Hsimi: sim (initsOf impl) (initsOf spec))
             (Hinvi: ginv (initsOf impl)).

  Lemma inv_simulation_steps:
    forall ihst ist1 ist2,
      ist1 = initsOf impl ->
      steps stepI impl ist1 ihst ist2 ->
      exists sst2 shst,
        steps stepS spec (initsOf spec) shst sst2 /\
        behaviorOf ihst = behaviorOf shst /\
        ist2 ≈ sst2.
  Proof.
    induction 2; simpl; intros; subst;
      [exists (initsOf spec), nil; repeat split; auto; constructor|].

    specialize (IHsteps eq_refl).
    destruct IHsteps as [sst2 [shst [? [? ?]]]].

    assert (ginv st3).
    { eapply inv_steps with (stepI:= stepI) (impl:= impl); eauto.
      econstructor; eauto.
    }

    eapply Hsim in H5;
      [|red; eauto
       |eassumption
       |eapply inv_steps with (LabelI:= LabelI); eassumption].
    specialize (H5 H8).
    destruct H5 as [slbl [sst3 ?]]; dest.

    eexists; eexists (_ :: _); repeat split; eauto.
    - econstructor; eauto.
    - simpl; congruence.
  Qed.

  Theorem invSim_implies_refinement:
    (steps stepI) # (steps stepS) |-- impl ⊑ spec.
  Proof.
    unfold Simulates, Refines; intros.
    inv H3.
    eapply inv_simulation_steps in H4; [|reflexivity].
    destruct H4 as [sst2 [shst [? [? ?]]]].
    econstructor; eauto.
  Qed.

End InvSim.

Section InvRSim.
  Context `{dv: DecValue}
          {SystemI StateI LabelI SystemS StateS LabelS: Type}
          `{HasInit SystemI StateI} `{@HasLabel dv LabelI}
          `{HasInit SystemS StateS} `{@HasLabel dv LabelS}.
  Variables (stepI: Step SystemI StateI LabelI) (stepS: Step SystemS StateS LabelS)
            (ginv: StateI -> Prop)
            (sim: StateI -> StateS -> Prop).

  Local Infix "≈" := sim (at level 30).

  Variables (impl: SystemI) (spec: SystemS).

  Hypotheses (Hinv: InvReachable impl stepI ginv)
             (Hsimi: sim (initsOf impl) (initsOf spec))
             (Hsim: InvSim stepI stepS ginv sim impl spec).

  Lemma invR_simulation_steps:
    forall ihst ist1 ist2,
      ist1 = initsOf impl ->
      steps stepI impl ist1 ihst ist2 ->
      exists sst2 shst,
        steps stepS spec (initsOf spec) shst sst2 /\
        behaviorOf ihst = behaviorOf shst /\
        ist2 ≈ sst2.
  Proof.
    induction 2; simpl; intros; subst;
      [exists (initsOf spec), nil; repeat split; auto; constructor|].

    specialize (IHsteps eq_refl).
    destruct IHsteps as [sst2 [shst [? [? ?]]]].

    assert (ginv st2) by (eapply Hinv; econstructor; eauto).
    assert (ginv st3).
    { eapply Hinv.
      eapply reachable_steps;
        [|eapply StepsCons; [eapply StepsNil|eassumption]].
      econstructor; eauto.
    }

    eapply Hsim in H5; [|red; eauto|eassumption|assumption].
    specialize (H5 H9).
    destruct H5 as [slbl [sst3 ?]]; dest.

    eexists; eexists (_ :: _); repeat split; eauto.
    - econstructor; eauto.
    - simpl; congruence.
  Qed.

  Theorem invRSim_implies_refinement:
    (steps stepI) # (steps stepS) |-- impl ⊑ spec.
  Proof.
    unfold Simulates, Refines; intros.
    inv H3.
    eapply invR_simulation_steps in H4; [|reflexivity].
    destruct H4 as [sst2 [shst [? [? ?]]]].
    econstructor; eauto.
  Qed.

End InvRSim.

Definition liftSim `{dv: DecValue} {iifc sifc: OStateIfc}
           (ossSim: @OStates iifc -> @OStates sifc -> Prop):
  @State dv iifc -> @State dv sifc -> Prop :=
  fun ist sst => ossSim (st_oss ist) (st_oss sst).

Close Scope list.


Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.ListUtil.NthExt.
Require Import Crypto.Util.Notations.

Module Option.
  Module List.
    Section map.
      Context {A B}
              (f : A -> option B).

      Fixpoint map (ls : list A) : list B
        := match ls with
           | nil => nil
           | cons x xs
             => match f x with
               | Some fx => fx :: map xs
               | None => map xs
               end
           end.
    End map.

    Fixpoint bind_list {A B} (v : list (option A)) (f : list A -> option B) : option B
      := match v with
         | nil => f nil
         | x :: xs => (x <- x; @bind_list A B xs (fun xs => f (x :: xs)))
         end%option%list.

    Definition lift {A} (ls : list (option A)) : option (list A)
      := fold_right (fun x xs => x <- x; xs <- xs; Some (x :: xs))%option
                    (Some nil)
                    ls.

    Lemma bind_list_cps_id {A B} v f
      : @bind_list A B v f = (v <- bind_list v (@Some _); f v)%option.
    Proof.
      revert B f; induction v as [|[x|] xs IHxs]; cbn; try reflexivity.
      intros; etransitivity; rewrite IHxs; [ | reflexivity ]; edestruct bind_list; reflexivity.
    Qed.

    Lemma eq_bind_list_lift {A} (ls : list (option A))
      : lift ls = bind_list ls (@Some _).
    Proof.
      cbv [lift]; induction ls as [|[x|] xs IHxs]; cbn; try reflexivity.
      rewrite IHxs; etransitivity; [ | rewrite bind_list_cps_id; reflexivity ].
      reflexivity.
    Qed.

    Lemma lift_Some_nth_error_all {A} ol l (H : @lift A ol = Some l)
      : forall i a, nth_error l i = Some a -> nth_error ol i = Some (Some a).
    Proof.
      cbv [lift] in *; revert dependent l; induction ol as [|x xs IHxs], l as [|y ys], i as [|i]; cbn in *; try congruence;
        intros; inversion_option; subst; destruct_head' option; cbn in *; try congruence.
      all: edestruct fold_right; cbn in *; inversion_option; specialize (IHxs _ eq_refl).
      all: match goal with H : cons _ _ = cons _ _ |- _ => inversion H; clear H; subst end.
      all: auto.
    Qed.

    Lemma lift_Some_nth_error_all_iff {A} ol l
      : @lift A ol = Some l
        <-> (List.length ol = List.length l
             /\ forall i a, nth_error l i = Some a -> nth_error ol i = Some (Some a)).
    Proof.
      cbv [lift] in *; revert dependent l; induction ol as [|x xs IHxs], l as [|y ys].
      all: repeat first [ apply conj
                        | progress inversion_option
                        | progress destruct_head'_and
                        | progress subst
                        | progress cbn in *
                        | progress intros
                        | congruence
                        | progress destruct_head' option
                        | solve [ eauto ]
                        | match goal with
                          | [ H : nth_error nil ?i = _ |- _ ] => is_var i; destruct i
                          | [ H : nth_error (cons _ _) ?i = _ |- _ ] => is_var i; destruct i
                          | [ H : cons _ _ = cons _ _ |- _ ] => inversion H; clear H
                          | [ H : forall x, Some ?y = Some x <-> _ |- _ ] => specialize (H y)
                          | [ H : ?x = ?x <-> _ |- _ ] => destruct H
                          | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
                          | [ H : _ -> ?x = ?x |- _ ] => clear H
                          | [ H : S _ = S _ |- _ ] => inversion H; clear H
                          | [ H : forall l, _ -> None = Some _ |- _ ] => specialize (H _ ltac:(eauto))
                          | [ H : forall i a, nth_error (cons _ _) i = _ -> _ |- _ ]
                            => pose proof (H 0 _ eq_refl); specialize (fun i => H (S i))
                          | [ |- Some (?x :: ?xs) = Some (?x :: ?ys) ] => (do 2 apply f_equal)
                          end
                        | match goal with
                          | [ H : context[@fold_right ?A ?B ?f ?init ?ls] |- _ ] => destruct (@fold_right A B f init ls)
                          end
                        | progress split_iff ].
      { unshelve eapply nth_ext; try eassumption; try congruence.
        intros n Hn; rewrite <- !nth_default_eq; cbv [nth_default].
        repeat match goal with H : forall i : nat, _ |- _ => specialize (H n) end.
        break_match.
        all: repeat match goal with H : forall a, Some ?x = Some a -> _ |- _ => specialize (H _ eq_refl) end.
        all: try congruence.
        all: repeat match goal with H : nth_error _ _ = None |- _ => rewrite nth_error_None in H end.
        all: try lia. }
    Qed.

    Lemma lift_None_nth_error_iff {A} ol
      : @lift A ol = None <-> exists j, nth_error ol j = Some None.
    Proof.
      cbv [lift]; induction ol as [|[x|] xs IHxs].
      all: repeat first [ progress cbn in *
                        | apply conj
                        | congruence
                        | progress intros
                        | progress destruct_head'_ex
                        | progress split_iff
                        | eexists (S _); cbn; eassumption
                        | exists 0; reflexivity
                        | progress specialize_by eauto
                        | match goal with
                          | [ H : nth_error nil ?i = _ |- _ ] => is_var i; destruct i
                          | [ H : nth_error (cons _ _) ?i = _ |- _ ] => is_var i; destruct i
                          | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
                          end
                        | match goal with
                          | [ H : context[@fold_right ?A ?B ?f ?init ?ls] |- _ ] => destruct (@fold_right A B f init ls)
                          end ].
    Qed.

    Module Export Notations.
      Notation "A <-- X ; B" := (bind_list X (fun A => B%option)) : option_scope.
    End Notations.
  End List.
End Option.

Export Option.List.Notations.

Lemma fold_right_option_seq A B f init ls v
  : List.fold_right (fun x y => x <- x; y <- y; Some (f x y))%option (Some init) ls = Some v
    <-> exists ls', List.map (@Some _) ls' = ls
                    /\ @List.fold_right A B f init ls' = v.
Proof.
  revert v; induction ls as [|x xs IHxs]; cbn; intros;
    repeat first [ apply conj
                 | progress intros
                 | progress subst
                 | progress cbn in *
                 | solve [ try (exists nil); cbn; auto ]
                 | congruence
                 | match goal with
                   | [ x : option _ |- _ ] => destruct x
                   | [ H : ex _ |- _ ] => destruct H
                   | [ H : and _ _ |- _ ] => destruct H
                   | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
                   | [ H : cons _ _ = cons _ _ |- _ ] => inversion H; clear H
                   | [ H : List.map _ ?x = nil |- _ ] => is_var x; destruct x
                   | [ H : List.map _ ?x = cons _ _ |- _ ] => is_var x; destruct x
                   | [ H : forall v, iff _ _ |- _ ]
                     => pose proof (fun v => proj1 (H v)); pose proof (fun v => proj2 (H v)); clear H
                   | [ |- iff _ _ ] => split
                   | [ |- context[Option.bind ?x ?y] ] => destruct x eqn:?
                   | [ H : context[Option.bind ?x ?y] |- _ ] => destruct x eqn:?
                   | [ H : forall v, _ = _ -> _ |- _ ] => specialize (H _ ltac:(eassumption || reflexivity))
                   | [ H : forall v, (exists y, _ = _ /\ _ = _) -> _ |- _ ] => specialize (H _ ltac:(eexists; split; reflexivity))
                   | [ |- exists ls', List.map ?f ls' = (?f ?x :: List.map ?f ?xs)%list /\ _ ]
                     => exists (cons x xs)
                   end ].
Qed.