(** Interpretation of endpoints in 1-types *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.

Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Base.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map1Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Map2Cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Identitor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.Compositor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Constant.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Transformations.Examples.Whiskering.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.

Local Open Scope cat.

Definition sem_homot_endpoint_one_types
           {A : poly_code}
           {J : UU}
           {S : J → poly_code}
           {l : ∏ (j : J), endpoint A (S j) I}
           {r : ∏ (j : J), endpoint A (S j) I}
           {Q : poly_code}
           {TR : poly_code}
           {al ar : endpoint A Q TR}
           {T : poly_code}
           {sl sr : endpoint A Q T}
           (p : homot_endpoint l r al ar sl sr)
           (X : total_bicat (disp_alg_bicat (⟦ A ⟧)))
           (pX : ∏ (i : J),
                 sem_endpoint_one_types (l i) X
                 ~
                 sem_endpoint_one_types (r i) X)
           (z : poly_act Q (pr1 X : one_type))
           (p_arg : sem_endpoint_one_types al X z = sem_endpoint_one_types ar X z)
  : sem_endpoint_one_types sl X z = sem_endpoint_one_types sr X z
  := sem_homot_endpoint_UU p (pr1 X : one_type) (pr2 X) pX z p_arg.

(** Bicategory of prealgebras *)
Definition hit_prealgebra_one_types
           (Σ : hit_signature)
  : bicat
  := total_bicat (disp_alg_bicat (⟦ point_constr Σ ⟧)).

(** Projections and builders of prealgebras *)
Section HITPreAlgebraProjections.
  Context {Σ : hit_signature}
          (X : hit_prealgebra_one_types Σ).

  Definition prealg_carrier
    : one_type
    := pr1 X.

  Definition prealg_constr
    : poly_act (point_constr Σ) prealg_carrier → prealg_carrier
    := pr2 X.
End HITPreAlgebraProjections.

Arguments prealg_constr {_ _} _.

Definition make_hit_prealgebra
           {Σ : hit_signature}
           (X : UU)
           (HX : isofhlevel 3 X)
           (f : poly_act (point_constr Σ) X → X)
  : hit_prealgebra_one_types Σ.
Proof.
  use tpair.
  - use make_one_type.
    + exact X.
    + exact HX.
  - exact f.
Defined.

Definition preserves_point
           {Σ : hit_signature}
           {X Y : hit_prealgebra_one_types Σ}
           (f : prealg_carrier X → prealg_carrier Y)
  : UU
  := ∏ (x : poly_act (point_constr Σ) (prealg_carrier X)),
     f (prealg_constr x)
     =
     prealg_constr (poly_map (point_constr Σ) f x).

Section HITPreAlgebraMorProjections.
  Context {Σ : hit_signature}
          {X Y : hit_prealgebra_one_types Σ}
          (f : X --> Y).

  Definition prealg_map_carrier
    : prealg_carrier X → prealg_carrier Y
    := pr1 f.

  Definition prealg_map_commute
    : preserves_point prealg_map_carrier
    := pr12 f.
End HITPreAlgebraMorProjections.

Definition make_hit_prealgebra_mor
           {Σ : hit_signature}
           {X Y : hit_prealgebra_one_types Σ}
           (f : prealg_carrier X → prealg_carrier Y)
           (Hf : preserves_point f)
  : X --> Y.
Proof.
  use tpair.
  - exact f.
  - use make_invertible_2cell.
    + exact Hf.
    + apply one_type_2cell_iso.
Defined.

(** Path Algebras for a HIT signature *)
Definition hit_path_algebra_disp_one_types
           (Σ : hit_signature)
  : disp_bicat (hit_prealgebra_one_types Σ)
  := disp_depprod_bicat
       (path_label Σ)
       (λ j, add_cell_disp_cat
               _ _ _
               (sem_endpoint_one_types (path_left Σ j))
               (sem_endpoint_one_types (path_right Σ j))).

Definition hit_path_algebra_one_types
           (Σ : hit_signature)
  : bicat
  := total_bicat (hit_path_algebra_disp_one_types Σ).

(** Projections *)
Section HITPathAlgebraProjections.
  Context {Σ : hit_signature}
          (X : hit_path_algebra_one_types Σ).

  Definition path_alg_carrier
    : one_type
    := prealg_carrier (pr1 X).

  Definition path_alg_constr
    : poly_act (point_constr Σ) path_alg_carrier → path_alg_carrier
    := @prealg_constr _ (pr1 X).

  Definition path_alg_path
             (j : path_label Σ)
             (x : poly_act (path_source Σ j) path_alg_carrier)
    : sem_endpoint_one_types (path_left Σ j) (pr1 X) x
      =
      sem_endpoint_one_types (path_right Σ j) (pr1 X) x
    := pr2 X j x.
End HITPathAlgebraProjections.

Arguments path_alg_constr {_ _} _.

Definition make_hit_path_algebra
           {Σ : hit_signature}
           (X : hit_prealgebra_one_types Σ)
           (pX : ∏ (j : path_label Σ)
                   (x : poly_act (path_source Σ j) (prealg_carrier X)),
                 sem_endpoint_one_types (path_left Σ j) _ x
                 =
                 sem_endpoint_one_types (path_right Σ j) _ x)
  : hit_path_algebra_one_types Σ.
Proof.
  use tpair.
  - exact X.
  - exact pX.
Defined.

Definition preserves_path
           {Σ : hit_signature}
           {X Y : hit_path_algebra_one_types Σ}
           (f : pr1 X --> pr1 Y)
           (Hf : preserves_point (pr1 f))
  : UU
  := ∏ (j : path_label Σ)
       (x : poly_act (path_source Σ j) (path_alg_carrier X)),
     maponpaths (prealg_map_carrier f) (path_alg_path X j x)
     @ sem_endpoint_UU_natural (path_right Σ j) Hf x
     =
     sem_endpoint_UU_natural (path_left Σ j) Hf x
     @ path_alg_path Y j (poly_map (path_source Σ j) _ x).

Section HITPathAlgebraMorProjections.
  Context {Σ : hit_signature}
          {X Y : hit_path_algebra_one_types Σ}
          (f : X --> Y).

  Definition path_alg_map_carrier
    : path_alg_carrier X → path_alg_carrier Y
    := prealg_map_carrier (pr1 f).

  Definition path_alg_map_commute
    : ∏ (x : poly_act (point_constr Σ) (path_alg_carrier X)),
      path_alg_map_carrier (path_alg_constr x)
      =
      path_alg_constr (poly_map (point_constr Σ) path_alg_map_carrier x)
    := prealg_map_commute (pr1 f).

  Definition path_alg_map_path
    : preserves_path (pr1 f) path_alg_map_commute
    := λ j x, eqtohomot (pr2 f j) x.
End HITPathAlgebraMorProjections.

Definition make_hit_path_alg_map
           {Σ : hit_signature}
           {X Y : hit_path_algebra_one_types Σ}
           (f : pr1 X --> pr1 Y)
           (pf : preserves_path _ (prealg_map_commute f))
  : X --> Y
  := f ,, λ i, funextsec _ _ _ (pf i).

(** HIT algebras *)
Definition is_hit_algebra_one_types
           (Σ : hit_signature)
           (X : hit_path_algebra_one_types Σ)
  : UU
  := ∏ (j : homot_label Σ)
       (x : ⟦ homot_point_arg Σ j ⟧ (pr11 X) : one_type)
       (p : sem_endpoint_one_types (homot_path_arg_left Σ j) (pr1 X) x
            =
            sem_endpoint_one_types (homot_path_arg_right Σ j) (pr1 X) x),
     sem_homot_endpoint_one_types
       (homot_left_path Σ j) (pr1 X) (pr2 X) x p
     =
     sem_homot_endpoint_one_types
       (homot_right_path Σ j) (pr1 X) (pr2 X) x p.

Definition isaprop_is_hit_algebra_one_types
           (Σ : hit_signature)
           (X : hit_path_algebra_one_types Σ)
  : isaprop (is_hit_algebra_one_types Σ X).
Proof.
  do 3 (use impred ; intro).
  exact (one_type_isofhlevel (pr11 X) _ _ _ _).
Defined.

Definition hit_algebra_one_types
           (Σ : hit_signature)
  : bicat
  := fullsubbicat (hit_path_algebra_one_types Σ) (is_hit_algebra_one_types Σ).

(** Projections *)
Section HITAlgebraProjections.
  Context {Σ : hit_signature}
          (X : hit_algebra_one_types Σ).

  Definition alg_carrier
    : UU
    := path_alg_carrier (pr1 X).

  Definition alg_constr
    : poly_act (point_constr Σ) alg_carrier → alg_carrier
    := @path_alg_constr _ (pr1 X).

  Definition alg_path
             (j : path_label Σ)
             (x : poly_act (path_source Σ j) alg_carrier)
    : sem_endpoint_one_types (path_left Σ j) _ x
      =
      sem_endpoint_one_types (path_right Σ j) _ x
    := path_alg_path (pr1 X) j x.

  Definition alg_homot
    : is_hit_algebra_one_types Σ (pr1 X)
    := pr2 X.
End HITAlgebraProjections.

Definition make_algebra
           {Σ : hit_signature}
           (X : hit_path_algebra_one_types Σ)
           (hX : is_hit_algebra_one_types Σ X)
  : hit_algebra_one_types Σ
  := X ,, hX.

(** Projections of algebra maps *)
Section HITAlgebraMapProjections.
  Context {Σ : hit_signature}
          {X Y : hit_algebra_one_types Σ}
          (f : X --> Y).

  Definition alg_map_carrier
    : alg_carrier X → alg_carrier Y
    := path_alg_map_carrier (pr1 f).

  Definition alg_map_commute
    : preserves_point alg_map_carrier
    := path_alg_map_commute (pr1 f).

  Definition alg_map_path
    : preserves_path _ alg_map_commute
    := path_alg_map_path (pr1 f).
End HITAlgebraMapProjections.

Definition make_algebra_map
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           (f : pr1 X --> pr1 Y)
  : X --> Y
  := f ,, tt.

Definition is_algebra_2cell
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           (α : alg_map_carrier f ~ alg_map_carrier g)
  : UU
  := ∏ (z : poly_act (point_constr Σ) (alg_carrier X)),
     α (alg_constr X z)
     @ alg_map_commute g z
     =
     alg_map_commute f z
     @ maponpaths (alg_constr Y) (poly_homot (point_constr Σ) α z).

(** Projections of algebra 2-cells *)
Section HITAlgebraCellProjections.
  Context {Σ : hit_signature}
          {X Y : hit_algebra_one_types Σ}
          {f g : X --> Y}
          (α : f ==> g).

  Definition alg_2cell_carrier
    : alg_map_carrier f ~ alg_map_carrier g
    := pr111 α.

  Definition alg_2cell_commute
    : is_algebra_2cell alg_2cell_carrier
    := eqtohomot (pr211 α).
End HITAlgebraCellProjections.

(** Equality of algebra 2-cells *)
Definition algebra_2cell_eq
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           {α β : f ==> g}
           (p : alg_2cell_carrier α ~ alg_2cell_carrier β)
  : α = β.
Proof.
  use subtypePath.
  { intro ; apply isapropunit. }
  use subtypePath.
  { intro ; use impred ; intro ; apply isapropunit. }
  use subtypePath.
  { intro ; apply one_types. }
  use funextsec.
  exact p.
Qed.

Definition alg_2cell_eq_component
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           {α β : f ==> g}
           (p : α = β)
  : alg_2cell_carrier α ~ alg_2cell_carrier β.
Proof.
  exact (eqtohomot (maponpaths (λ z, pr111 z) p)).
Qed.

(** Builder of 2-cells of algebras *)
Definition make_algebra_2cell
           {Σ : hit_signature}
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           (α : alg_map_carrier f ~ alg_map_carrier g)
           (Hα : is_algebra_2cell α)
  : f ==> g.
Proof.
  simple refine (((α ,, _) ,, λ _, tt) ,, tt).
  abstract (use funextsec ; exact Hα).
Defined.

(** Univalence of the bicategory of algebras *)
Definition is_univalent_2_hit_algebra_one_types
           (Σ : hit_signature)
  : is_univalent_2 (hit_algebra_one_types Σ).
Proof.
  use is_univalent_2_fullsubbicat.
  - use total_is_univalent_2.
    + split.
      * use disp_depprod_univalent_2_0.
        ** use total_is_univalent_2_1.
           *** apply one_types_is_univalent_2_1.
           *** apply disp_alg_bicat_univalent_2_1.
        ** intro i.
           apply add_cell_disp_cat_univalent_2_1.
        ** intro i.
           use add_cell_disp_cat_univalent_2_0.
           *** apply one_types_is_univalent_2_1.
           *** apply disp_alg_bicat_univalent_2_1.
      * use disp_depprod_univalent_2_1.
        intro i.
        apply add_cell_disp_cat_univalent_2_1.
    + split.
      * use total_is_univalent_2_0.
        ** apply one_types_is_univalent_2_0.
        ** apply disp_alg_bicat_univalent_2_0.
           apply one_types_is_univalent_2_1.
      * use total_is_univalent_2_1.
        ** apply one_types_is_univalent_2_1.
        ** apply disp_alg_bicat_univalent_2_1.
  - exact (isaprop_is_hit_algebra_one_types Σ).
Defined.

Definition hit_prealg_is_invertible_2cell_one_type
           (Σ : hit_signature)
           {X Y : hit_prealgebra_one_types Σ}
           {f g : X --> Y}
           (α : f ==> g)
  : is_invertible_2cell α.
Proof.
  use is_invertible_disp_to_total.
  use tpair.
  - apply one_type_2cell_iso.
  - exact (disp_locally_groupoid_alg
             (⟦ point_constr Σ ⟧)
             (pr1 X) (pr1 Y)
             (pr1 f) (pr1 g)
             (make_invertible_2cell
                (one_type_2cell_iso _ _ _ _ (pr1 α)))
             (pr2 X) (pr2 Y)
             (pr2 f) (pr2 g)
             (pr2 α)).
Defined.

Definition hit_path_alg_is_invertible_2cell_one_type
           (Σ : hit_signature)
           {X Y : hit_path_algebra_one_types Σ}
           {f g : X --> Y}
           (α : f ==> g)
  : is_invertible_2cell α.
Proof.
  use is_invertible_disp_to_total.
  use tpair.
  - apply hit_prealg_is_invertible_2cell_one_type.
  - exact (disp_locally_groupoid_depprod
             (path_label Σ)
             (λ i, add_cell_disp_cat _ _ _ _ _)
             (λ i, disp_locally_groupoid_add_cell _ _ _ _ _)
             (pr1 X) (pr1 Y)
             (pr1 f) (pr1 g)
             (make_invertible_2cell
                (hit_prealg_is_invertible_2cell_one_type Σ (pr1 α)))
             (pr2 X) (pr2 Y)
             (pr2 f) (pr2 g)
             (pr2 α)).
Defined.

Definition hit_alg_is_invertible_2cell_one_type
           (Σ : hit_signature)
           {X Y : hit_algebra_one_types Σ}
           {f g : X --> Y}
           (α : f ==> g)
  : is_invertible_2cell α.
Proof.
  apply bicat_is_invertible_2cell_to_fullsub_is_invertible_2cell.
  apply hit_path_alg_is_invertible_2cell_one_type.
Defined.


Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
Require Import malloc.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import VSU_malloc_definitions.
Local Open Scope logic.
(*
Definition Gprog : funspecs := external_specs ++ private_specs.
*)
Lemma body_malloc_small:  semax_body MF_Vprog MF_Gprog f_malloc_small malloc_small_spec.
Proof.
start_function.
rewrite <- seq_assoc.
forward_call n. (*! t'1 = size2bin(nbytes) !*)
(*rep_lia.*)
forward. (*! b = t'1 !*)
set (b:=size2binZ n).
assert (Hprednat: forall m, m > 0 -> Nat.pred(Z.to_nat m) = Z.to_nat(Z.pred m))
  by (intros; rewrite Z2Nat.inj_pred; reflexivity).
assert_PROP(Zlength rvec = BINS) as Hlrvec. {
  unfold mem_mgr_R; Intros bins idxs lens.
  entailer!. autorewrite with sublist in *. rep_lia.
}
(* Now we split cases on whether success is guaranteed.
   This which simplifies establishing the different cases in postcondition,
   but comes at the cost of two symbolic executions. *)
destruct (guaranteed rvec n) eqn: Hguar.

* (*+ case guaranteed *)
assert (Hb: 0 <= b < BINS) by (apply (claim2 n); lia).
rewrite (mem_mgr_split_R gv b rvec) by apply Hb.
Intros bins idxs lens.
freeze [1; 3] Otherlists.
deadvars!.
apply is_guaranteed in Hguar.
assert (0 < Znth b lens)%nat. {
  subst b lens. autorewrite with sublist.
  change 0%nat with (Z.to_nat 0%Z).
  apply Z2Nat.inj_lt; rep_lia.
}
assert_PROP (Znth b bins <> nullval) as Hnonnull. {
  sep_apply (mmlist_ne_nonnull (bin2sizeZ b) (Znth b lens) (Znth b bins)).
  entailer!.
}
forward. (*! p = bin[b] !*)
forward_if( (*! if p == null *)
     PROP()
     LOCAL(temp _p (Znth b bins); temp _b (Vint (Int.repr b)); gvars gv)
     SEP(FRZL Otherlists; TT;
         data_at Ews (tarray (tptr tvoid) BINS) bins (gv _bin);
         mmlist (bin2sizeZ b) (Znth b lens) (Znth b bins) nullval)).
  + (* branch p==NULL *) contradiction.
  + (* branch p<>NULL *)
    forward. (*! skip *)
    entailer!.
  + (* after if: unroll and pop mmlist *)
    set (p:=Znth b bins) in *. (* TODO clumsy, just to reuse old steps *)
    set (len:=Z.of_nat(Znth b lens)) in *.
    set (s:=bin2sizeZ b).
    assert_PROP (len > 0).
    { replace (Znth b lens) with (Z.to_nat len);
        try (subst len; rewrite nat_of_Z_eq; reflexivity).
      sep_apply (mmlist_ne_len s len p nullval); auto. entailer!.  }
    assert_PROP (isptr p).
    { entailer!. unfold nullval in *.
      match goal with | HA: p <> _ |- _ => simpl in HA end. (* not Archi.ptr64 *)
      unfold is_pointer_or_null in *. simpl in *.
      destruct p; try contradiction; simpl.
      subst. contradiction. auto. }
    replace (Znth b lens) with (Z.to_nat len); try rep_lia.
    rewrite (mmlist_unroll_nonempty s (Z.to_nat len) p);
      try (subst len; rewrite nat_of_Z_eq; assumption).
    Intros q.
    assert_PROP(force_val (sem_cast_pointer p) = field_address (tptr tvoid) [] p).
    { entailer!. unfold field_address. if_tac. normalize. contradiction. }
    forward. (*! q = *p !*)
    forward. (*! bin[b]=q !*)
    (* prepare token+chunk to return *)
    deadvars!.
    thaw Otherlists.
    sep_apply (to_malloc_token'_and_block n p q s); try rep_lia.
    (* refold invariant *)
    assert (Hrveclen: Zlength rvec = BINS) by
        (subst lens; rewrite Zlength_map in H1; rep_lia).
    set (rvec':= add_resvec rvec b (-1)).
    set (lens':= map Z.to_nat rvec').
    set (bins':=(upd_Znth b bins (force_val (sem_cast_pointer q)))).
    assert (Hlens: Nat.pred (Z.to_nat len) = (Znth b lens')).
    { unfold lens'.
      unfold len.
      rewrite nat_of_Z_eq.
      unfold rvec'.
      rewrite Znth_map; try (rewrite Zlength_add_resvec; rep_lia).
      unfold add_resvec.
      simple_if_tac' Htest.
      -- rewrite upd_Znth_same; try rep_lia.
         replace (Znth b lens) with (Z.to_nat(Znth b rvec))
           by (subst lens; rewrite Znth_map; lia).
         rewrite Hprednat. rep_lia. unfold b; lia.
      --  bdestruct (Zlength rvec =? BINS); [ | rep_lia].
            bdestruct (0 <=? b); [ | rep_lia].
            bdestruct (b <? BINS); [ |rep_lia].
            inv Htest.
    }
    rewrite Hlens.
    change s with (bin2sizeZ b).
    forward. (*! return p !*)
    set (lens := map Z.to_nat rvec).
    Exists p. entailer!.
    unfold mem_mgr_R.
    Exists bins'.
    set (idxs:= (map Z.of_nat (seq 0 (Z.to_nat BINS)))).
    Exists idxs.
    Exists lens'.
    cancel.
    entailer!.
    { split.
      subst lens'. subst rvec'. rewrite Zlength_map. rewrite Zlength_add_resvec. rep_lia.
      apply add_resvec_no_neg; auto.
      rep_lia.
    }
    (* fold mem_mgr *)
    assert (Zlength lens = BINS) by (unfold lens; rewrite Zlength_map; rep_lia).
    assert (Zlength lens' = BINS) by (unfold lens'; rewrite Zlength_map;
                                      unfold rvec'; rewrite Zlength_add_resvec; rep_lia).
    assert (Zlength bins' = BINS) by
        (replace (Zlength bins') with BINS by auto; reflexivity).
    assert (Zlength idxs = BINS) by auto.
    assert (Hbins': sublist 0 b bins' = sublist 0 b bins) by
      (unfold bins'; rewrite sublist_upd_Znth_l; try reflexivity; try rep_lia).
    assert (Hlens': sublist 0 b lens' = sublist 0 b lens).
    { unfold lens'; unfold lens; unfold rvec'.
      do 2 rewrite sublist_map; f_equal.
      unfold add_resvec.
      simple_if_tac''; auto.
      rewrite sublist_upd_Znth_l; try rep_lia; auto.  }
    assert (Hbins'': sublist (b+1) BINS bins' = sublist (b+1) BINS bins) by
      (unfold bins'; rewrite sublist_upd_Znth_r; try reflexivity; try rep_lia).
    assert (Hlens'': sublist (b+1) BINS lens' = sublist (b+1) BINS lens). {
      unfold lens'. unfold lens. unfold rvec'. unfold add_resvec.
      simple_if_tac''; auto. do 2 rewrite sublist_map; try rep_lia.
      rewrite sublist_upd_Znth_r; auto; try rep_lia.
      }
    assert (Hsub:  sublist 0 b (zip3 lens bins idxs)
                 = sublist 0 b (zip3 lens' bins' idxs)).
    { repeat rewrite sublist_zip3; try rep_lia.
      rewrite Hbins'. rewrite Hlens'.  reflexivity.  }
    assert (Hsub':  sublist (b + 1) BINS (zip3 lens bins idxs)
                  = sublist (b + 1) BINS (zip3 lens' bins' idxs)).
    { repeat rewrite sublist_zip3; try rep_lia.
      rewrite Hbins''. rewrite Hlens''.  reflexivity. }
    rewrite Hsub. rewrite Hsub'.
    rewrite pull_right.
    assert (Hq: q = (Znth b bins')). (* TODO clean this mess *)
    { unfold bins'. rewrite upd_Znth_same.
      destruct q; auto with valid_pointer.
      match goal with | HA: Zlength bins = _ |- _ =>
                        auto 10  with valid_pointer; rewrite H0; assumption end.  }
    rewrite Hq.
    (* Annoying rewrite, but can't use replace_SEP because that's for
       preconditions; would have to do use it back at the last forward. *)
    assert (Hassoc:
        iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
        mmlist (bin2sizeZ b) (Znth b lens') (Znth b bins') nullval * TT *
        iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs))
      = iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
        iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs)) *
        mmlist (bin2sizeZ b) (Znth b lens') (Znth b bins') nullval * TT)
           by (apply pred_ext; entailer!).
    sep_apply Hassoc; clear Hassoc.
    rewrite mem_mgr_split'; try entailer!; auto.

* (*+ case not guaranteed *)
assert (Hb: 0 <= b < BINS) by (apply (claim2 n); lia).
rewrite (mem_mgr_split_R gv b rvec) by apply Hb.
Intros bins idxs lens.
freeze [1; 3] Otherlists.
deadvars!.
forward. (*! p = bin[b] !*)
(* TODO may not need post since excluding one branch *)
forward_if( (*! if p == null *)
    EX p:val, EX len:Z,
     PROP(p <> nullval)
     LOCAL(temp _p p; temp _b (Vint (Int.repr b)); gvars gv)
     SEP(FRZL Otherlists; TT;
         data_at Ews (tarray (tptr tvoid) BINS) (upd_Znth b bins p) (gv _bin);
         mmlist (bin2sizeZ b) (Z.to_nat len) p nullval)).

  + (* typecheck guard *)
    set (lens:=map Z.to_nat rvec).
    destruct (Znth b lens) eqn: Hblen.
    - (* length 0 *)
      match goal with | HA: Znth b bins = nullval <-> _ |- _ => set (Hbn:=HA) end.
      (*Set Printing Implicit. -- to see the need for following step. *)
      change Inhabitant_val with Vundef in Hbn.
      assert (Znth b bins = nullval) by apply (proj2 Hbn Hblen).
      change (@Znth val Vundef) with (@Znth val Inhabitant_val).
      replace (Znth b bins) with nullval by assumption.
      auto with valid_pointer.
    - (* length non-zero *)
      match goal with | HA: Znth b bins = nullval <-> _ |- _ => destruct HA end.
      assert (Znth b bins <> nullval). {
        assert (S n0 <> 0%nat) by congruence.
        change lens with (map Z.to_nat rvec) in *.
        rewrite Hblen in *; auto.
      }
      change (Vint Int.zero) with nullval.
      auto with valid_pointer.
      apply denote_tc_test_eq_split; auto with valid_pointer.
      sep_apply (mmlist_ne_valid_pointer (bin2sizeZ b) (S n0) (Znth b bins) nullval).
      lia. change Inhabitant_val with Vundef; entailer!.
  + (* branch p==NULL *)
    change Inhabitant_val with Vundef in *.
    replace (Znth b bins) with nullval by assumption.
    assert_PROP(Znth b lens = 0%nat) as Hlen0.
   { entailer!.
      match goal with | HA: nullval = nullval <-> _ |- _ => (apply HA; reflexivity) end.  }
    rewrite Hlen0.
    rewrite mmlist_empty.
    forward_call b. (*! p = fill_bin(b) !*)
    Intro r_with_l; destruct r_with_l as [root len]; simpl.
    forward_if. (*! if p==NULL !*)
    ++ (* typecheck guard *)
      apply denote_tc_test_eq_split; auto with valid_pointer.
      if_tac. entailer!.
      sep_apply (mmlist_ne_valid_pointer (bin2sizeZ b) (Z.to_nat len) root nullval).
      change (Z.to_nat len > 0)%nat with (0 < Z.to_nat len)%nat.
      change 0%nat with (Z.to_nat 0). apply Z2Nat.inj_lt; rep_lia.
      entailer!.
    ++ (* case p==NULL after fill_bin() *)
      forward. (*! return null *)
      Exists nullval. entailer!.
      thaw Otherlists.
      set (idxs:= (map Z.of_nat (seq 0 (Z.to_nat BINS)))).
      replace (data_at Ews (tarray (tptr tvoid) BINS) bins (gv _bin))
         with (data_at Ews (tarray (tptr tvoid) BINS) bins (gv _bin) * emp)
         by normalize.
      rewrite <- (mmlist_empty (bin2sizeZ b)). (* used to need: at 2. *)
      2: solve [ pose proof (bin2size_range b); rep_lia].
      rewrite <- Hlen0 at 1.
      unfold mem_mgr_R. Exists bins. Exists idxs.  Exists (map Z.to_nat rvec).
      entailer!. rewrite <-(mem_mgr_split' b); unfold b, Inhabitant_val; auto.
      rewrite H6; cancel.
    ++ (* case p<>NULL *)
      if_tac. contradiction.
      Intros.
      forward. (*! bin[b] = p !*)
      Exists root. Exists len.
     entailer!.
    ++ pose proof (bin2size_range b); rep_lia.
  + (* branch p!=NULL *)
    forward. (*! skip !*)
    Exists (Znth b bins).
    Exists (Z.of_nat (nth (Z.to_nat b) lens 0%nat)).
    rewrite Nat2Z.id.
    match goal with | HA: Zlength bins = _ |- _ =>
                      rewrite upd_Znth_same_val by (rewrite HA; assumption) end.
    entailer!.
    rewrite <- nth_Znth; try rep_lia.
    unfold Inhabitant_nat.
    entailer!.
  + (* after if: unroll and pop mmlist *)
    Intros p len.
    set (s:=bin2sizeZ b).
    assert_PROP (len > 0).
    { sep_apply (mmlist_ne_len s len p nullval); auto. entailer!.  }
    assert_PROP (isptr p).
    { entailer!. clear - H6 PNp. destruct p; auto.
      contradiction H6; simpl in *; subst; auto. }
    rewrite (mmlist_unroll_nonempty s (Z.to_nat len) p)
       by (rewrite Z2Nat.id; rep_lia); try assumption.
    Intros q.
    assert_PROP(force_val (sem_cast_pointer p) = field_address (tptr tvoid) [] p).
    { entailer!. unfold field_address. rewrite if_true by auto. normalize. }
    forward. (*! q = *p !*)
    forward. (*! bin[b]=q !*)
    (* prepare token+chunk to return *)
    deadvars!.
    thaw Otherlists.
    sep_apply (to_malloc_token'_and_block n p q s).
    (* refold invariant *)
    rewrite upd_Znth_twice by (rewrite H0; apply Hb).
    set (lens':=(upd_Znth b lens (Nat.pred (Z.to_nat len)))).
    set (bins':=(upd_Znth b bins (force_val (sem_cast_pointer q)))).
    assert (Hpredlen: Nat.pred (Z.to_nat len) = (Znth b lens')).
    { unfold lens'. rewrite upd_Znth_same. reflexivity.
      match goal with | HA: Zlength lens = _ |- _ => rewrite HA end.
      assumption. }
    rewrite Hpredlen.
    change s with (bin2sizeZ b).
    forward. (*! return p !*)
    Exists p. entailer!.
    rewrite if_false by auto.
    bdestruct (size2binZ n <? BINS); try rep_lia.
    set (rvec':= add_resvec rvec b (len-1)).
    Exists rvec'.
    assert (Heq_except: eq_except rvec' rvec (size2binZ n))
      by (unfold rvec'; apply add_resvec_eq_except).
    entailer!.
    unfold mem_mgr_R.
    set (lens:= (map Z.to_nat rvec)) in *.
    Exists bins'.
    set (idxs:= (map Z.of_nat (seq 0 (Z.to_nat BINS)))).
    Exists idxs.
    Exists lens'.
    assert (Hlbins': Zlength bins' = BINS)
      by (subst bins'; rewrite upd_Znth_Zlength; rep_lia).
    assert (Hllens': Zlength lens' = BINS)
      by (subst lens'; rewrite upd_Znth_Zlength; rep_lia).
    entailer!.
    { split.
      -- subst lens' rvec'. rewrite Hpredlen, upd_Znth_same by rep_lia.
         unfold add_resvec.
         bdestruct (Zlength rvec =? BINS); [ | rep_lia].
         bdestruct (0 <=? b); [ | rep_lia].
         bdestruct (b <? BINS); [ |rep_lia].
         simpl.
         rewrite <- upd_Znth_map. subst lens. f_equal.
         rewrite Hprednat; auto. f_equal.
         replace (Znth b rvec) with 0; try rep_lia.
         symmetry.  apply small_not_guaranteed_zero; auto.
      -- apply add_resvec_no_neg; auto.
         assert (0 <= Znth b rvec).
         { apply Forall_Znth. assumption. lia. }
         rep_lia.
    }
(* TODO following can be more succinct using replace, as in free_small and pre_fill *)
    assert (Hbins': sublist 0 b bins' = sublist 0 b bins) by
      (unfold bins'; rewrite sublist_upd_Znth_l; try reflexivity; try rep_lia).
    assert (Hlens': sublist 0 b lens' = sublist 0 b lens) by
      (unfold lens'; rewrite sublist_upd_Znth_l; try reflexivity; try rep_lia).
    assert (Hbins'': sublist (b+1) BINS bins' = sublist (b+1) BINS bins) by
      (unfold bins'; rewrite sublist_upd_Znth_r; try reflexivity; try rep_lia).
    assert (Hlens'': sublist (b+1) BINS lens' = sublist (b+1) BINS lens) by
      (unfold lens'; rewrite sublist_upd_Znth_r; try reflexivity; try rep_lia).
    assert (Hsub:  sublist 0 b (zip3 lens bins idxs)
                 = sublist 0 b (zip3 lens' bins' idxs)).
    { repeat rewrite sublist_zip3; try rep_lia.
      - rewrite Hbins'. rewrite Hlens'.  reflexivity.
      - assert (Zlength idxs = BINS) by auto. rep_lia.
      - assert (Zlength idxs = BINS) by auto. rep_lia.
    }
    assert (Hsub':  sublist (b + 1) BINS (zip3 lens bins idxs)
                  = sublist (b + 1) BINS (zip3 lens' bins' idxs)).
    { repeat rewrite sublist_zip3; try rep_lia.
      - rewrite Hbins''. rewrite Hlens''.  reflexivity.
      - assert (Zlength idxs = BINS) by auto. rep_lia.
      - assert (Zlength idxs = BINS) by auto. rep_lia.
    }
    rewrite Hsub. rewrite Hsub'.
    rewrite pull_right.
    assert (Hq: q = (Znth b bins')).
    { unfold bins'. rewrite upd_Znth_same.
      destruct q; auto with valid_pointer. rep_lia.
    }
    rewrite Hq.
    rewrite mem_mgr_split'; try entailer!; auto.
Qed.
(*
Definition module := [mk_body body_malloc_small].
*)


From iris.proofmode Require Import tactics.
From iris_named_props Require Import named_props.

Set Default Proof Using "All".
Section tests.
  Context {PROP: bi} {Haffine: BiAffine PROP}.
  Implicit Types (P Q R : PROP).

  Lemma demo_split_manual P Q R :
    "HP" ∷ P ∗
    "HQ" ∷ Q ∗
    "HP_to_R" ∷ (P -∗ R) -∗
    R ∗ Q.
  Proof.
    iNamed 1.
    iSplitL "HP HP_to_R".
    - iApply ("HP_to_R" with "HP").
    - iExact "HQ".
  Qed.

  Lemma demo_split_delay P Q R :
    "HP" ∷ P ∗
    "HQ" ∷ Q ∗
    "HP_to_R" ∷ (P -∗ R) -∗
    R ∗ Q.
  Proof.
    iNamed 1.
    iSplitDelay.
    - iSpecialize ("HP_to_R" with "HP").
      iFrame.
      Show.
      rewrite left_id. (* TODO: this is an annoyance *)
      iNamedAccu.
    - iNamed 1.
      Show.
      iExact "HQ".
  Qed.
End tests.


Require Import ExtLib.Structures.Monad.

Set Implicit Arguments.

Class MonadZero (m : Type -> Type) : Type :=
{ mzero : forall {T}, m T }.

Section ZeroFuncs.
  Context {m : Type -> Type}.
  Context {Monad_m : Monad m}.
  Context {Zero_m : MonadZero m}.

  Definition assert (b : bool) : m unit :=
    if b then ret tt else mzero.

End ZeroFuncs.


Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Logic.FunctionalExtensionality
        Coq.Sets.Ensembles
        Coq.Arith.Arith
        Fiat.Computation.Core
        Fiat.ADT.ADTSig
        Fiat.ADT.Core
        Fiat.Common.StringBound
        Fiat.Common.ilist2
        Fiat.Common.ilist
        Fiat.ADTNotation.BuildADT
        Fiat.ADTNotation.BuildADTSig
        Fiat.Common.Ensembles.IndexedEnsembles
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.QueryStructure.Specification.Representation.Schema
        Fiat.QueryStructure.Specification.Representation.Relation
        Fiat.QueryStructure.Specification.Representation.QueryStructureSchema.

Section BuildQueryStructureConstraints.
  (* Query Structures maintain a set of constraints that enforce
     cross-relation data integrity. Query Structure Schemas encode
     these as a list of dependent products, which
     [BuildQueryStructureConstraints] uses to build the actual constraints.
   *)

  Local Obligation Tactic := intros.

  (* [BuildQueryStructureConstraints_cons] searches the *)

  Program Definition BuildQueryStructureConstraints_cons
          {n}
          (namedSchemas : Vector.t RawSchema n)
          (constr : sigT (crossRelationProdR namedSchemas))
          (constraints :
             list (sigT (crossRelationProdR namedSchemas)))
          (idx idx' : _)
          (HInd : option (crossRelationR namedSchemas idx idx'))
    : option (crossRelationR namedSchemas idx idx')
    :=
      if (fin_eq_dec idx (fst (projT1 constr))) then
        if (fin_eq_dec idx' (snd (projT1 constr))) then
          _
        else HInd
      else HInd.
  Next Obligation.
    destruct constr; simpl in *.
    (* No need to check if the indices are in the list of Relations, because
     they are Bounded Strings. *)
    unfold crossRelationR, GetNRelSchemaHeading, GetNRelSchema; simpl.
    rewrite H, H0;  exact (Some c).
  Defined.

  Fixpoint BuildQueryStructureConstraints'
           {n}
           (namedSchemas : Vector.t RawSchema n)
           (constraints :
              list (sigT (crossRelationProdR namedSchemas)))
           {struct constraints}
    : forall (idx idx' : _), option (crossRelationR namedSchemas idx idx') :=
    match constraints with
    | idx'' :: constraints' =>
      fun idx idx' => @BuildQueryStructureConstraints_cons _
                                                           namedSchemas idx'' constraints' idx idx'
                                                           (BuildQueryStructureConstraints' constraints' idx idx')
    | nil => fun _ _ => None
    end.

  Definition BuildQueryStructureConstraints qsSchema :=
    BuildQueryStructureConstraints' (qschemaConstraints qsSchema).

End BuildQueryStructureConstraints.

(* A Query Structure is a collection of relations
   (described by a proposition) which satisfy the
   schema and the cross-relation constraints. *)

Record RawQueryStructure (QSSchema : RawQueryStructureSchema) :=
  { rawRels : ilist2 (B := RawRelation) (qschemaSchemas QSSchema);
    crossConstr :
      forall (idx idx' : _),
        match (BuildQueryStructureConstraints QSSchema idx idx') with
        | Some CrossConstr =>
          forall (tup : @IndexedRawTuple (GetNRelSchemaHeading (qschemaSchemas QSSchema) idx)),
            idx <> idx' ->
            (* These are cross-relation constraints which only need to be
           enforced on distinct relations. *)
            (rawRel (ith2 rawRels idx )) tup ->
            CrossConstr (indexedElement tup) (rawRel (ith2 rawRels idx'))
        | None => True
        end
  }.

Definition QueryStructure (QSSchema : QueryStructureSchema) := RawQueryStructure QSSchema.

(* Notation "t ! R" := (rels t R%string): QueryStructure_scope. *)

(* This typeclass allows our method definitions to infer the
   the QueryStructure [r] they are called with. *)

(* Class QueryStructureSchemaHint :=
  { qsSchemaHint : QueryStructureSchema
  }.

Class QueryStructureHint :=
  { qsSchemaHint' : QueryStructureSchema;
    qsHint :> @QueryStructure qsSchemaHint'
  }. *)

(*Notation "'query' id ( r : 'rep' , x : dom ) : cod := bod" :=
  (Build_methDef {| methID := id; methDom := dom; methCod := cod |}
                 (fun (r : rep) x =>
                    let _ := {| codHint := cod |} in
                    queryRes <- bod%QuerySpec;
                  ret (r, queryRes)))%comp
                                     (no associativity, id at level 0, x at level 0, dom at level 0,
                                      r at level 0, cod at level 0, only parsing,
                                      at level 94, format "'query'  id  (  r  : 'rep'  ,  x  :  dom )  :  cod  :=  '[  '   bod ']' " ) :
    queryDef_scope.

Notation "'update' id ( r : 'rep' , x : dom ) : cod := bod" :=
  (Build_methDef {| methID := id; methDom := dom; methCod := cod |}
                 (fun (r : rep) x =>
                    bod%QuerySpec))
    (no associativity, id at level 0, x at level 0, dom at level 0,
     r at level 0, cod at level 0, only parsing,
     at level 94, format "'update'  id  (  r  :  'rep'  ,  x  :  dom )  :  cod  :=  '[  '   bod ']' " ) :
    queryDef_scope. *)

(* Notation for ADTs built from [BuildADT]. *)

(*Notation "'QueryADTRep' r { cons1 , meth1 , .. , methn } " :=
  (let _ := {| rep := (QueryStructure r) |}
   in @BuildADT (QueryStructure r) _ _ _ _
             (icons cons1%consDef (inil (B := @consDef (QueryStructure r))))
             (icons (B := @methDef (QueryStructure r)) (meth1%queryDef%methDefParsing ) .. (icons (B := @methDef (QueryStructure r)) methn%queryDef%methDefParsing (inil (B := @methDef (QueryStructure r)))) ..))
    (no associativity, at level 96, r at level 0, only parsing,
     format "'QueryADTRep'  r  '/' '[hv  ' {  cons1 , '//' '//' meth1 , '//' .. , '//' methn  ']' }") : QueryStructure_scope. *)

Definition GetRelation
           (QSSchema : QueryStructureSchema)
           (qs : QueryStructure QSSchema)
           (idx : Fin.t _)
  : @IndexedEnsemble (@RawTuple (GetNRelSchemaHeading (qschemaSchemas QSSchema) idx)) := rawRel (ith2 (rawRels qs) idx).

Definition GetRelationBnd
           (QSSchema : QueryStructureSchema)
           (qs : QueryStructure QSSchema)
           (idx : BoundedIndex (QSschemaNames QSSchema))
  : @IndexedEnsemble (@RawTuple (GetNRelSchemaHeading (qschemaSchemas QSSchema) (ibound (indexb idx)))) := @GetRelation QSSchema qs (ibound (indexb idx)).

(* This lets us drop the constraints from the reference implementation
   for easier refinements. *)

Definition UnConstrQueryStructure (qsSchema : RawQueryStructureSchema) :=
  ilist2 (B := fun ns => RawUnConstrRelation (rawSchemaHeading ns))
        (qschemaSchemas qsSchema).

Definition GetUnConstrRelation
           {QSSchema : RawQueryStructureSchema}
           (qs : UnConstrQueryStructure QSSchema)
           (idx : _)
  : @IndexedEnsemble (@RawTuple (GetNRelSchemaHeading (qschemaSchemas QSSchema) idx)) :=
      ith2 qs idx.

Definition GetUnConstrRelationBnd
           {QSSchema : QueryStructureSchema}
           (qs : UnConstrQueryStructure QSSchema)
           (idx : BoundedIndex (QSschemaNames QSSchema))
  : @IndexedEnsemble (@RawTuple (GetNRelSchemaHeading (qschemaSchemas QSSchema) (ibound (indexb idx)))) :=
      ith2 qs (ibound (indexb idx)).

Definition DropQSConstraints
           {qsSchema : QueryStructureSchema}
           (qs : QueryStructure qsSchema)
  : UnConstrQueryStructure qsSchema :=
  @imap2 _
        (fun ns => RawRelation ns)
        (fun ns => RawUnConstrRelation (rawSchemaHeading ns))
        (fun ns => @rawRel ns) _ (qschemaSchemas qsSchema) (rawRels qs).

Definition DropQSConstraints_AbsR (qsSchema : QueryStructureSchema)
           (qs : QueryStructure qsSchema)
           (qs' : UnConstrQueryStructure qsSchema)
  : Prop :=
  DropQSConstraints qs = qs'.

Lemma GetRelDropConstraints
      {qsSchema : QueryStructureSchema}
      (qs : QueryStructure qsSchema)
      (Ridx : _)
  : GetUnConstrRelation (DropQSConstraints qs) Ridx = GetRelation qs Ridx.
Proof.
  unfold GetUnConstrRelation, DropQSConstraints, GetRelation.
  rewrite <- ith_imap2; reflexivity.
Qed.

(* Typeclass + notations for declaring abstraction relation for
   QueryStructure Implementations. *)

Definition SatisfiesAttributeConstraints
           {qsSchema}
           (Ridx : Fin.t _)
           (tup : @RawTuple (GetNRelSchemaHeading (qschemaSchemas qsSchema) Ridx))
  :=
    match (attrConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx)) with
      Some Constr => Constr tup
    | None => True
    end.

Definition SatisfiesTupleConstraints
           {qsSchema}
           (Ridx : Fin.t _)
           (tup tup' : @RawTuple (GetNRelSchemaHeading (qschemaSchemas qsSchema) Ridx)) :=
  match (tupleConstraints (GetNRelSchema (qschemaSchemas qsSchema) Ridx)) with
    Some Constr => Constr tup tup'
  | None => True
  end.

Definition SatisfiesCrossRelationConstraints
           {qsSchema}
           (Ridx Ridx' : Fin.t _)
           (tup : @RawTuple (GetNRelSchemaHeading (qschemaSchemas qsSchema) Ridx)) R :=
  match (BuildQueryStructureConstraints qsSchema Ridx Ridx') with
  | Some CrossConstr => CrossConstr tup R
  | None => True
  end.

Definition UpdateUnConstrRelation
           {qsSchema : RawQueryStructureSchema}
           (rels : UnConstrQueryStructure qsSchema)
           (Ridx : _)
           newRel :
  UnConstrQueryStructure qsSchema :=
  replace_Index2 _ rels Ridx newRel.

Definition UpdateRelation
           {qsSchema : QueryStructureSchema}
           (rels : ilist2 (B := RawRelation) (qschemaSchemas qsSchema))
           (Ridx : _)
           newRel :
  ilist2 (qschemaSchemas qsSchema) :=
  replace_Index2 _ rels Ridx newRel.

(* Consequences of ith_replace_BoundIndex_neq and ith_replace_BoundIndex_eq on updates *)

Lemma get_update_unconstr_eq :
  forall (db_schema : RawQueryStructureSchema) (qs : UnConstrQueryStructure db_schema)
         (index : _) ens,
    GetUnConstrRelation (UpdateUnConstrRelation qs index ens) index = ens.
Proof.
  unfold UpdateUnConstrRelation, GetUnConstrRelation.
  intros; rewrite ith_replace2_Index_eq; reflexivity.
Qed.

Lemma get_update_unconstr_neq :
  forall (db_schema : RawQueryStructureSchema) (qs : UnConstrQueryStructure db_schema)
         (index1 index2 : _) ens,
    index1 <> index2 ->
    GetUnConstrRelation
      (UpdateUnConstrRelation qs index1 ens) index2 =
    GetUnConstrRelation qs index2.
Proof.
  unfold UpdateUnConstrRelation, GetUnConstrRelation;
  intros; simpl; rewrite ith_replace2_Index_neq; eauto using string_dec.
Qed.

Notation "ro ≃ rn" := (@UnConstrRelationAbsR _ _ _ ro%QueryImpl rn) : QueryImpl_scope.

Notation "qs ! R" :=
  (GetUnConstrRelationBnd qs {|bindex := R%string |}): QueryImpl_scope.

(*Arguments BuildQueryStructureConstraints _ _ _. *)
Arguments BuildQueryStructureConstraints_cons [_ _] _ _ _ _ (*/*) _ .
(*Arguments BuildQueryStructureConstraints_cons_obligation_1 [_ _] _ (*/*) _ _ _ _.*)


(* This file is an automatic translation, the licence of the source can be found here: *)
(* https://github.com/herd/herdtools7/blob/master/LICENSE.txt *)
(* Translation of model AArch64 *)
From Coq Require Import Relations Ensembles String.
From RelationAlgebra Require Import lattice prop monoid rel kat.
From Catincoq.lib Require Import Cat proprel.
Section Model.
Variable c : candidate.
Definition events := events c.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition B := B c.
Definition RMW := RMW c.
Definition F := F c.
Definition rf := rf c.
Definition po := po c.
Definition int := int c.
Definition ext := ext c.
Definition loc := loc c.
Definition addr := addr c.
Definition data := data c.
Definition ctrl := ctrl c.
Definition amo := amo c.
Definition rmw := rmw c.
Definition unknown_set := unknown_set c.
Definition unknown_relation := unknown_relation c.
Definition M := R ⊔ W.
Definition emptyset : set events := empty.
Definition classes_loc : set events -> Ensemble (Ensemble events) := partition loc.
Definition X := unknown_set "X".
Definition tag2events := unknown_relation "tag2events".
Definition emptyset_0 : set events := domain 0.
Definition partition := classes_loc.
Definition tag2instrs := tag2events.
Definition po_loc := po ⊓ loc.
Definition rfe := rf ⊓ ext.
Definition rfi := rf ⊓ int.
Definition co0 := loc ⊓ ([IW] ⋅ top ⋅ [(W ⊓ !IW)] ⊔ [(W ⊓ !FW)] ⋅ top ⋅ [FW]).
Definition toid (s : set events) : relation events := [s].
Definition fencerel (B : set events) := (po ⊓ [top] ⋅ top ⋅ [B]) ⋅ po.
Definition ctrlcfence (CFENCE : set events) := (ctrl ⊓ [top] ⋅ top ⋅ [CFENCE]) ⋅ po.
Definition imply (A : relation events) (B : relation events) := !A ⊔ B.
Definition nodetour (R1 : relation events) (R2 : relation events) (R3 : relation events) := R1 ⊓ !(R2 ⋅ R3).
Definition singlestep (R : relation events) := nodetour R R R.
(* Definition of map already included in the prelude *)
Definition LKW := (*failed: try LKW with emptyset_0*) emptyset_0.
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition cobase := co0.
Variable co : relation events.
Definition coi := co ⊓ int.
Definition coe := co ⊓ !coi.
Definition fr := rf° ⋅ co ⊓ !id.
Definition fri := fr ⊓ int.
Definition fre := fr ⊓ !fri.
Definition uniproc := acyclic (po_loc ⊔ (rf ⊔ (fr ⊔ co))).
Definition dd := addr ⊔ data.
Definition rdw := po_loc ⊓ fre ⋅ rfe.
Definition detour := po_loc ⊓ coe ⋅ rfe.
Definition addrpo := addr ⋅ po.
Definition com := fr ⊔ (co ⊔ rf).
Definition atomic := is_empty (rmw ⊓ fre ⋅ coe).
Definition DMB_ISH := (*failed: try DMB.ISH with emptyset_0*) emptyset_0.
Definition DMB_ISHLD := (*failed: try DMB.ISHLD with emptyset_0*) emptyset_0.
Definition DMB_ISHST := (*failed: try DMB.ISHST with emptyset_0*) emptyset_0.
Definition DSB_ISH := (*failed: try DSB.ISH with emptyset_0*) emptyset_0.
Definition DSB_ISHLD := (*failed: try DSB.ISHLD with emptyset_0*) emptyset_0.
Definition DSB_ISHST := (*failed: try DSB.ISHST with emptyset_0*) emptyset_0.
Definition DMB_SY := (*failed: try DMB.SY with emptyset_0*) emptyset_0.
Definition DMB_ST := (*failed: try DMB.ST with emptyset_0*) emptyset_0.
Definition DMB_LD := (*failed: try DMB.LD with emptyset_0*) emptyset_0.
Definition DSB_SY := (*failed: try DSB.SY with emptyset_0*) emptyset_0.
Definition DSB_ST := (*failed: try DSB.ST with emptyset_0*) emptyset_0.
Definition DSB_LD := (*failed: try DSB.LD with emptyset_0*) emptyset_0.
Definition DMB_OSH := (*failed: try DMB.OSH with emptyset_0*) emptyset_0.
Definition DSB_OSH := (*failed: try DSB.OSH with emptyset_0*) emptyset_0.
Definition DMB_OSHLD := (*failed: try DMB.OSHLD with emptyset_0*) emptyset_0.
Definition DSB_OSHLD := (*successful: try DSB.OSH with emptyset_0*) DSB_OSH.
Definition DMB_OSHST := (*failed: try DMB.OSHST with emptyset_0*) emptyset_0.
Definition DSB_OSHST := (*failed: try DSB.OSHST with emptyset_0*) emptyset_0.
Definition ISB := (*failed: try ISB with emptyset_0*) emptyset_0.
Definition A := (*failed: try A with emptyset_0*) emptyset_0.
Definition L := (*failed: try L with emptyset_0*) emptyset_0.
Definition Q := (*failed: try Q with emptyset_0*) emptyset_0.
Definition NoRet := (*failed: try NoRet with emptyset_0*) emptyset_0.
Definition dmb_ish := fencerel DMB_ISH.
Definition dmb_ishld := fencerel DMB_ISHLD.
Definition dmb_ishst := fencerel DMB_ISHST.
Definition dmb_fullsy := fencerel DMB_SY.
Definition dmb_fullst := fencerel DMB_ST.
Definition dmb_fullld := fencerel DMB_LD.
Definition dmb_sy := dmb_fullsy ⊔ dmb_ish.
Definition dmb_st := dmb_fullst ⊔ dmb_ishst.
Definition dmb_ld := dmb_fullld ⊔ dmb_ishld.
Definition dsb_sy := fencerel DSB_SY.
Definition dsb_st := fencerel DSB_ST.
Definition dsb_ld := fencerel DSB_LD.
Definition isb := fencerel ISB.
Definition ctrlisb := (*successful: try ctrlcfence ISB with 0*) ctrlcfence ISB.
Definition ci0 := ctrlisb ⊔ detour.
Definition ii0 := dd ⊔ (rfi ⊔ rdw).
Definition cc0 := dd ⊔ (ctrl ⊔ addrpo).
Definition ic0 : relation events := 0.
Inductive ci : relation _ := ci_c : incl (ci0 ⊔ (ci ⋅ ii ⊔ cc ⋅ ci)) ci
     with ii : relation _ := ii_c : incl (ii0 ⊔ (ci ⊔ (ic ⋅ ci ⊔ ii ⋅ ii))) ii
     with cc : relation _ := cc_c : incl (cc0 ⊔ (ci ⊔ (ci ⋅ ic ⊔ cc ⋅ cc))) cc
     with ic : relation _ := ic_c : incl (ic0 ⊔ (ii ⊔ (cc ⊔ (ic ⋅ cc ⊔ ii ⋅ ic)))) ic.
Section scheme.
Variables ci' ii' cc' ic' : relation events.
Variable Hci' : incl (ci0 ⊔ (ci' ⋅ ii' ⊔ cc' ⋅ ci')) ci'.
Variable Hii' : incl (ii0 ⊔ (ci' ⊔ (ic' ⋅ ci' ⊔ ii' ⋅ ii'))) ii'.
Variable Hcc' : incl (cc0 ⊔ (ci' ⊔ (ci' ⋅ ic' ⊔ cc' ⋅ cc'))) cc'.
Variable Hic' : incl (ic0 ⊔ (ii' ⊔ (cc' ⊔ (ic' ⋅ cc' ⊔ ii' ⋅ ic')))) ic'.

  Fixpoint ci_ind' x y (r : ci x y) : ci' x y
      with ii_ind' x y (r : ii x y) : ii' x y
      with cc_ind' x y (r : cc x y) : cc' x y
      with ic_ind' x y (r : ic x y) : ic' x y.
  Proof.
    destruct r as [x y r]; apply Hci'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      destruct r as [x_y r1 r2]; exists x_y.
       apply ci_ind'; exact r1.
       apply ii_ind'; exact r2.
      destruct r as [x_y r1 r2]; exists x_y.
       apply cc_ind'; exact r1.
       apply ci_ind'; exact r2.
    destruct r as [x y r]; apply Hii'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ic_ind'; exact r1.
        apply ci_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply ii_ind'; exact r1.
        apply ii_ind'; exact r2.
    destruct r as [x y r]; apply Hcc'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ci_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       destruct r as [x_y r1 r2]; exists x_y.
        apply ci_ind'; exact r1.
        apply ic_ind'; exact r2.
       destruct r as [x_y r1 r2]; exists x_y.
        apply cc_ind'; exact r1.
        apply cc_ind'; exact r2.
    destruct r as [x y r]; apply Hic'.
    destruct r as [r | r]; [ left | right ].
     exact r.
     destruct r as [r | r]; [ left | right ].
      apply ii_ind'; exact r.
      destruct r as [r | r]; [ left | right ].
       apply cc_ind'; exact r.
       destruct r as [r | r]; [ left | right ].
        destruct r as [x_y r1 r2]; exists x_y.
         apply ic_ind'; exact r1.
         apply cc_ind'; exact r2.
        destruct r as [x_y r1 r2]; exists x_y.
         apply ii_ind'; exact r1.
         apply ic_ind'; exact r2.
  Qed.
End scheme.
Definition ppo := let ppoR := ii ⊓ [R] ⋅ top ⋅ [R] in let ppoW := ic ⊓ [R] ⋅ top ⋅ [W] in ppoR ⊔ ppoW.
Definition acq := [A] ⋅ top ⋅ [M] ⊓ po.
Definition rel := [M] ⋅ top ⋅ [L] ⊓ po.
Definition syf := dmb_sy ⊓ [M] ⋅ top ⋅ [M] ⊔ dsb_sy ⊓ [M] ⋅ top ⋅ [M].
Definition stf := dmb_st ⊓ [W] ⋅ top ⋅ [W] ⊔ dsb_st ⊓ [W] ⋅ top ⋅ [W].
Definition ldf := dmb_ld ⊓ [R] ⋅ top ⋅ [M] ⊔ dsb_ld ⊓ [R] ⋅ top ⋅ [M].
Definition fence := syf ⊔ (stf ⊔ (ldf ⊔ (acq ⊔ rel))).
Definition hb := [R] ⋅ top ⋅ [M] ⊓ fence ⊔ (rfe ⊔ ppo).
Definition thin_air := acyclic hb.
Definition prop := com^* ⋅ syf ⊔ (stf ⊔ (rfe ⊔ 1) ⋅ rel).
Definition prop_al := [L] ⋅ top ⋅ [A] ⊓ (rf ⊔ po) ⊔ [A] ⋅ top ⋅ [L] ⊓ fr.
Definition xx := [W] ⋅ top ⋅ [W] ⊓ ([X] ⋅ top ⋅ [X] ⊓ po).
Definition observation := irreflexive (prop ⋅ (rfe ⋅ ((fence ⊔ ppo) ⋅ fre))).
Definition propagation := acyclic (co ⊔ (prop ⋅ hb^* ⊔ (xx ⊔ prop_al ⋅ hb^*))).
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := uniproc /\ (atomic /\ (thin_air /\ (observation /\ propagation))).
End Model.

Hint Unfold events R W IW FW B RMW F rf po int ext loc addr data ctrl amo rmw unknown_set unknown_relation M emptyset classes_loc X tag2events emptyset_0 partition tag2instrs po_loc rfe rfi co0 toid fencerel ctrlcfence imply nodetour singlestep LKW generate_orders generate_cos cobase coi coe fr fri fre uniproc dd rdw detour addrpo com atomic DMB_ISH DMB_ISHLD DMB_ISHST DSB_ISH DSB_ISHLD DSB_ISHST DMB_SY DMB_ST DMB_LD DSB_SY DSB_ST DSB_LD DMB_OSH DSB_OSH DMB_OSHLD DSB_OSHLD DMB_OSHST DSB_OSHST ISB A L Q NoRet dmb_ish dmb_ishld dmb_ishst dmb_fullsy dmb_fullst dmb_fullld dmb_sy dmb_st dmb_ld dsb_sy dsb_st dsb_ld isb ctrlisb ci0 ii0 cc0 ic0 ppo acq rel syf stf ldf fence hb thin_air prop prop_al xx observation propagation witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model AArch64 *)


From bisimulations Require Import prelude.
From bisimulations Require Import system.
From bisimulations Require Import relations.
From bisimulations Require Import paths.
From bisimulations Require Import formulas.
From bisimulations Require Import reflexive.directed_branching.
From bisimulations Require Import reflexive.hmlu.
From bisimulations Require Import reflexive.phmlu.

Section Distinguish.
Context `{ReflSystem : @refl_system X System}.

Record DADist φ (p q : X) : Prop := mkDADist
{ NoPolarity : sc db_dapart p q
; PosPolarity : HmluPos φ → db_dapart p q
; NegPolarity : HmluNeg φ → db_dapart q p
}.

Lemma neg_da_dist {φ p q} : DADist φ p q → DADist (¬ₕ φ) q p.
Proof. intros [HNP HPos HNeg]. constructor; [by symmetry|..]; by autorewrite with hints. Qed.
Lemma conj_left_da_dist {φ ψ p q} : DADist φ p q → DADist (φ ∧ₕ ψ) p q.
Proof. intros [HNP HPos HNeg]. constructor; [by symmetry|..]; autorewrite with hints; intros []; eauto. Qed.
Lemma conj_right_da_dist {φ ψ p q} : DADist ψ p q → DADist (φ ∧ₕ ψ) p q.
Proof. intros [HNP HPos HNeg]. constructor; [by symmetry|..]; autorewrite with hints; intros []; eauto. Qed.
Lemma diam_simple_da_dist {l δ φ p q} : db_dapart p q → DADist (◇ₕ l δ φ) p q.
Proof. intros Hpq. constructor; [by left|by intros|]. intros. inv_polarity. Qed.
Lemma diam_left_da_dist {l δ φ p q} : DADist δ p q → DADist (◇ₕ l δ φ) p q.
Proof. intros [HNP HPos HNeg]. constructor; [done|..]; intros; inv_polarity; eauto. Qed.

Hint Resolve neg_da_dist : hints.
Hint Resolve conj_left_da_dist : hints.
Hint Resolve conj_right_da_dist : hints.
Hint Resolve diam_simple_da_dist : hints.
Hint Resolve diam_left_da_dist : hints.

Lemma good_distinguish_gives_apartness_impl {p q φ} : HmluGood φ → p ⊨ₕ φ → q ⊭ₕ φ → DADist φ p q.
Proof.
  intros Hgood. revert φ Hgood p q.
  eapply (hmlu_good_ind (λ φ, ∀ p q, p ⊨ₕ φ → q ⊭ₕ φ → DADist φ p q)); simpl.
  - by intros.
  - eauto with hints.
  - intros φ ψ IHφ IHψ p q [Hpφ Hpψ] [Hqφ|Hqψ]; eauto with hints.
  - intros l δ φ Hδ IHδ IHφ p q Hp Hq. inv_hmlu; fold HmluTrue HmluFalse in *.
    rename p into p1, x into p2, x0 into p3, H into Hp12, H0 into Hp23, H1 into Hp3.
    eapply diam_simple_da_dist. induction Hp12; [|by eapply db_dapart_extend_backwards_one; eauto].
    eapply Fwd; try done. intros q2 Hq12 q3 Hq23.
    destruct (hmlu_true_or_false δ q2); [right|left; by eapply IHδ].
    eapply NoPolarity, IHφ; try done.
    eapply Hq; try done.
    by eapply rtc_to_path_via_by_pos.
Qed.

Theorem good_distinguish_gives_apartness {p q φ} : HmluGood φ → p ⊨ₕ φ → q ⊭ₕ φ → sc db_dapart p q.
Proof. intros. eauto using NoPolarity, good_distinguish_gives_apartness_impl. Qed.
Theorem good_distinguish_gives_apartness_pos {p q φ} : HmluGood φ → HmluPos φ → p ⊨ₕ φ → q ⊭ₕ φ → db_dapart p q.
Proof. intros. eauto using PosPolarity, good_distinguish_gives_apartness_impl. Qed.
Theorem good_distinguish_gives_apartness_neg {p q φ} : HmluGood φ → HmluNeg φ → p ⊨ₕ φ → q ⊭ₕ φ → db_dapart q p.
Proof. intros. eauto using NegPolarity, good_distinguish_gives_apartness_impl. Qed.

End Distinguish.


Require Import Coq.Program.Syntax.
Require Import List.
Require Import String.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Core.RelDec.
(*Require Import Injection. *)

Open Scope string_scope.
Import MonadNotation.
Open Scope monad_scope.

Set Implicit Arguments.
Set Maximal Implicit Insertion.

Module FunNotation.

  Notation "f $ x" := (f x)
    (at level 99, x at level 99, right associativity, only parsing).

  Notation "'begin' e1 'end'" := ((e1))
    (at level 0, only parsing).

End FunNotation.
Import FunNotation.

Definition compose A B C (g:B -> C) (f:A -> B) (x:A) : C := g (f x).

Definition uncurry A B C (f:A -> B -> C) (x:A * B) : C := let (a,b) := x in f a b.

Definition const A B (x:B) : A -> B := fun _ => x.

Fixpoint zip A B (xs:list A) (ys:list B) : list (A * B) :=
  match xs, ys with
  | [], _ => []
  | _, [] => []
  | x::xs, y::ys => (x,y)::zip xs ys
  end
.

Fixpoint unzip A B (xys:list (A * B)) : list A * list B :=
match xys with
| [] => ([], [])
| (x,y)::xys => let (xs,ys) := unzip xys in (x::xs,y::ys)
end.

Definition sum_tot {A} (x:A + A) : A := match x with inl a => a | inr a => a end.

Definition forEach A B (xs:list A) (f:A -> B) : list B := map f xs.

Definition lsingleton {A} (x:A) : list A := [x].

Definition firstf {A B C} (f:A->C) (xy:A*B) : C*B :=
let (x,y) := xy in (f x, y).

Definition secondf {A B C} (f:B->C) (xy:A*B) : A*C :=
let (x,y) := xy in (x, f y).

Fixpoint update {K V} {kRealDec:RelDec (@eq K)} x v l : list (K * V) :=
match l with
| [] => [(x,v)]
| (y,w)::l' => if eq_dec x y then (x,v)::l' else (y,w)::update x v l'
end.

Definition updateMany {K V} {kRealDec:RelDec (@eq K)}
  (ups:list (K * V)) (init:list (K * V)) : list (K * V) :=
    fold_right (uncurry update) init ups.


Require Coq.Strings.Ascii.
Require Coq.Strings.String.
Require Import Coq.Strings.String.
Require Import Coq.Program.Wf.
Require Import Coq.PArith.BinPos.
Require Import Coq.ZArith.ZArith.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Programming.Injection.
Require Import ExtLib.Data.Char.
Require Import ExtLib.Data.String.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Core.RelDec.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Set Printing Universes.

Monomorphic Universe Ushow.

Definition showM@{T} : Type@{Ushow} :=
  forall m : Type@{T}, Injection ascii m -> Monoid m -> m.

Class ShowScheme@{t} (T : Type@{t}) : Type :=
{ show_mon : Monoid@{t} T
; show_inj : Injection ascii T
}.

Global Instance ShowScheme_string : ShowScheme string :=
{ show_mon := Monoid_string_append
; show_inj := fun x => String x EmptyString
}.

Global Instance ShowScheme_string_compose : ShowScheme (string -> string) :=
{ show_mon := Monoid_compose string
; show_inj := String
}.

Definition runShow {T} {M : ShowScheme T} (m : showM) : T :=
  m _ show_inj show_mon.

Class Show@{t m} (T : Type@{t}) : Type :=
  show : T -> showM@{m}.

Definition to_string {T} {M : Show T} (v : T) : string :=
  runShow (show v) ""%string.

Definition empty : showM :=
  fun _ _ m => monoid_unit m.
Definition cat (a b : showM) : showM :=
  fun _ i m => monoid_plus m (a _ i m) (b _ i m).
Global Instance Injection_ascii_showM : Injection ascii showM :=
  fun v => fun _ i _ => i v.

Fixpoint show_exact (s : string) : showM :=
  match s with
    | EmptyString => empty
    | String a s' => cat (inject a) (show_exact s')
  end.

Module ShowNotation.
  Delimit Scope show_scope with show.

  Notation "x << y" := (cat x%show y%show) (at level 100) : show_scope.
  Coercion show_exact : string >-> showM.
  Definition _inject_char : ascii -> showM := inject.
  Coercion _inject_char : ascii >-> showM.
End ShowNotation.

Definition indent (indent : showM) (v : showM) : showM :=
  let nl := Ascii.ascii_of_nat 10 in
    fun _ inj mon =>
      v _ (fun a => if eq_dec a nl
         then monoid_plus mon (inj a) (indent _ inj mon)
         else inj a) mon.

Section sepBy.
  Import ShowNotation.
  Local Open Scope show_scope.

  Definition sepBy {T : Type}
              {F : Foldable T showM} (sep : showM) (ls : T) : showM :=
    match
      fold (fun s acc =>
        match acc with
          | None => Some s
          | Some x => Some (x << sep << s)
        end) None ls
      with
      | None => empty
      | Some s => s
    end.
End sepBy.

Section sepBy_f.
  Import ShowNotation.
  Local Open Scope show_scope.
  Variables (T : Type) (E : Type).
  Context {F : Foldable T E}.
  Variable (f : E -> showM).

  Definition sepBy_f (sep : showM) (ls : T) : showM :=
    match
      fold (fun s acc =>
        match acc with
          | None => Some (f s)
          | Some x => Some (x << sep << f s)
        end) None ls
      with
      | None => empty
      | Some s => s
    end.
End sepBy_f.

Definition wrap (before after : showM) (x : showM) : showM :=
  cat before (cat x after).

Section sum_Show.
  Import ShowNotation.
  Local Open Scope show_scope.

  Definition sum_Show@{a m}
              {A : Type@{a}} {B : Type@{a}} {AS:Show@{a m} A} {BS:Show@{a m} B}
  : Show@{a m} (A+B) :=
    fun s =>
        let (tag, payload) :=
          match s with
          | inl a => (show_exact "inl"%string, show a)
          | inr b => (show_exact "inr"%string, show b)
          end
        in
        "("%char <<
        tag <<
        " "%char <<
        payload <<
        ")"%char.

End sum_Show.

Section foldable_Show.
  Context {A:Type} {B:Type} {F : Foldable B A} {BS : Show A}.

  Global Instance foldable_Show : Show B :=
    { show s := sepBy_f show (show_exact ", "%string) s }.

End foldable_Show.

Fixpoint iter_show (ss : list showM) : showM :=
  match ss with
    | nil => empty
    | cons s ss => cat s (iter_show ss)
  end.

Section hiding_notation.
  Import ShowNotation.
  Local Open Scope show_scope.
  Import Ascii.
  Import String.

  Global Instance unit_Show : Show unit :=
  { show u := "tt"%string }.
  Global Instance bool_Show : Show bool :=
  { show b := if b then "true"%string else "false"%string }.
  Global Instance ascii_Show : Show ascii :=
    fun a =>  "'"%char << a << "'"%char.
  Global Instance string_Show : Show string :=
  { show s := """"%char << s << """"%char }.

  Program Fixpoint nat_show (n:nat) {measure n} : showM :=
    if Compare_dec.le_gt_dec n 9 then
      inject (Char.digit2ascii n)
    else
      let n' := NPeano.Nat.div n 10 in
      (@nat_show n' _) << (inject (Char.digit2ascii (n - 10 * n'))).
  Next Obligation.
    assert (NPeano.Nat.div n 10 < n) ; eauto.
    eapply NPeano.Nat.div_lt.
    match goal with [ H : n > _ |- _ ] => inversion H end; apply Lt.lt_O_Sn.
    repeat constructor.
  Defined.
  Global Instance nat_Show : Show nat := { show := nat_show }.

  Global Instance Show_positive : Show positive :=
    fun x => nat_show (Pos.to_nat x).

  Global Instance Show_Z : Show Z :=
    fun x =>
      match x with
      | Z0 => "0"%char
      | Zpos p => show p
      | Zneg p => "-"%char << show p
      end.

End hiding_notation.

Section pair_Show.
  Import ShowNotation.
  Local Open Scope show_scope.
  Definition pair_Show@{a m t}
              {A : Type@{a}} {B : Type@{a}} {AS:Show A} {BS:Show B}
  : Show@{_ t} (A*B) :=
    fun p =>
      let (a,b) := p in
      "("%char << show a << ","%char << show b << ")"%char.
End pair_Show.

(*
Examples:
Eval compute in (runShow (show (42,"foo"%string)) : string).
Eval compute in (runShow (show (inl true : bool+string))).
*)


From Hammer Require Import Hammer.

Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relations.
Require Import ExtLib.Structures.Proper.
Require Import ExtLib.Core.Type.

Set Implicit Arguments.
Set Strict Implicit.
Set Universe Polymorphism.

Definition Fun@{d c} (A : Type@{d}) (B : Type@{c}) := A -> B.

Section type.
Universe uT uU.
Variables (T : Type@{uT}) (U : Type@{uU}) (tT : type T) (tU : type U).

Global Instance type_Fun@{uU'} : type@{uU'} (T -> U) :=
{ equal := fun f g => respectful equal equal f g
; proper := fun x => respectful equal equal x x
}.

Variables (tOk : typeOk tT) (uOk : typeOk tU).

Global Instance typeOk_Fun@{uU'} : typeOk@{uU'} type_Fun.
Proof. hammer_hook "PreFun" "PreFun.typeOk_Fun".
constructor.
{ unfold equiv. simpl. unfold respectful.
destruct tOk. destruct uOk; intros.
split; intros.
{ destruct (only_proper _ _ H0).
etransitivity. eapply H. eassumption.
symmetry. eapply H. symmetry. auto. }
{ destruct (only_proper _ _ H0).
symmetry. etransitivity; [ | eapply H ].
symmetry. eapply H. eassumption. symmetry. eauto. } }
{ red. intros. apply H. }
{ compute. intuition. symmetry. eapply H. symmetry. auto. }
{ simpl; intro; intros. intuition. red in H; red in H0; simpl in *.
red; intros.
etransitivity. eapply H. eassumption.
eapply H0.
eapply only_proper in H1; intuition.
eapply preflexive with (wf := proper); auto.
apply tOk. }
Qed.

Global Instance proper_app@{uU'} : forall (f : T -> U) (a : T),
proper@{uU'} f -> proper a -> proper (f a).
Proof. hammer_hook "PreFun" "PreFun.proper_app".
simpl; intros. red in H.
eapply proper_left; eauto.
eapply H. eapply preflexive. eapply equiv_prefl; auto. auto.
Qed.

Theorem proper_fun@{uU'} : forall (f : T -> U),
(forall x y, equal x y -> equal (f x) (f y)) ->
proper@{uU'} f.
Proof. hammer_hook "PreFun" "PreFun.proper_fun".
intros. do 3 red. eauto.
Qed.

Theorem equal_fun@{uU'} : forall (f g : T -> U),
(forall x y, equal x y -> equal (f x) (g y)) ->
equal@{uU'} f g.
Proof. hammer_hook "PreFun" "PreFun.equal_fun". intros. do 3 red. apply H. Qed.

Theorem equal_app@{uU'} : forall (f g : T -> U) (x y : T),
equal@{uU'} f g -> equal x y ->
equal (f x) (g y).
Proof. hammer_hook "PreFun" "PreFun.equal_app".
clear. intros. do 3 red in H. auto.
Qed.

End type.

Definition compose@{uA uB uC} {A:Type@{uA}} {B:Type@{uB}} {C : Type@{uC}}
(g : B -> C) (f : A -> B) : A -> C :=
fun x => g (f x).


(** Administrative lemmas for Fsub.

    Authors: Brian Aydemir and Arthur Charguéraud, with help from
    Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis.

    This file contains a number of administrative lemmas that we
    require for proving type-safety.  The lemmas mainly concern the
    relations [wf_typ] and [wf_env].

    This file also contains regularity lemmas, which show that various
    relations hold only for locally closed terms.  In addition to
    being necessary to complete the proof of type-safety, these lemmas
    help demonstrate that our definitions are correct; they would be
    worth proving even if they are unneeded for any "real" proofs.

    Table of contents:
      - #Properties of wf_typ#
      - #Properties of wf_env and wf_typ#
      - #Properties of wf_env#
      - #Properties of substitution#
      - #Regularity lemmas#
      - #Automation# *)

Require Export Fsub_Infrastructure.

(* ********************************************************************** *)
(** * ## Properties of [wf_typ] *)

(** If a type is well-formed in an environment, then it is locally
    closed. *)

Lemma type_from_wf_typ : forall E T,
  wf_typ E T -> type T.
Proof.
  intros E T H; induction H; eauto.
Qed.

(** The remaining properties are analogous to the properties that we
    need to show for the subtyping and typing relations. *)

Lemma wf_typ_weakening : forall T E F G,
  wf_typ (G ++ E) T ->
  ok (G ++ F ++ E) ->
  wf_typ (G ++ F ++ E) T.
Proof with simpl_env; eauto.
  intros T E F G Hwf_typ Hk.
  remember (G ++ E).
  generalize dependent G.
  induction Hwf_typ; intros G Hok Heq; subst...
  Case "type_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- concat_assoc.
    apply H0...
Qed.

Lemma wf_typ_weaken_head : forall T E F,
  wf_typ E T ->
  ok (F ++ E) ->
  wf_typ (F ++ E) T.
Proof.
  intros.
  rewrite_env (empty ++ F++ E).
  auto using wf_typ_weakening.
Qed.

Lemma wf_typ_narrowing : forall V U T E F X,
  wf_typ (F ++ [(X, bind_sub V)] ++ E) T ->
  ok (F ++ [(X, bind_sub U)] ++ E) ->
  wf_typ (F ++ [(X, bind_sub U)] ++ E) T.
Proof with simpl_env; eauto.
  intros V U T E F X Hwf_typ Hok.
  remember (F ++ [(X, bind_sub V)] ++ E).
  generalize dependent F.
  induction Hwf_typ; intros F Hok Heq; subst...
  Case "wf_typ_var".
    binds_cases H...
  Case "typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- concat_assoc.
    apply H0...
Qed.

Lemma wf_typ_strengthening : forall E F x U T,
 wf_typ (F ++ [(x, bind_typ U)] ++ E) T ->
 wf_typ (F ++ E) T.
Proof with simpl_env; eauto.
  intros E F x U T H.
  remember (F ++ [(x, bind_typ U)] ++ E).
  generalize dependent F.
  induction H; intros F Heq; subst...
  Case "wf_typ_var".
    binds_cases H...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- concat_assoc.
    apply H1...
Qed.

Lemma wf_typ_subst_tb : forall F Q E Z P T,
  wf_typ (F ++ [(Z, bind_sub Q)] ++ E) T ->
  wf_typ E P ->
  ok (map (subst_tb Z P) F ++ E) ->
  wf_typ (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with simpl_env; eauto using wf_typ_weaken_head, type_from_wf_typ.
  intros F Q E Z P T WT WP.
  remember (F ++ [(Z, bind_sub Q)] ++ E).
  generalize dependent F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt...
  Case "wf_typ_var".
    destruct (X == Z); subst...
    SCase "X <> Z".
      binds_cases H...
      apply (wf_typ_var (subst_tt Z P U))...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) ([(Y, bind_sub T1)] ++ F) ++ E).
    apply H0...
Qed.

Lemma wf_typ_open : forall E U T1 T2,
  ok E ->
  wf_typ E (typ_all T1 T2) ->
  wf_typ E U ->
  wf_typ E (open_tt T2 U).
Proof with simpl_env; eauto.
  intros E U T1 T2 Ok WA WU.
  inversion WA; subst.
  pick fresh X.
  rewrite (subst_tt_intro X)...
  rewrite_env (map (subst_tb X U) empty ++ E).
  eapply wf_typ_subst_tb...
Qed.

(* ********************************************************************** *)
(** * ## Properties of [wf_env] and [wf_typ] *)

Lemma ok_from_wf_env : forall E,
  wf_env E ->
  ok E.
Proof.
  intros E H; induction H; auto.
Qed.

(** We add [ok_from_wf_env] as a hint here since it helps blur the
    distinction between [wf_env] and [ok] in proofs.  The lemmas in
    the [Environment] library use [ok], whereas here we naturally have
    (or can easily show) the stronger [wf_env].  Thus,
    [ok_from_wf_env] serves as a bridge that allows us to use the
    environments library. *)

Hint Resolve ok_from_wf_env : core.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  wf_typ E U.
Proof with auto using wf_typ_weaken_head.
  induction 1; intros J; binds_cases J...
  inversion H4; subst...
Qed.

Lemma wf_typ_from_wf_env_typ : forall x T E,
  wf_env ([(x, bind_typ T)] ++ E) ->
  wf_typ E T.
Proof.
  intros x T E H. inversion H; auto.
Qed.

Lemma wf_typ_from_wf_env_sub : forall x T E,
  wf_env ([(x, bind_sub T)] ++ E) ->
  wf_typ E T.
Proof.
  intros x T E H. inversion H; auto.
Qed.

(* ********************************************************************** *)
(** * ## Properties of [wf_env] *)

(** These properties are analogous to the properties that we need to
    show for the subtyping and typing relations. *)

Lemma wf_env_narrowing : forall V E F U X,
  wf_env (F ++ [(X, bind_sub V)] ++ E) ->
  wf_typ E U ->
  wf_env (F ++ [(X, bind_sub U)] ++ E).
Proof with eauto 6 using wf_typ_narrowing.
  induction F; intros U X Wf_env Wf;
    inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma wf_env_strengthening : forall x T E F,
  wf_env (F ++ [(x, bind_typ T)] ++ E) ->
  wf_env (F ++ E).
Proof with eauto using wf_typ_strengthening.
  induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma wf_env_subst_tb : forall Q Z P E F,
  wf_env (F ++ [(Z, bind_sub Q)] ++ E) ->
  wf_typ E P ->
  wf_env (map (subst_tb Z P) F ++ E).
Proof with eauto 6 using wf_typ_subst_tb.
  induction F; intros Wf_env WP; simpl_env;
    inversion Wf_env; simpl_env in *; simpl subst_tb...
Qed.

(* ********************************************************************** *)
(** * ## Environment is unchanged by substitution for a fresh name *)

Lemma notin_fv_tt_open : forall (Y X : atom) T,
  X `notin` fv_tt (open_tt T Y) ->
  X `notin` fv_tt T.
Proof.
 intros Y X T. unfold open_tt.
 generalize 0.
 induction T; simpl; intros k Fr; notin_simpl; try apply notin_union; eauto.
Qed.

Lemma notin_fv_wf : forall E (X : atom) T,
  wf_typ E T ->
  X `notin` dom E ->
  X `notin` fv_tt T.
Proof with auto.
  intros E X T Wf_typ.
  induction Wf_typ; intros Fr; simpl...
  Case "wf_typ_var".
    assert (X0 `in` (dom E))...
    eapply binds_In; eauto.
  Case "wf_typ_all".
    apply notin_union...
    pick fresh Y.
    apply (notin_fv_tt_open Y)...
Qed.

Lemma map_subst_tb_id : forall G Z P,
  wf_env G ->
  Z `notin` dom G ->
  G = map (subst_tb Z P) G.
Proof with auto.
  intros G Z P H.
  induction H; simpl; intros Fr; simpl_env...
  rewrite <- IHwf_env...
    rewrite <- subst_tt_fresh... eapply notin_fv_wf; eauto.
  rewrite <- IHwf_env...
    rewrite <- subst_tt_fresh... eapply notin_fv_wf; eauto.
Qed.

(* ********************************************************************** *)
(** * ## Regularity of relations *)

Lemma sub_regular : forall E S T,
  sub E S T ->
  wf_env E /\ wf_typ E S /\ wf_typ E T.
Proof with simpl_env; auto*.
  intros E S T H.
  induction H...
  Case "sub_trans_tvar".
    eauto*.
  Case "sub_all".
    repeat split...
    SCase "Second of original three conjuncts".
      pick fresh Y and apply wf_typ_all...
      destruct (H1 Y)...
      rewrite_env (empty ++ [(Y, bind_sub S1)] ++ E).
      apply (wf_typ_narrowing T1)...
    SCase "Third of original three conjuncts".
      pick fresh Y and apply wf_typ_all...
      destruct (H1 Y)...
Qed.

Lemma typing_regular : forall E e T,
  typing E e T ->
  wf_env E /\ expr e /\ wf_typ E T.
Proof with simpl_env; auto*.
  intros E e T H; induction H...
  Case "typing_var".
    repeat split...
    eauto using wf_typ_from_binds_typ.
  Case "typing_abs".
    pick fresh y.
    destruct (H0 y) as [Hok [J K]]...
    repeat split. inversion Hok...
    SCase "Second of original three conjuncts".
      pick fresh x and apply expr_abs.
        eauto using type_from_wf_typ, wf_typ_from_wf_env_typ.
        destruct (H0 x)...
    SCase "Third of original three conjuncts".
      apply wf_typ_arrow; eauto using wf_typ_from_wf_env_typ.
      rewrite_env (empty ++ E).
      eapply wf_typ_strengthening; simpl_env; eauto.
  Case "typing_app".
    repeat split...
    destruct IHtyping1 as [_ [_ K]].
    inversion K...
  Case "typing_tabs".
    pick fresh Y.
    destruct (H0 Y) as [Hok [J K]]...
    inversion Hok; subst.
    repeat split...
    SCase "Second of original three conjuncts".
      pick fresh X and apply expr_tabs.
        eauto using type_from_wf_typ, wf_typ_from_wf_env_sub...
        destruct (H0 X)...
    SCase "Third of original three conjuncts".
      pick fresh Z and apply wf_typ_all...
      destruct (H0 Z)...
  Case "typing_tapp".
    destruct (sub_regular _ _ _ H0) as [R1 [R2 R3]].
    repeat split...
    SCase "Second of original three conjuncts".
      apply expr_tapp...
      eauto using type_from_wf_typ.
    SCase "Third of original three conjuncts".
      destruct IHtyping as [R1' [R2' R3']].
      eapply wf_typ_open; eauto.
  Case "typing_sub".
    repeat split...
    destruct (sub_regular _ _ _ H0)...
Qed.

Lemma value_regular : forall e,
  value e ->
  expr e.
Proof.
  intros e H. induction H; auto.
Qed.

Lemma red_regular : forall e e',
  red e e' ->
  expr e /\ expr e'.
Proof with auto*.
  intros e e' H.
  induction H; assert(J := value_regular); split...
  Case "red_abs".
    inversion H. pick fresh y. rewrite (subst_ee_intro y)...
  Case "red_tabs".
    inversion H. pick fresh Y. rewrite (subst_te_intro Y)...
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** The lemma [ok_from_wf_env] was already added above as a hint since it
    helps blur the distinction between [wf_env] and [ok] in proofs.

    As currently stated, the regularity lemmas are ill-suited to be
    used with [auto] and [eauto] since they end in conjunctions.  Even
    if we were, for example, to split [sub_regularity] into three
    separate lemmas, the resulting lemmas would be usable only by
    [eauto] and there is no guarantee that [eauto] would be able to
    find proofs effectively.  Thus, the hints below apply the
    regularity lemmas and [type_from_wf_typ] to discharge goals about
    local closure and well-formedness, but in such a way as to
    minimize proof search.

    The first hint introduces an [wf_env] fact into the context.  It
    works well when combined with the lemmas relating [wf_env] and
    [wf_typ].  We choose to use those lemmas explicitly via [(auto
    using ...)] tactics rather than add them as hints.  When used this
    way, the explicitness makes the proof more informative rather than
    more cluttered (with useless details).

    The other three hints try outright to solve their respective
    goals. *)

Hint Extern 1 (wf_env ?E) =>
  match goal with
  | H: sub _ _ _ |- _ => apply (proj1 (sub_regular _ _ _ H))
  | H: typing _ _ _ |- _ => apply (proj1 (typing_regular _ _ _ H))
  end.

Hint Extern 1 (wf_typ ?E ?T) =>
  match goal with
  | H: typing E _ T |- _ => apply (proj2 (proj2 (typing_regular _ _ _ H)))
  | H: sub E T _ |- _ => apply (proj1 (proj2 (sub_regular _ _ _ H)))
  | H: sub E _ T |- _ => apply (proj2 (proj2 (sub_regular _ _ _ H)))
  end.

Hint Extern 1 (type ?T) =>
  let go E := apply (type_from_wf_typ E); auto in
  match goal with
  | H: typing ?E _ T |- _ => go E
  | H: sub ?E T _ |- _ => go E
  | H: sub ?E _ T |- _ => go E
  end.

Hint Extern 1 (expr ?e) =>
  match goal with
  | H: typing _ ?e _ |- _ => apply (proj1 (proj2 (typing_regular _ _ _ H)))
  | H: red ?e _ |- _ => apply (proj1 (red_regular _ _ H))
  | H: red _ ?e |- _ => apply (proj2 (red_regular _ _ H))
  end.


(* Copyright (c) Akira Kawata All rights reserved. *)

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
From Coq Require Import Lists.List.
From Coq Require Import Program.Basics.
From Egison Require Import Maps.

Module Egison.

  Definition varid := string.

   Inductive exp : Type :=
  | evar : varid -> exp
  | eint : nat -> exp
  (* | tlmb : varid -> exp -> exp *)
  (* | tapp : exp -> exp -> exp *)
  | etpl : exp -> exp -> exp
  | ecll : list exp -> exp
  | epair : exp -> exp -> exp
  | emal : exp -> exp -> (ptn * exp) -> exp
  | esm : exp
  | emtc : (list (pptn * exp * (list (dptn * exp)))) -> exp
  | etplmtc : exp -> exp -> exp
  with ptn : Type :=
  | pwld : ptn
  | pvar : varid -> ptn
  | pval : exp -> ptn
  | ppair : ptn -> ptn -> ptn
 with pptn : Type :=
  | ppdol : pptn
  | ppvar : varid -> pptn
  | pppair : pptn -> pptn -> pptn
  with dptn : Type :=
  | dpvar :  varid -> dptn
  | dppair :  dptn -> dptn -> dptn.

   Scheme exp_m_ind  := Minimality for exp Sort Prop
     with ptn_m_ind := Minimality for ptn Sort Prop
     with pptn_m_ind := Minimality for pptn Sort Prop
     with dptn_m_ind := Minimality for dptn Sort Prop.

   Combined Scheme exp_all_ind from exp_m_ind, ptn_m_ind, pptn_m_ind, dptn_m_ind.

   Inductive ty : Type :=
   | tint : ty
   | ttpl : ty -> ty -> ty
   | tcll : ty -> ty
   | tpair : ty -> ty -> ty
   | tmtc : list ty -> ty
   | tptn : ty -> ty
   | tpptn : ty -> list ty -> ty
   | tdptn : ty -> ty.

  (* Definition ppex1 := ppdol : pptn. *)

  Definition env := partial_map exp.
  Definition tenv := partial_map ty.

  (* Definition mlcssize (f : exp -> nat) (mcl : pptn * exp * (list (dptn * exp))) : nat := *)
  (*   let '(_, m1, l) := mcl in *)
  (*   max (f m1) (fold_left max (map (compose f snd) l) 0). *)

  (* Fixpoint expsize (m: exp) : nat := *)
  (*   match m with *)
  (*   | evar _ => 1 *)
  (*   | eint _ => 1 *)
  (*   (* | tlmb _ n => 1 + expsize n *) *)
  (*   (* | tapp n1 n2 => 1 + max (expsize n1) (expsize n2) *) *)
  (*   | etpl ms => 1 + fold_left max (map expsize ms) 0 *)
  (*   | ecll ms => 1 + fold_left max (map expsize ms) 0 *)
  (*   | epair m1 m2 => 1 + max (expsize m1) (expsize m2) *)
  (*   | emal m1 m2 pts => 1 + max (max (expsize m1) (expsize m2)) (fold_left max (map (compose expsize snd) pts) 0) *)
  (*   | esm => 1 *)
  (*   | emtc mcl => 1 + fold_left max (map (mlcssize expsize) mcl) 0 *)
  (*   end. *)

  Definition mclsvalue (f : exp -> Prop) (mcl : pptn * exp * (list (dptn * exp))) :=
    let '(_, m1, l) := mcl in (f m1) /\ (List.Forall (fun m => f (snd m))) l.

  Definition mclsexps (mcl : pptn * exp * (list (dptn * exp))) : list exp :=
    let '(_, m1, l) := mcl in
    m1 :: map (fun m => snd m) l.

  Inductive value : exp -> Prop :=
  | V_Var : forall i, value (evar i)
  | V_Int : forall i, value (eint i)
  | V_Tpl : forall m1 m2, value m1 -> value m2 -> value (etpl m1 m2)
  | V_Cll : forall ms, Forall value ms -> value (ecll ms)
  | V_Pair : forall m1 m2, value m1 /\ value m2 -> value (epair m1 m2)
  | V_Mal : forall m1 m2 pt, value m1 -> value m2 -> value (snd pt) -> value (emal m1 m2 pt)
  | V_Mtc : forall mcls, Forall value (concat (map mclsexps mcls)) -> value (emtc mcls)
  | V_Tplmtc : forall m1 m2, value m1 -> value m2 -> value (etplmtc m1 m2).
  (* | V_Lmb : forall i m, value (tlmb i m) *)

  Import ListNotations.

  Definition ms : Type := ((list (ptn * exp * env * exp)) * env * env).
  Definition ma : Type := (ptn * exp * env * exp).

  Fixpoint filtersome {A: Type} (l: list (option A)) : list A :=
    match l with
    | [] => []
    | (Some v)::r => v::filtersome r
    | None::r => filtersome r
    end.

  Inductive same_length_list {A B: Type} : (list A) -> (list B) -> Prop :=
  | sll_nil : same_length_list [] []
  | sll_cons : forall h1 h2 l1 l2, same_length_list l1 l2 -> same_length_list (h1::l1) (h2::l2).

  Inductive same_length_list3 {A B C: Type} : (list A) -> (list B) -> (list C) -> Prop :=
  | sll_nil3 : same_length_list3 [] [] []
  | sll_cons3 : forall h1 h2 h3 l1 l2 l3, same_length_list3 l1 l2 l3 -> same_length_list3 (h1::l1) (h2::l2) (h3::l3).

  Fixpoint zip {A B: Type} (l1:list A)  (l2: list B) : (list (A*B)) :=
    match (l1, l2) with
    | ([], _) => []
    | (_, []) => []
    | (h1::r1, h2::r2) => (h1,h2) :: zip r1 r2
    end.

  Fixpoint zip3 {A B C: Type} (l1:list A)  (l2: list B) (l3: list C) : (list (A*B*C)) :=
    match (l1, l2, l3) with
    | ([], _, _) => []
    | (_, [], _) => []
    | (_, _, []) => []
    | (h1::r1, h2::r2, h3::r3) => (h1,h2,h3) :: zip3 r1 r2 r3
    end.

  Fixpoint zip4 {A B C D: Type} (l1:list A)  (l2: list B) (l3: list C) (l4: list D) : (list (A*B*C*D)) :=
    match (l1, l2, l3, l4) with
    | ([], _, _, _) => []
    | (_, [], _, _) => []
    | (_, _, [], _) => []
    | (_, _, _, []) => []
    | (h1::r1, h2::r2, h3::r3, h4::r4) => (h1,h2,h3,h4) :: zip4 r1 r2 r3 r4
    end.

  Definition is_epair (t: exp) : Prop :=
    match t with
    | (epair _ _) => True
    | _ => False
    end.

  Definition is_pval (p: ptn) : Prop :=
    match p with
    | (pval _) => True
    | _ => False
    end.

  Definition is_ppair (p: ptn) : Prop :=
    match p with
    | (ppair _ _) => True
    | _ => False
    end.

  Inductive type : (tenv * exp * ty * tenv) -> Prop :=
  | T_Var : forall Gamma s T, Gamma s = Some T -> type (Gamma, (evar s), T, Gamma)
  | T_Int : forall Gamma i, type (Gamma, (eint i), tint, Gamma)
  | T_Pair : forall Gamma e1 T1 e2 T2, type (Gamma, e1, T1, Gamma) ->
                                  type (Gamma, e2, T2, Gamma) ->
                                  type (Gamma, (epair e1 e2), (tpair T1 T2), Gamma)
  | T_Tpl : forall Gamma e1 T1 e2 T2, type (Gamma, e1, T1, Gamma) ->
                                 type (Gamma, e2, T2, Gamma) ->
                                 type (Gamma, (etpl e1 e2), (ttpl T1 T2), Gamma)
  | T_Cll : forall Gamma es T, Forall type (map (fun e => (Gamma,e,T,Gamma)) es) ->
                          type (Gamma, (ecll es), (tcll T), Gamma)
  | T_Sm : forall Gamma T, type (Gamma, esm, (tmtc [T]), Gamma)
  | T_TplMtc : forall Gamma e1 T1 e2 T2 T12,
      type (Gamma, e1, (tmtc T1), Gamma) ->
      type (Gamma, e2, (tmtc T2), Gamma) ->
      T12 = T1 ++ T2 ->
      type (Gamma, (etplmtc e1 e2), (tmtc T12), Gamma)
  | T_Mtc : forall Gamma mcls T, Forall typemcl (map (fun m => (Gamma, m, T)) mcls) ->
                            type (Gamma, emtc mcls, tmtc [T], Gamma)
  | T_Mal : forall Gamma e1 e2 e3 T1 T2 Gamma1 p,
      type (Gamma, e1, T1, Gamma) ->
      type (Gamma, e2, (tmtc [T1]), Gamma) ->
      typeptn (Gamma, p, (tptn T1), Gamma1) ->
      type (Gamma1, e3, T2, Gamma1) ->
      type (Gamma, emal e1 e2 (p, e3), tcll T2, Gamma)
  with typemcl : (tenv * (pptn * exp * (list (dptn * exp))) * ty) -> Prop :=
  | TM_1 : forall Gamma pp M dpN_v T S,
      typepptn (Gamma, pp, tpptn T [S], Gamma) ->
      type (Gamma, M, tmtc [S], Gamma) ->
      Forall typedpN (map (fun dpN => (Gamma, dpN, T, [S])) dpN_v) ->
      typemcl (Gamma, (pp, M, dpN_v), T)
  | TM_2 : forall Gamma pp M dpN_v T S1 S2,
      typepptn (Gamma, pp, tpptn T [S1;S2], Gamma) ->
      type (Gamma, M, tmtc [S1;S2], Gamma) ->
      Forall typedpN (map (fun dpN => (Gamma, dpN, T, [S1;S2])) dpN_v) ->
      typemcl (Gamma, (pp, M, dpN_v), T)
  with typedpN : (tenv * (dptn * exp) * ty * list ty) -> Prop :=
  | TDN_1 : forall Gamma dp N T S Gamma1,
      typedptn (Gamma, dp, tdptn T, Gamma1) -> type (Gamma1, N, tcll S, Gamma1) ->
      typedpN (Gamma, (dp, N), T, [S])
  | TDN_2 : forall Gamma dp N T S1 S2 Gamma1,
      typedptn (Gamma, dp, tdptn T, Gamma1) -> type (Gamma1, N, tcll (ttpl S1 S2), Gamma1) ->
      typedpN (Gamma, (dp, N), T, [S1;S2])
  with typeptn : (tenv * ptn * ty * tenv) -> Prop :=
  | TP_Wld : forall Gamma T, typeptn (Gamma, pwld, T, Gamma)
  | TP_Var : forall Gamma s T, typeptn (Gamma, (pvar s), (tptn T), s |-> T ; Gamma)
  | TP_Val : forall Gamma e T, type (Gamma, e, T, Gamma) -> typeptn (Gamma, pval e, tptn T, Gamma)
  | TP_Pair : forall Gamma p1 T1 p2 T2 Gamma1 Gamma2,
      typeptn (Gamma, p1, tptn T1, Gamma1) ->
      typeptn (Gamma1, p2, tptn T2, Gamma2) ->
      typeptn (Gamma, ppair p1 p2, tptn (tpair T1 T2), Gamma2)
  with typepptn : (tenv * pptn * ty * tenv) -> Prop :=
  | TPP_Dol : forall Gamma T, typepptn (Gamma, ppdol, tpptn T [T], Gamma)
  | TPP_Var : forall Gamma s T, typepptn (Gamma, ppvar s, tpptn T [], Gamma)
  | TPP_Pair : forall Gamma pp1 T1 S1 pp2 T2 S2 S12,
      typepptn (Gamma, pp1, tpptn T1 S1, Gamma) ->
      typepptn (Gamma, pp2, tpptn T2 S2, Gamma) ->
      S12 = S1 ++ S2 ->
      typepptn (Gamma, pppair pp1 pp2, tpptn (tpair T1 T2) S12, Gamma)
  with typedptn : (tenv * dptn * ty * tenv) -> Prop :=
  | TDP_Var : forall Gamma s T, typedptn (Gamma, (dpvar s), (tdptn T), s |-> T ; Gamma)
  | TDP_Pair : forall Gamma dp1 T1 Gamma1 dp2 T2 Gamma2,
      typedptn (Gamma, dp1, tdptn T1, Gamma1) ->
      typedptn (Gamma, dp2, tdptn T2, Gamma2) ->
      typedptn (Gamma, dppair dp1 dp2, tdptn (tpair T1 T2), Gamma1 @@ Gamma2).

  Scheme type_m_ind  := Minimality for type Sort Prop
    with typemcl_m_ind := Induction for typemcl Sort Prop
    with typedpN_m_ind := Induction for typedpN Sort Prop
    with typeptn_m_ind := Minimality for typeptn Sort Prop
    with typepptn_m_ind := Induction for typepptn Sort Prop
    with typedptn_m_ind := Induction for typedptn Sort Prop.

  Combined Scheme type_all_ind from type_m_ind, typemcl_m_ind, typedpN_m_ind, typeptn_m_ind, typepptn_m_ind, typedptn_m_ind.
  Check type_all_ind.

  Theorem T_Int_example : type (empty, (eint 10), tint, empty).
  Proof.
    econstructor.
  Qed.

  Inductive eval : (env * exp * exp)-> Prop :=
  | E_VarIn : forall i Gamma t, (Gamma i) = Some t -> eval (Gamma, (evar i), t)
  | E_VarOut : forall i Gamma, (Gamma i) = None -> eval (Gamma, (evar i), (evar i))
  | E_Int : forall i e, eval (e, (eint i), (eint i))
  | E_Tpl : forall Gamma t1 t2 v1 v2, eval (Gamma, t1, v1) -> eval (Gamma, t2, v2) -> eval (Gamma, etpl t1 t2, etpl v1 v2)
  | E_Cll : forall e ts vs, same_length_list ts vs ->
                      Forall eval (map (fun tpl => let '(t,v) := tpl in (e,t,v)) (zip ts vs)) -> eval (e, (ecll ts), (ecll vs))
  | E_Pair : forall e t1 t2 v1 v2, eval (e, t1, v1) -> eval (e, t2, v2) -> eval (e, (epair t1 t2), (epair v1 v2))
  | E_Sm : forall Gamma, eval (Gamma, esm, esm)
  (* | emtc : forall Gamma (ts: (list (pptn * exp * (list (dptn * exp))))), eval Gamma ((emtc ts), (emtc vs)) *)
  | E_Tplmtc : forall Gamma t1 t2 v1 v2, eval (Gamma, t1, v1) -> eval (Gamma, t2, v2) -> eval (Gamma, etplmtc t1 t2, etplmtc v1 v2)
  | E_Emal : forall Gamma M N p L v_v v m_m m_e Delta_v, same_length_list Delta_v v_v -> eval (Gamma, M,v) -> evalmtc Gamma N [(m_m, m_e)] -> evalms3 [[([(p,m_m,m_e,v)], Gamma, empty)]] Delta_v ->
                                                  Forall eval (map (fun t => let '(d,v) := t in (Gamma @@ d, L, v)) (zip Delta_v v_v)) ->
                                                  eval (Gamma, (emal M N (p, L)), ecll v_v)

  with evalmtc : env -> exp -> list (exp * env) -> Prop :=
  | Emtc_Sm : forall Gamma, evalmtc Gamma esm [(esm, Gamma)]
  | Emtc_Mtc : forall Gamma l, evalmtc Gamma (emtc l) [((emtc l), Gamma)]
  | Emtc_Tpl : forall Gamma m1 m2 n1 n2, eval (Gamma, (etplmtc m1 m2), (etplmtc n1 n2)) -> evalmtc Gamma (etplmtc m1 m2) [(n1, Gamma); (n2, Gamma)]

  with evaldp : dptn -> exp -> option env -> Prop :=
  | Edp_Var : forall z v, value v -> evaldp (dpvar z) v (Some (z |-> v))
  | Edp_Pair : forall p1 p2 v1 v2 g1 g2,
      value v1 -> value v2 -> evaldp p1 v1 (Some g1) -> evaldp p2 v2 (Some g2) ->
      evaldp (dppair p1 p2) (epair v1 v2) (Some (g1 @@ g2))
  | Edp_Fail : forall t p1 p2, not (is_epair t) -> evaldp (dppair p1 p2) t None

  with evalpp : pptn -> env -> ptn -> option ((list ptn) * env) -> Prop :=
  | Epp_Dol : forall g p, evalpp ppdol g p (Some ([p], empty))
  | Epp_Var : forall i g m v, eval (g, m, v) -> evalpp (ppvar i) g (pval m) (Some ([], (i |-> v)))
  | Epp_Pair : forall pp1 pp2 p1 p2 g pv1 pv2 g1 g2,
                evalpp pp1 g p1 (Some (pv1,g1)) -> evalpp pp2 g p2 (Some (pv2,g2)) ->
                evalpp (pppair pp1 pp2) g (ppair p1 p2) (Some ((pv1 ++ pv2), (g1 @@ g2)))
  | Epp_VarFail : forall y g p, not (is_pval p) -> evalpp (ppvar y) g p None
  | Epp_PairFail : forall pp1 pp2 p g, not (is_ppair p) -> evalpp (pppair pp1 pp2) g p None

  with evalms1 : ((list ms) * option env * option (list ms)) -> Prop :=
  | Ems1_Nil : evalms1 ([], None, None)
  | Ems1_ANil : forall sv g d, evalms1 ((([],g,d)::sv), (Some d), (Some sv))
  | Ems1 : forall p m mg v av g d sv avv d1,
        evalma (g @@ d) (p,m,mg,v) avv d1 ->
        evalms1 ((((p,m,mg,v)::av, g, d)::sv), None, (Some ((map (fun ai => (ai ++ av, g, d @@ d1)) avv) ++ sv)))

  with evalms2 : (list (list ms)) -> (list env) -> (list (list ms)) -> Prop :=
  | Ems2 : forall svv gvv svv1 gvv1 svv2,
      same_length_list3 svv gvv svv1 ->
      Forall evalms1 (zip3 svv gvv svv1) ->
      (filtersome gvv) = gvv1 ->
      (filtersome svv1) = svv2 ->
      evalms2 svv gvv1 svv2

  with evalms3 : (list (list ms)) -> (list env) -> Prop :=
  | Ems3_Nil : evalms3 [[]] []
  | Ems3 : forall svv gv svv1 dv gdv, evalms2 svv gv svv1 -> evalms3 svv1 dv -> gdv = gv ++ dv ->
                             evalms3 svv gdv

  with evalma : env -> ma -> list (list ma) -> env -> Prop :=
  | Ema_Some : forall x g v d, evalma g (pvar x, esm, d, v) [[]] (x |-> v)
  | Ema_PpFail : forall p g pp m sv pv d v avv g1,
      evalpp pp g p None -> evalma g (p,(emtc pv),d,v) avv g1 ->
      evalma g (p,emtc ((pp,m,sv)::pv),d,v) avv g1
  | Ema_DpFail : forall p g pp m dp n sv pv d v pv1 d1 avv g1,
      evalpp pp g p (Some (pv1, d1)) -> evaldp dp v None ->
      evalma g (p, emtc ((pp,m,sv)::pv),d,v) avv g1 ->
      evalma g (p, emtc ((pp,m,(dp,n)::sv)::pv),d,v) avv g1
  | Ema : forall p Gamma pp M dp N sigma_v Delta v phi1_v p1_v Delta1 Delta2 v1_vv m1_v,
      evalpp pp Gamma p (Some (p1_v, Delta1)) ->
      evaldp dp v (Some Delta2) ->
      eval (Delta @@ Delta1 @@ Delta2, N, ecll v1_vv) ->
      evalmtc Gamma M m1_v ->
      evalma Gamma (p, emtc ((pp,M,(dp,N)::sigma_v)::phi1_v), Delta, v)
             ((map (fun tpl => match tpl with
                              | (etpl v11 v12) => map (fun t => let '(v1, (m1, Gamma1), p1) := t in (p1,m1,Gamma1,v1)) (zip3 [v11;v12] m1_v p1_v)
                              | v11 => map (fun t => let '(v1, (m1, Gamma1), p1) := t in (p1,m1,Gamma1,v1)) (zip3 [v11] m1_v p1_v)
                              end
                   ) v1_vv)) empty.

  (* Following Egison code is translated into Coq as follows. *)
  (* (define $unordered-pair *)
  (*   (matcher *)
  (*     {[<pair $ $> [something something] *)
  (*       {[[$x $y] {[x y] [y x]}]}] *)
  (*      [$ something *)
  (*       {[$tgt {tgt}]}]})) *)

  (* (match-all [1 2] unordered-pair {[<pair $a $b> [a b]]}) ===> {[1,2] [2,1]} *)

  Open Scope string_scope.
  Definition unordered_pair: exp :=
    (emtc [(pppair ppdol ppdol, etplmtc esm esm,
            [(dppair (dpvar "x") (dpvar "y"), (ecll [(etpl (evar "x") (evar "y")); etpl (evar "y") (evar "x")]))]);
           (ppdol, esm,
            [(dpvar "tgt", ecll [evar "tgt"])])]).

  Definition match_all_example: exp :=
    (emal (epair (eint 1) (eint 2)) unordered_pair (ppair (pvar "a") (pvar "b"),etpl (evar "a") (evar "b"))).
  Theorem unordered_pair_example : eval (empty, match_all_example, ecll [etpl (eint 1) (eint 2);etpl (eint 2) (eint 1)]).
  Proof.
    econstructor.
    - repeat econstructor.
    - repeat econstructor.
    - repeat econstructor.
    - econstructor.
      + econstructor.
        * repeat econstructor.
        * econstructor.
          -- econstructor.
             eapply Ema.
             --- repeat econstructor.
             --- repeat econstructor.
             --- repeat econstructor.
             --- repeat econstructor.
          -- repeat constructor.
        * repeat constructor.
        * repeat constructor.
      + repeat econstructor.
      + repeat econstructor.
    - repeat econstructor.
  Qed.

  Theorem unordered_pair_type_example : type (empty, match_all_example, tcll (ttpl tint tint), empty).
  Proof.
    econstructor.
    - repeat econstructor.
    - econstructor.
      econstructor.
      + eapply TM_2.
        * repeat econstructor.
        * repeat econstructor.
        * repeat econstructor.
      + repeat econstructor.
    - repeat econstructor.
    - repeat econstructor.
  Qed.
End Egison.