From stdpp Require Export functions gmap gmultiset.
From iris.algebra Require Export monoid.
From iris.prelude Require Import options.
Local Existing Instances monoid_ne monoid_assoc monoid_comm
  monoid_left_id monoid_right_id monoid_proper
  monoid_homomorphism_rel_po monoid_homomorphism_rel_proper
  monoid_homomorphism_op_proper
  monoid_homomorphism_ne weak_monoid_homomorphism_proper.

(** We define the following big operators with binders build in:

- The operator [ [^o list] k ↦ x ∈ l, P ] folds over a list [l]. The binder [x]
  refers to each element at index [k].
- The operator [ [^o map] k ↦ x ∈ m, P ] folds over a map [m]. The binder [x]
  refers to each element at index [k].
- The operator [ [^o set] x ∈ X, P ] folds over a set [X]. The binder [x] refers
  to each element.

Since these big operators are like quantifiers, they have the same precedence as
[∀] and [∃]. *)

(** * Big ops over lists *)
Fixpoint big_opL `{Monoid M o} {A} (f : nat → A → M) (xs : list A) : M :=
  match xs with
  | [] => monoid_unit
  | x :: xs => o (f 0 x) (big_opL (λ n, f (S n)) xs)
  end.
Global Instance: Params (@big_opL) 4 := {}.
Global Arguments big_opL {M} o {_ A} _ !_ /.
Typeclasses Opaque big_opL.
Notation "'[^' o 'list]' k ↦ x ∈ l , P" := (big_opL o (λ k x, P) l)
  (at level 200, o at level 1, l at level 10, k, x at level 1, right associativity,
   format "[^ o  list]  k ↦ x  ∈  l ,  P") : stdpp_scope.
Notation "'[^' o 'list]' x ∈ l , P" := (big_opL o (λ _ x, P) l)
  (at level 200, o at level 1, l at level 10, x at level 1, right associativity,
   format "[^ o  list]  x  ∈  l ,  P") : stdpp_scope.

Definition big_opM_def `{Monoid M o} `{Countable K} {A} (f : K → A → M)
  (m : gmap K A) : M := big_opL o (λ _, curry f) (map_to_list m).
Definition big_opM_aux : seal (@big_opM_def). Proof. by eexists. Qed.
Definition big_opM := big_opM_aux.(unseal).
Global Arguments big_opM {M} o {_ K _ _ A} _ _.
Definition big_opM_eq : @big_opM = @big_opM_def := big_opM_aux.(seal_eq).
Global Instance: Params (@big_opM) 7 := {}.
Notation "'[^' o 'map]' k ↦ x ∈ m , P" := (big_opM o (λ k x, P) m)
  (at level 200, o at level 1, m at level 10, k, x at level 1, right associativity,
   format "[^  o  map]  k ↦ x  ∈  m ,  P") : stdpp_scope.
Notation "'[^' o 'map]' x ∈ m , P" := (big_opM o (λ _ x, P) m)
  (at level 200, o at level 1, m at level 10, x at level 1, right associativity,
   format "[^ o  map]  x  ∈  m ,  P") : stdpp_scope.

Definition big_opS_def `{Monoid M o} `{Countable A} (f : A → M)
  (X : gset A) : M := big_opL o (λ _, f) (elements X).
Definition big_opS_aux : seal (@big_opS_def). Proof. by eexists. Qed.
Definition big_opS := big_opS_aux.(unseal).
Global Arguments big_opS {M} o {_ A _ _} _ _.
Definition big_opS_eq : @big_opS = @big_opS_def := big_opS_aux.(seal_eq).
Global Instance: Params (@big_opS) 6 := {}.
Notation "'[^' o 'set]' x ∈ X , P" := (big_opS o (λ x, P) X)
  (at level 200, o at level 1, X at level 10, x at level 1, right associativity,
   format "[^ o  set]  x  ∈  X ,  P") : stdpp_scope.

Definition big_opMS_def `{Monoid M o} `{Countable A} (f : A → M)
  (X : gmultiset A) : M := big_opL o (λ _, f) (elements X).
Definition big_opMS_aux : seal (@big_opMS_def). Proof. by eexists. Qed.
Definition big_opMS := big_opMS_aux.(unseal).
Global Arguments big_opMS {M} o {_ A _ _} _ _.
Definition big_opMS_eq : @big_opMS = @big_opMS_def := big_opMS_aux.(seal_eq).
Global Instance: Params (@big_opMS) 6 := {}.
Notation "'[^' o 'mset]' x ∈ X , P" := (big_opMS o (λ x, P) X)
  (at level 200, o at level 1, X at level 10, x at level 1, right associativity,
   format "[^ o  mset]  x  ∈  X ,  P") : stdpp_scope.

(** * Properties about big ops *)
Section big_op.
Context `{Monoid M o}.
Implicit Types xs : list M.
Infix "`o`" := o (at level 50, left associativity).

(** ** Big ops over lists *)
Section list.
  Context {A : Type}.
  Implicit Types l : list A.
  Implicit Types f g : nat → A → M.

  Lemma big_opL_nil f : ([^o list] k↦y ∈ [], f k y) = monoid_unit.
  Proof. done. Qed.
  Lemma big_opL_cons f x l :
    ([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (S k) y.
  Proof. done. Qed.
  Lemma big_opL_singleton f x : ([^o list] k↦y ∈ [x], f k y) ≡ f 0 x.
  Proof. by rewrite /= right_id. Qed.
  Lemma big_opL_app f l1 l2 :
    ([^o list] k↦y ∈ l1 ++ l2, f k y)
    ≡ ([^o list] k↦y ∈ l1, f k y) `o` ([^o list] k↦y ∈ l2, f (length l1 + k) y).
  Proof.
    revert f. induction l1 as [|x l1 IH]=> f /=; first by rewrite left_id.
    by rewrite IH assoc.
  Qed.
  Lemma big_opL_snoc f l x :
    ([^o list] k↦y ∈ l ++ [x], f k y) ≡ ([^o list] k↦y ∈ l, f k y) `o` f (length l) x.
  Proof. rewrite big_opL_app big_opL_singleton Nat.add_0_r //. Qed.

  Lemma big_opL_unit l : ([^o list] k↦y ∈ l, monoid_unit) ≡ (monoid_unit : M).
  Proof. induction l; rewrite /= ?left_id //. Qed.

  Lemma big_opL_gen_proper_2 {B} (R : relation M) f (g : nat → B → M)
        l1 (l2 : list B) :
    R monoid_unit monoid_unit →
    Proper (R ==> R ==> R) o →
    (∀ k,
      match l1 !! k, l2 !! k with
      | Some y1, Some y2 => R (f k y1) (g k y2)
      | None, None => True
      | _, _ => False
      end) →
    R ([^o list] k ↦ y ∈ l1, f k y) ([^o list] k ↦ y ∈ l2, g k y).
  Proof.
    intros ??. revert l2 f g. induction l1 as [|x1 l1 IH]=> -[|x2 l2] //= f g Hfg.
    - by specialize (Hfg 0).
    - by specialize (Hfg 0).
    - f_equiv; [apply (Hfg 0)|]. apply IH. intros k. apply (Hfg (S k)).
  Qed.
  Lemma big_opL_gen_proper R f g l :
    Reflexive R →
    Proper (R ==> R ==> R) o →
    (∀ k y, l !! k = Some y → R (f k y) (g k y)) →
    R ([^o list] k ↦ y ∈ l, f k y) ([^o list] k ↦ y ∈ l, g k y).
  Proof.
    intros. apply big_opL_gen_proper_2; [done..|].
    intros k. destruct (l !! k) eqn:?; auto.
  Qed.

  Lemma big_opL_ext f g l :
    (∀ k y, l !! k = Some y → f k y = g k y) →
    ([^o list] k ↦ y ∈ l, f k y) = [^o list] k ↦ y ∈ l, g k y.
  Proof. apply big_opL_gen_proper; apply _. Qed.

  Lemma big_opL_permutation (f : A → M) l1 l2 :
    l1 ≡ₚ l2 → ([^o list] x ∈ l1, f x) ≡ ([^o list] x ∈ l2, f x).
  Proof.
    induction 1 as [|x xs1 xs2 ? IH|x y xs|xs1 xs2 xs3]; simpl; auto.
    - by rewrite IH.
    - by rewrite !assoc (comm _ (f x)).
    - by etrans.
  Qed.
  Global Instance big_opL_permutation' (f : A → M) :
    Proper ((≡ₚ) ==> (≡)) (big_opL o (λ _, f)).
  Proof. intros xs1 xs2. apply big_opL_permutation. Qed.

  (** The lemmas [big_opL_ne] and [big_opL_proper] are more generic than the
  instances as they also give [l !! k = Some y] in the premise. *)
  Lemma big_opL_ne f g l n :
    (∀ k y, l !! k = Some y → f k y ≡{n}≡ g k y) →
    ([^o list] k ↦ y ∈ l, f k y) ≡{n}≡ ([^o list] k ↦ y ∈ l, g k y).
  Proof. apply big_opL_gen_proper; apply _. Qed.
  Lemma big_opL_proper f g l :
    (∀ k y, l !! k = Some y → f k y ≡ g k y) →
    ([^o list] k ↦ y ∈ l, f k y) ≡ ([^o list] k ↦ y ∈ l, g k y).
  Proof. apply big_opL_gen_proper; apply _. Qed.

  (** The version [big_opL_proper_2] with [≡] for the list arguments can only be
  used if there is a setoid on [A]. The version for [dist n] can be found in
  [algebra.list]. We do not define this lemma as a [Proper] instance, since
  [f_equiv] will then use sometimes use this one, and other times
  [big_opL_proper'], depending on whether a setoid on [A] exists. *)
  Lemma big_opL_proper_2 `{!Equiv A} f g l1 l2 :
    l1 ≡ l2 →
    (∀ k y1 y2,
      l1 !! k = Some y1 → l2 !! k = Some y2 → y1 ≡ y2 → f k y1 ≡ g k y2) →
    ([^o list] k ↦ y ∈ l1, f k y) ≡ ([^o list] k ↦ y ∈ l2, g k y).
  Proof.
    intros Hl Hf. apply big_opL_gen_proper_2; try (apply _ || done).
    intros k. assert (l1 !! k ≡ l2 !! k) as Hlk by (by f_equiv).
    destruct (l1 !! k) eqn:?, (l2 !! k) eqn:?; inversion Hlk; naive_solver.
  Qed.

  Global Instance big_opL_ne' n :
    Proper (pointwise_relation _ (pointwise_relation _ (dist n)) ==> (=) ==> dist n)
           (big_opL o (A:=A)).
  Proof. intros f f' Hf l ? <-. apply big_opL_ne; intros; apply Hf. Qed.
  Global Instance big_opL_proper' :
    Proper (pointwise_relation _ (pointwise_relation _ (≡)) ==> (=) ==> (≡))
           (big_opL o (A:=A)).
  Proof. intros f f' Hf l ? <-. apply big_opL_proper; intros; apply Hf. Qed.

  Lemma big_opL_consZ_l (f : Z → A → M) x l :
    ([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (1 + k)%Z y.
  Proof. rewrite big_opL_cons. auto using big_opL_ext with f_equal lia. Qed.
  Lemma big_opL_consZ_r (f : Z → A → M) x l :
    ([^o list] k↦y ∈ x :: l, f k y) = f 0 x `o` [^o list] k↦y ∈ l, f (k + 1)%Z y.
  Proof. rewrite big_opL_cons. auto using big_opL_ext with f_equal lia. Qed.

  Lemma big_opL_fmap {B} (h : A → B) (f : nat → B → M) l :
    ([^o list] k↦y ∈ h <$> l, f k y) ≡ ([^o list] k↦y ∈ l, f k (h y)).
  Proof. revert f. induction l as [|x l IH]=> f; csimpl=> //. by rewrite IH. Qed.

  Lemma big_opL_omap {B} (h : A → option B) (f : B → M) l :
    ([^o list] y ∈ omap h l, f y) ≡ ([^o list] y ∈ l, from_option f monoid_unit (h y)).
  Proof.
    revert f. induction l as [|x l IH]=> f //; csimpl.
    case_match; csimpl; by rewrite IH // left_id.
  Qed.

  Lemma big_opL_op f g l :
    ([^o list] k↦x ∈ l, f k x `o` g k x)
    ≡ ([^o list] k↦x ∈ l, f k x) `o` ([^o list] k↦x ∈ l, g k x).
  Proof.
    revert f g; induction l as [|x l IH]=> f g /=; first by rewrite left_id.
    by rewrite IH -!assoc (assoc _ (g _ _)) [(g _ _ `o` _)]comm -!assoc.
  Qed.
End list.

Lemma big_opL_bind {A B} (h : A → list B) (f : B → M) l :
  ([^o list] y ∈ l ≫= h, f y) ≡ ([^o list] x ∈ l, [^o list] y ∈ h x, f y).
Proof.
  revert f. induction l as [|x l IH]=> f; csimpl=> //. by rewrite big_opL_app IH.
Qed.

Lemma big_opL_sep_zip_with {A B C} (f : A → B → C) (g1 : C → A) (g2 : C → B)
    (h1 : nat → A → M) (h2 : nat → B → M) l1 l2 :
  (∀ x y, g1 (f x y) = x) →
  (∀ x y, g2 (f x y) = y) →
  length l1 = length l2 →
  ([^o list] k↦xy ∈ zip_with f l1 l2, h1 k (g1 xy) `o` h2 k (g2 xy)) ≡
  ([^o list] k↦x ∈ l1, h1 k x) `o` ([^o list] k↦y ∈ l2, h2 k y).
Proof.
  intros Hlen Hg1 Hg2. rewrite big_opL_op.
  rewrite -(big_opL_fmap g1) -(big_opL_fmap g2).
  rewrite fmap_zip_with_r; [|auto with lia..].
  by rewrite fmap_zip_with_l; [|auto with lia..].
Qed.

Lemma big_opL_sep_zip {A B} (h1 : nat → A → M) (h2 : nat → B → M) l1 l2 :
  length l1 = length l2 →
  ([^o list] k↦xy ∈ zip l1 l2, h1 k xy.1 `o` h2 k xy.2) ≡
  ([^o list] k↦x ∈ l1, h1 k x) `o` ([^o list] k↦y ∈ l2, h2 k y).
Proof. by apply big_opL_sep_zip_with. Qed.

(** ** Big ops over finite maps *)

Lemma big_opM_empty `{Countable K} {B} (f : K → B → M) :
  ([^o map] k↦x ∈ ∅, f k x) = monoid_unit.
Proof. by rewrite big_opM_eq /big_opM_def map_to_list_empty. Qed.

Lemma big_opM_insert `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
  m !! i = None →
  ([^o map] k↦y ∈ <[i:=x]> m, f k y) ≡ f i x `o` [^o map] k↦y ∈ m, f k y.
Proof. intros ?. by rewrite big_opM_eq /big_opM_def map_to_list_insert. Qed.

Lemma big_opM_delete `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
  m !! i = Some x →
  ([^o map] k↦y ∈ m, f k y) ≡ f i x `o` [^o map] k↦y ∈ delete i m, f k y.
Proof.
  intros. rewrite -big_opM_insert ?lookup_delete //.
  by rewrite insert_delete insert_id.
Qed.

Section gmap.
  Context `{Countable K} {A : Type}.
  Implicit Types m : gmap K A.
  Implicit Types f g : K → A → M.

  Lemma big_opM_gen_proper_2 {B} (R : relation M) f (g : K → B → M)
        m1 (m2 : gmap K B) :
    subrelation (≡) R → Equivalence R →
    Proper (R ==> R ==> R) o →
    (∀ k,
      match m1 !! k, m2 !! k with
      | Some y1, Some y2 => R (f k y1) (g k y2)
      | None, None => True
      | _, _ => False
      end) →
    R ([^o map] k ↦ x ∈ m1, f k x) ([^o map] k ↦ x ∈ m2, g k x).
  Proof.
    intros HR ??. revert m2 f g.
    induction m1 as [|k x1 m1 Hm1k IH] using map_ind=> m2 f g Hfg.
    { destruct m2 as [|k x2 m2 _ _] using map_ind.
      { rewrite !big_opM_empty. by apply HR. }
      generalize (Hfg k). by rewrite lookup_empty lookup_insert. }
    generalize (Hfg k). rewrite lookup_insert.
    destruct (m2 !! k) as [x2|] eqn:Hm2k; [intros Hk|done].
    etrans; [by apply HR, big_opM_insert|].
    etrans; [|by symmetry; apply HR, big_opM_delete].
    f_equiv; [done|]. apply IH=> k'. destruct (decide (k = k')) as [->|?].
    - by rewrite lookup_delete Hm1k.
    - generalize (Hfg k'). rewrite lookup_insert_ne // lookup_delete_ne //.
  Qed.

  Lemma big_opM_gen_proper R f g m :
    Reflexive R →
    Proper (R ==> R ==> R) o →
    (∀ k x, m !! k = Some x → R (f k x) (g k x)) →
    R ([^o map] k ↦ x ∈ m, f k x) ([^o map] k ↦ x ∈ m, g k x).
  Proof.
    intros ?? Hf. rewrite big_opM_eq. apply (big_opL_gen_proper R); auto.
    intros k [i x] ?%elem_of_list_lookup_2. by apply Hf, elem_of_map_to_list.
  Qed.

  Lemma big_opM_ext f g m :
    (∀ k x, m !! k = Some x → f k x = g k x) →
    ([^o map] k ↦ x ∈ m, f k x) = ([^o map] k ↦ x ∈ m, g k x).
  Proof. apply big_opM_gen_proper; apply _. Qed.

  (** The lemmas [big_opM_ne] and [big_opM_proper] are more generic than the
  instances as they also give [m !! k = Some y] in the premise. *)
  Lemma big_opM_ne f g m n :
    (∀ k x, m !! k = Some x → f k x ≡{n}≡ g k x) →
    ([^o map] k ↦ x ∈ m, f k x) ≡{n}≡ ([^o map] k ↦ x ∈ m, g k x).
  Proof. apply big_opM_gen_proper; apply _. Qed.
  Lemma big_opM_proper f g m :
    (∀ k x, m !! k = Some x → f k x ≡ g k x) →
    ([^o map] k ↦ x ∈ m, f k x) ≡ ([^o map] k ↦ x ∈ m, g k x).
  Proof. apply big_opM_gen_proper; apply _. Qed.
  (** The version [big_opM_proper_2] with [≡] for the map arguments can only be
  used if there is a setoid on [A]. The version for [dist n] can be found in
  [algebra.gmap]. We do not define this lemma as a [Proper] instance, since
  [f_equiv] will then use sometimes use this one, and other times
  [big_opM_proper'], depending on whether a setoid on [A] exists. *)
  Lemma big_opM_proper_2 `{!Equiv A} f g m1 m2 :
    m1 ≡ m2 →
    (∀ k y1 y2,
      m1 !! k = Some y1 → m2 !! k = Some y2 → y1 ≡ y2 → f k y1 ≡ g k y2) →
    ([^o map] k ↦ y ∈ m1, f k y) ≡ ([^o map] k ↦ y ∈ m2, g k y).
  Proof.
    intros Hl Hf. apply big_opM_gen_proper_2; try (apply _ || done).
    intros k. assert (m1 !! k ≡ m2 !! k) as Hlk by (by f_equiv).
    destruct (m1 !! k) eqn:?, (m2 !! k) eqn:?; inversion Hlk; naive_solver.
  Qed.

  Global Instance big_opM_ne' n :
    Proper (pointwise_relation _ (pointwise_relation _ (dist n)) ==> (=) ==> dist n)
           (big_opM o (K:=K) (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opM_ne; intros; apply Hf. Qed.
  Global Instance big_opM_proper' :
    Proper (pointwise_relation _ (pointwise_relation _ (≡)) ==> (=) ==> (≡))
           (big_opM o (K:=K) (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opM_proper; intros; apply Hf. Qed.

  Lemma big_opM_singleton f i x : ([^o map] k↦y ∈ {[i:=x]}, f k y) ≡ f i x.
  Proof.
    rewrite -insert_empty big_opM_insert/=; last eauto using lookup_empty.
    by rewrite big_opM_empty right_id.
  Qed.

  Lemma big_opM_unit m : ([^o map] k↦y ∈ m, monoid_unit) ≡ (monoid_unit : M).
  Proof.
    by induction m using map_ind; rewrite /= ?big_opM_insert ?left_id // big_opM_eq.
  Qed.

  Lemma big_opM_fmap {B} (h : A → B) (f : K → B → M) m :
    ([^o map] k↦y ∈ h <$> m, f k y) ≡ ([^o map] k↦y ∈ m, f k (h y)).
  Proof.
    rewrite big_opM_eq /big_opM_def map_to_list_fmap big_opL_fmap.
    by apply big_opL_proper=> ? [??].
  Qed.

  Lemma big_opM_omap {B} (h : A → option B) (f : K → B → M) m :
    ([^o map] k↦y ∈ omap h m, f k y)
    ≡ [^o map] k↦y ∈ m, from_option (f k) monoid_unit (h y).
  Proof.
    revert f. induction m as [|i x m Hmi IH] using map_ind=> f.
    { by rewrite omap_empty !big_opM_empty. }
    assert (omap h m !! i = None) by (by rewrite lookup_omap Hmi).
    destruct (h x) as [y|] eqn:Hhx.
    - by rewrite omap_insert Hhx //= !big_opM_insert // IH Hhx.
    - rewrite omap_insert_None // delete_notin // big_opM_insert //.
      by rewrite Hhx /= left_id.
  Qed.

  Lemma big_opM_insert_delete `{Countable K} {B} (f : K → B → M) (m : gmap K B) i x :
    ([^o map] k↦y ∈ <[i:=x]> m, f k y) ≡ f i x `o` [^o map] k↦y ∈ delete i m, f k y.
  Proof.
    rewrite -insert_delete big_opM_insert; first done. by rewrite lookup_delete.
  Qed.

  Lemma big_opM_insert_override (f : K → A → M) m i x x' :
    m !! i = Some x → f i x ≡ f i x' →
    ([^o map] k↦y ∈ <[i:=x']> m, f k y) ≡ ([^o map] k↦y ∈ m, f k y).
  Proof.
    intros ? Hx. rewrite -insert_delete big_opM_insert ?lookup_delete //.
    by rewrite -Hx -big_opM_delete.
  Qed.

  Lemma big_opM_fn_insert {B} (g : K → A → B → M) (f : K → B) m i (x : A) b :
    m !! i = None →
    ([^o map] k↦y ∈ <[i:=x]> m, g k y (<[i:=b]> f k))
    ≡ g i x b `o` [^o map] k↦y ∈ m, g k y (f k).
  Proof.
    intros. rewrite big_opM_insert // fn_lookup_insert.
    f_equiv; apply big_opM_proper; auto=> k y ?.
    by rewrite fn_lookup_insert_ne; last set_solver.
  Qed.
  Lemma big_opM_fn_insert' (f : K → M) m i x P :
    m !! i = None →
    ([^o map] k↦y ∈ <[i:=x]> m, <[i:=P]> f k) ≡ (P `o` [^o map] k↦y ∈ m, f k).
  Proof. apply (big_opM_fn_insert (λ _ _, id)). Qed.

  Lemma big_opM_filter' (φ : K * A → Prop) `{∀ kx, Decision (φ kx)} f m :
    ([^o map] k ↦ x ∈ filter φ m, f k x)
    ≡ ([^o map] k ↦ x ∈ m, if decide (φ (k, x)) then f k x else monoid_unit).
  Proof.
    induction m as [|k v m ? IH] using map_ind.
    { by rewrite map_filter_empty !big_opM_empty. }
    destruct (decide (φ (k, v))).
    - rewrite map_filter_insert //.
      assert (filter φ m !! k = None) by (apply map_filter_lookup_None; eauto).
      by rewrite !big_opM_insert // decide_True // IH.
    - rewrite map_filter_insert_not' //; last by congruence.
      rewrite !big_opM_insert // decide_False // IH. by rewrite left_id.
  Qed.

  Lemma big_opM_union f m1 m2 :
    m1 ##ₘ m2 →
    ([^o map] k↦y ∈ m1 ∪ m2, f k y)
    ≡ ([^o map] k↦y ∈ m1, f k y) `o` ([^o map] k↦y ∈ m2, f k y).
  Proof.
    intros. induction m1 as [|i x m ? IH] using map_ind.
    { by rewrite big_opM_empty !left_id. }
    decompose_map_disjoint.
    rewrite -insert_union_l !big_opM_insert //;
      last by apply lookup_union_None.
    rewrite -assoc IH //.
  Qed.

  Lemma big_opM_op f g m :
    ([^o map] k↦x ∈ m, f k x `o` g k x)
    ≡ ([^o map] k↦x ∈ m, f k x) `o` ([^o map] k↦x ∈ m, g k x).
  Proof.
    rewrite big_opM_eq /big_opM_def -big_opL_op. by apply big_opL_proper=> ? [??].
  Qed.
End gmap.

Lemma big_opM_sep_zip_with `{Countable K} {A B C}
    (f : A → B → C) (g1 : C → A) (g2 : C → B)
    (h1 : K → A → M) (h2 : K → B → M) m1 m2 :
  (∀ x y, g1 (f x y) = x) →
  (∀ x y, g2 (f x y) = y) →
  (∀ k, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) →
  ([^o map] k↦xy ∈ map_zip_with f m1 m2, h1 k (g1 xy) `o` h2 k (g2 xy)) ≡
  ([^o map] k↦x ∈ m1, h1 k x) `o` ([^o map] k↦y ∈ m2, h2 k y).
Proof.
  intros Hdom Hg1 Hg2. rewrite big_opM_op.
  rewrite -(big_opM_fmap g1) -(big_opM_fmap g2).
  rewrite map_fmap_zip_with_r; [|naive_solver..].
  by rewrite map_fmap_zip_with_l; [|naive_solver..].
Qed.

Lemma big_opM_sep_zip `{Countable K} {A B}
    (h1 : K → A → M) (h2 : K → B → M) m1 m2 :
  (∀ k, is_Some (m1 !! k) ↔ is_Some (m2 !! k)) →
  ([^o map] k↦xy ∈ map_zip m1 m2, h1 k xy.1 `o` h2 k xy.2) ≡
  ([^o map] k↦x ∈ m1, h1 k x) `o` ([^o map] k↦y ∈ m2, h2 k y).
Proof. intros. by apply big_opM_sep_zip_with. Qed.

(** ** Big ops over finite sets *)
Section gset.
  Context `{Countable A}.
  Implicit Types X : gset A.
  Implicit Types f : A → M.

  Lemma big_opS_gen_proper R f g X :
    Reflexive R → Proper (R ==> R ==> R) o →
    (∀ x, x ∈ X → R (f x) (g x)) →
    R ([^o set] x ∈ X, f x) ([^o set] x ∈ X, g x).
  Proof.
    rewrite big_opS_eq. intros ?? Hf. apply (big_opL_gen_proper R); auto.
    intros k x ?%elem_of_list_lookup_2. by apply Hf, elem_of_elements.
  Qed.

  Lemma big_opS_ext f g X :
    (∀ x, x ∈ X → f x = g x) →
    ([^o set] x ∈ X, f x) = ([^o set] x ∈ X, g x).
  Proof. apply big_opS_gen_proper; apply _. Qed.

  (** The lemmas [big_opS_ne] and [big_opS_proper] are more generic than the
  instances as they also give [x ∈ X] in the premise. *)
  Lemma big_opS_ne f g X n :
    (∀ x, x ∈ X → f x ≡{n}≡ g x) →
    ([^o set] x ∈ X, f x) ≡{n}≡ ([^o set] x ∈ X, g x).
  Proof. apply big_opS_gen_proper; apply _. Qed.
  Lemma big_opS_proper f g X :
    (∀ x, x ∈ X → f x ≡ g x) →
    ([^o set] x ∈ X, f x) ≡ ([^o set] x ∈ X, g x).
  Proof. apply big_opS_gen_proper; apply _. Qed.

  Global Instance big_opS_ne' n :
    Proper (pointwise_relation _ (dist n) ==> (=) ==> dist n) (big_opS o (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opS_ne; intros; apply Hf. Qed.
  Global Instance big_opS_proper' :
    Proper (pointwise_relation _ (≡) ==> (=) ==> (≡)) (big_opS o (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opS_proper; intros; apply Hf. Qed.

  Lemma big_opS_empty f : ([^o set] x ∈ ∅, f x) = monoid_unit.
  Proof. by rewrite big_opS_eq /big_opS_def elements_empty. Qed.

  Lemma big_opS_insert f X x :
    x ∉ X → ([^o set] y ∈ {[ x ]} ∪ X, f y) ≡ (f x `o` [^o set] y ∈ X, f y).
  Proof. intros. by rewrite big_opS_eq /big_opS_def elements_union_singleton. Qed.
  Lemma big_opS_fn_insert {B} (f : A → B → M) h X x b :
    x ∉ X →
    ([^o set] y ∈ {[ x ]} ∪ X, f y (<[x:=b]> h y))
    ≡ f x b `o` [^o set] y ∈ X, f y (h y).
  Proof.
    intros. rewrite big_opS_insert // fn_lookup_insert.
    f_equiv; apply big_opS_proper; auto=> y ?.
    by rewrite fn_lookup_insert_ne; last set_solver.
  Qed.
  Lemma big_opS_fn_insert' f X x P :
    x ∉ X → ([^o set] y ∈ {[ x ]} ∪ X, <[x:=P]> f y) ≡ (P `o` [^o set] y ∈ X, f y).
  Proof. apply (big_opS_fn_insert (λ y, id)). Qed.

  Lemma big_opS_union f X Y :
    X ## Y →
    ([^o set] y ∈ X ∪ Y, f y) ≡ ([^o set] y ∈ X, f y) `o` ([^o set] y ∈ Y, f y).
  Proof.
    intros. induction X as [|x X ? IH] using set_ind_L.
    { by rewrite left_id_L big_opS_empty left_id. }
    rewrite -assoc_L !big_opS_insert; [|set_solver..].
    by rewrite -assoc IH; last set_solver.
  Qed.

  Lemma big_opS_delete f X x :
    x ∈ X → ([^o set] y ∈ X, f y) ≡ f x `o` [^o set] y ∈ X ∖ {[ x ]}, f y.
  Proof.
    intros. rewrite -big_opS_insert; last set_solver.
    by rewrite -union_difference_L; last set_solver.
  Qed.

  Lemma big_opS_singleton f x : ([^o set] y ∈ {[ x ]}, f y) ≡ f x.
  Proof. intros. by rewrite big_opS_eq /big_opS_def elements_singleton /= right_id. Qed.

  Lemma big_opS_unit X : ([^o set] y ∈ X, monoid_unit) ≡ (monoid_unit : M).
  Proof.
    by induction X using set_ind_L; rewrite /= ?big_opS_insert ?left_id // big_opS_eq.
  Qed.

  Lemma big_opS_filter' (φ : A → Prop) `{∀ x, Decision (φ x)} f X :
    ([^o set] y ∈ filter φ X, f y)
    ≡ ([^o set] y ∈ X, if decide (φ y) then f y else monoid_unit).
  Proof.
    induction X as [|x X ? IH] using set_ind_L.
    { by rewrite filter_empty_L !big_opS_empty. }
    destruct (decide (φ x)).
    - rewrite filter_union_L filter_singleton_L //.
      rewrite !big_opS_insert //; last set_solver.
      by rewrite decide_True // IH.
    - rewrite filter_union_L filter_singleton_not_L // left_id_L.
      by rewrite !big_opS_insert // decide_False // IH left_id.
  Qed.

  Lemma big_opS_op f g X :
    ([^o set] y ∈ X, f y `o` g y) ≡ ([^o set] y ∈ X, f y) `o` ([^o set] y ∈ X, g y).
  Proof. by rewrite big_opS_eq /big_opS_def -big_opL_op. Qed.

  Lemma big_opS_list_to_set f (l : list A) :
    NoDup l →
    ([^o set] x ∈ list_to_set l, f x) ≡ [^o list] x ∈ l, f x.
  Proof.
    induction 1 as [|x l ?? IHl].
    - rewrite big_opS_empty //.
    - rewrite /= big_opS_union; last set_solver.
      by rewrite big_opS_singleton IHl.
  Qed.
End gset.

Lemma big_opS_set_map `{Countable A, Countable B} (h : A → B) (X : gset A) (f : B → M) :
  Inj (=) (=) h →
  ([^o set] x ∈ set_map h X, f x) ≡ ([^o set] x ∈ X, f (h x)).
Proof.
  intros Hinj.
  induction X as [|x X ? IH] using set_ind_L.
  { by rewrite set_map_empty !big_opS_empty. }
  rewrite set_map_union_L set_map_singleton_L.
  rewrite !big_opS_union; [|set_solver..].
  rewrite !big_opS_singleton IH //.
Qed.

Lemma big_opM_dom `{Countable K} {A} (f : K → M) (m : gmap K A) :
  ([^o map] k↦_ ∈ m, f k) ≡ ([^o set] k ∈ dom _ m, f k).
Proof.
  induction m as [|i x ?? IH] using map_ind.
  { by rewrite big_opM_eq big_opS_eq dom_empty_L. }
  by rewrite dom_insert_L big_opM_insert // IH big_opS_insert ?not_elem_of_dom.
Qed.

(** ** Big ops over finite msets *)
Section gmultiset.
  Context `{Countable A}.
  Implicit Types X : gmultiset A.
  Implicit Types f : A → M.

  Lemma big_opMS_gen_proper R f g X :
    Reflexive R → Proper (R ==> R ==> R) o →
    (∀ x, x ∈ X → R (f x) (g x)) →
    R ([^o mset] x ∈ X, f x) ([^o mset] x ∈ X, g x).
  Proof.
    rewrite big_opMS_eq. intros ?? Hf. apply (big_opL_gen_proper R); auto.
    intros k x ?%elem_of_list_lookup_2. by apply Hf, gmultiset_elem_of_elements.
  Qed.

  Lemma big_opMS_ext f g X :
    (∀ x, x ∈ X → f x = g x) →
    ([^o mset] x ∈ X, f x) = ([^o mset] x ∈ X, g x).
  Proof. apply big_opMS_gen_proper; apply _. Qed.

  (** The lemmas [big_opMS_ne] and [big_opMS_proper] are more generic than the
  instances as they also give [x ∈ X] in the premise. *)
  Lemma big_opMS_ne f g X n :
    (∀ x, x ∈ X → f x ≡{n}≡ g x) →
    ([^o mset] x ∈ X, f x) ≡{n}≡ ([^o mset] x ∈ X, g x).
  Proof. apply big_opMS_gen_proper; apply _. Qed.
  Lemma big_opMS_proper f g X :
    (∀ x, x ∈ X → f x ≡ g x) →
    ([^o mset] x ∈ X, f x) ≡ ([^o mset] x ∈ X, g x).
  Proof. apply big_opMS_gen_proper; apply _. Qed.

  Global Instance big_opMS_ne' n :
    Proper (pointwise_relation _ (dist n) ==> (=) ==> dist n) (big_opMS o (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opMS_ne; intros; apply Hf. Qed.
  Global Instance big_opMS_proper' :
    Proper (pointwise_relation _ (≡) ==> (=) ==> (≡)) (big_opMS o (A:=A)).
  Proof. intros f g Hf m ? <-. apply big_opMS_proper; intros; apply Hf. Qed.

  Lemma big_opMS_empty f : ([^o mset] x ∈ ∅, f x) = monoid_unit.
  Proof. by rewrite big_opMS_eq /big_opMS_def gmultiset_elements_empty. Qed.

  Lemma big_opMS_disj_union f X Y :
    ([^o mset] y ∈ X ⊎ Y, f y) ≡ ([^o mset] y ∈ X, f y) `o` [^o mset] y ∈ Y, f y.
  Proof. by rewrite big_opMS_eq /big_opMS_def gmultiset_elements_disj_union big_opL_app. Qed.

  Lemma big_opMS_singleton f x : ([^o mset] y ∈ {[ x ]}, f y) ≡ f x.
  Proof.
    intros. by rewrite big_opMS_eq /big_opMS_def gmultiset_elements_singleton /= right_id.
  Qed.

  Lemma big_opMS_delete f X x :
    x ∈ X → ([^o mset] y ∈ X, f y) ≡ f x `o` [^o mset] y ∈ X ∖ {[ x ]}, f y.
  Proof.
    intros. rewrite -big_opMS_singleton -big_opMS_disj_union.
    by rewrite -gmultiset_disj_union_difference'.
  Qed.

  Lemma big_opMS_unit X : ([^o mset] y ∈ X, monoid_unit) ≡ (monoid_unit : M).
  Proof.
    by induction X using gmultiset_ind;
      rewrite /= ?big_opMS_disj_union ?big_opMS_singleton ?left_id // big_opMS_eq.
  Qed.

  Lemma big_opMS_op f g X :
    ([^o mset] y ∈ X, f y `o` g y) ≡ ([^o mset] y ∈ X, f y) `o` ([^o mset] y ∈ X, g y).
  Proof. by rewrite big_opMS_eq /big_opMS_def -big_opL_op. Qed.
End gmultiset.
End big_op.

Section homomorphisms.
  Context `{Monoid M1 o1, Monoid M2 o2}.
  Infix "`o1`" := o1 (at level 50, left associativity).
  Infix "`o2`" := o2 (at level 50, left associativity).
  (** The ssreflect rewrite tactic only works for relations that have a
  [RewriteRelation] instance. For the purpose of this section, we want to
  rewrite with arbitrary relations, so we declare any relation to be a
  [RewriteRelation]. *)
  Local Instance: ∀ {A} (R : relation A), RewriteRelation R := {}.

  Lemma big_opL_commute {A} (h : M1 → M2) `{!MonoidHomomorphism o1 o2 R h}
      (f : nat → A → M1) l :
    R (h ([^o1 list] k↦x ∈ l, f k x)) ([^o2 list] k↦x ∈ l, h (f k x)).
  Proof.
    revert f. induction l as [|x l IH]=> f /=.
    - apply monoid_homomorphism_unit.
    - by rewrite monoid_homomorphism IH.
  Qed.
  Lemma big_opL_commute1 {A} (h : M1 → M2) `{!WeakMonoidHomomorphism o1 o2 R h}
      (f : nat → A → M1) l :
    l ≠ [] → R (h ([^o1 list] k↦x ∈ l, f k x)) ([^o2 list] k↦x ∈ l, h (f k x)).
  Proof.
    intros ?. revert f. induction l as [|x [|x' l'] IH]=> f //.
    - by rewrite !big_opL_singleton.
    - by rewrite !(big_opL_cons _ x) monoid_homomorphism IH.
  Qed.

  Lemma big_opM_commute `{Countable K} {A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 R h} (f : K → A → M1) m :
    R (h ([^o1 map] k↦x ∈ m, f k x)) ([^o2 map] k↦x ∈ m, h (f k x)).
  Proof.
    intros. induction m as [|i x m ? IH] using map_ind.
    - by rewrite !big_opM_empty monoid_homomorphism_unit.
    - by rewrite !big_opM_insert // monoid_homomorphism -IH.
  Qed.
  Lemma big_opM_commute1 `{Countable K} {A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 R h} (f : K → A → M1) m :
    m ≠ ∅ → R (h ([^o1 map] k↦x ∈ m, f k x)) ([^o2 map] k↦x ∈ m, h (f k x)).
  Proof.
    intros. induction m as [|i x m ? IH] using map_ind; [done|].
    destruct (decide (m = ∅)) as [->|].
    - by rewrite !big_opM_insert // !big_opM_empty !right_id.
    - by rewrite !big_opM_insert // monoid_homomorphism -IH //.
  Qed.

  Lemma big_opS_commute `{Countable A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 R h} (f : A → M1) X :
    R (h ([^o1 set] x ∈ X, f x)) ([^o2 set] x ∈ X, h (f x)).
  Proof.
    intros. induction X as [|x X ? IH] using set_ind_L.
    - by rewrite !big_opS_empty monoid_homomorphism_unit.
    - by rewrite !big_opS_insert // monoid_homomorphism -IH.
  Qed.
  Lemma big_opS_commute1 `{Countable A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 R h} (f : A → M1) X :
    X ≠ ∅ → R (h ([^o1 set] x ∈ X, f x)) ([^o2 set] x ∈ X, h (f x)).
  Proof.
    intros. induction X as [|x X ? IH] using set_ind_L; [done|].
    destruct (decide (X = ∅)) as [->|].
    - by rewrite !big_opS_insert // !big_opS_empty !right_id.
    - by rewrite !big_opS_insert // monoid_homomorphism -IH //.
  Qed.

  Lemma big_opMS_commute `{Countable A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 R h} (f : A → M1) X :
    R (h ([^o1 mset] x ∈ X, f x)) ([^o2 mset] x ∈ X, h (f x)).
  Proof.
    intros. induction X as [|x X IH] using gmultiset_ind.
    - by rewrite !big_opMS_empty monoid_homomorphism_unit.
    - by rewrite !big_opMS_disj_union !big_opMS_singleton monoid_homomorphism -IH.
  Qed.
  Lemma big_opMS_commute1 `{Countable A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 R h} (f : A → M1) X :
    X ≠ ∅ → R (h ([^o1 mset] x ∈ X, f x)) ([^o2 mset] x ∈ X, h (f x)).
  Proof.
    intros. induction X as [|x X IH] using gmultiset_ind; [done|].
    destruct (decide (X = ∅)) as [->|].
    - by rewrite !big_opMS_disj_union !big_opMS_singleton !big_opMS_empty !right_id.
    - by rewrite !big_opMS_disj_union !big_opMS_singleton monoid_homomorphism -IH //.
  Qed.

  Context `{!LeibnizEquiv M2}.

  Lemma big_opL_commute_L {A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 (≡) h} (f : nat → A → M1) l :
    h ([^o1 list] k↦x ∈ l, f k x) = ([^o2 list] k↦x ∈ l, h (f k x)).
  Proof using Type*. unfold_leibniz. by apply big_opL_commute. Qed.
  Lemma big_opL_commute1_L {A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : nat → A → M1) l :
    l ≠ [] → h ([^o1 list] k↦x ∈ l, f k x) = ([^o2 list] k↦x ∈ l, h (f k x)).
  Proof using Type*. unfold_leibniz. by apply big_opL_commute1. Qed.

  Lemma big_opM_commute_L `{Countable K} {A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 (≡) h} (f : K → A → M1) m :
    h ([^o1 map] k↦x ∈ m, f k x) = ([^o2 map] k↦x ∈ m, h (f k x)).
  Proof using Type*. unfold_leibniz. by apply big_opM_commute. Qed.
  Lemma big_opM_commute1_L `{Countable K} {A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : K → A → M1) m :
    m ≠ ∅ → h ([^o1 map] k↦x ∈ m, f k x) = ([^o2 map] k↦x ∈ m, h (f k x)).
  Proof using Type*. unfold_leibniz. by apply big_opM_commute1. Qed.

  Lemma big_opS_commute_L `{Countable A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
    h ([^o1 set] x ∈ X, f x) = ([^o2 set] x ∈ X, h (f x)).
  Proof using Type*. unfold_leibniz. by apply big_opS_commute. Qed.
  Lemma big_opS_commute1_L `{ Countable A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
    X ≠ ∅ → h ([^o1 set] x ∈ X, f x) = ([^o2 set] x ∈ X, h (f x)).
  Proof using Type*. intros. rewrite <-leibniz_equiv_iff. by apply big_opS_commute1. Qed.

  Lemma big_opMS_commute_L `{Countable A} (h : M1 → M2)
      `{!MonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
    h ([^o1 mset] x ∈ X, f x) = ([^o2 mset] x ∈ X, h (f x)).
  Proof using Type*. unfold_leibniz. by apply big_opMS_commute. Qed.
  Lemma big_opMS_commute1_L `{Countable A} (h : M1 → M2)
      `{!WeakMonoidHomomorphism o1 o2 (≡) h} (f : A → M1) X :
    X ≠ ∅ → h ([^o1 mset] x ∈ X, f x) = ([^o2 mset] x ∈ X, h (f x)).
  Proof using Type*. intros. rewrite <-leibniz_equiv_iff. by apply big_opMS_commute1. Qed.
End homomorphisms.


(**
This file describes the construction of our proof system, mainly about:
  1. The definitions of Separation Logic triple in CBS:
    a. three different definitions of CBS-SL-triple
    b. prove the equivalence of three definitions
  2. how to state and prove the reasoning rules of:
    a. primitive operations (block & file)
    b. terms
    c. structural rules
  (we can prove the SL rules by the proven Hoare rules ).

Author: Bowen Zhang.

Date : 2023.02.22
*)

From SLF (* TLC *) Require Export LibCore TLCbuffer.
From SLF (* CBS *) Require Export Himpl Hoare.

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

(*** Implicit Types (to improve the readability) ***)

Implicit Types b bp : bloc.
Implicit Types f fp: floc.
Implicit Types ln : list int.
Implicit Types n : int.
Implicit Types v : val.
Implicit Types t : trm.
Implicit Types be : bool.
Implicit Types hb : heapb.
Implicit Types sb : stateb.
Implicit Types hf : heapf.
Implicit Types sf : statef.

(*all operators have opaque definitions*)
Global Opaque hbempty hbpure hbstar hbsingle hbexists hbforall.
Global Opaque hfempty hfpure hfstar hfsingle hfexists hfforall.

(* ################################################################# *)
Open Scope liblist_scope.
Open Scope Z_scope.

(* ================================================================================ *)
(** ** Separation Logic Formal System for CBS ** **)

(**============= * Definition of Separation Logic triple ================*)
(* 1st way: using refinement predicate *)
Definition triple (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
forall Hf Hb,
    hoare t (H \* \R[Hf,Hb]) (Q \*+ \R[Hf,Hb]).

(* 2nd way: using CBS predicate *)
Definition triple_pred (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
forall H',
    hoare t (H \* H') (Q \*+ H').

(* 3rd way: using CBS heap *)
Definition triple_lowlevel (t:trm) (H:hprop) (Q:val->hprop) : Prop :=
forall h1 h2,
  glodisjoint h1 h2 ->
  H h1 ->
  exists h1' v,
       glodisjoint h1' h2
    /\ eval (h1 \g h2) t (h1' \g h2) v
    /\ Q v h1'.

(* 1st definition <-> 2nd definition *)
Definition triple_iff_triple_pred: forall t H Q,
  triple_pred t H Q  <->  triple t H Q.
Proof.
  intros. unfolds~ triple_pred,triple. iff* R.
  intros H'. lets M : refine_eq' H'. rewrite M.
  intros hf hb (h1&h2&KA&(hf1&hb1&h11&h12&KB1&KB2&KB3&KB4)&KC&KD).
  lets T : R (= hf1) (= hb1) hf hb.
  apply hpure_inv in KB1 as (KB11&KB12).
  subst. unfold glounion in KD.
  simpls. do 2 rewrite union_empty_l in KD.
  lets C : hstar_intro KA KB2 KC.
  unfold glounion in C. rewrite <- KD in C.
  apply T in C as (hf'&hb'&v&CA&CB).
  exists hf' hb' v. splits~.
  destruct CB as (h3&h4&C1&C2&C3&C4).
  exists~ h3 h4. splits~.
  exists~ hf1 hb1. rewrite hstar_hpure_iff.
  splits~.
Qed.

(* 2nd definition <-> 3rd definition *)
Lemma triple_pred_iff_triple_lowlevel : forall t H Q,
  triple_pred t H Q <-> triple_lowlevel t H Q.
Proof using.
  unfold triple_pred,triple_lowlevel. iff* M.
  - introv D P1. unfold hoare in M.
    forwards~ (hf'&hb'&v&R1&R2):
      (rm M) (=h2) ((fst h1) \u (fst h2)) ((snd h1) \u (snd h2)).
    exists~ h1 h2.
    destruct R2 as (h1'&h2'&HA&HB&HC&HD).
    subst. exists~ h1' v. splits~.
    rewrite HD in R1. apply R1.
  - introv (h1&h2&HA&HB&HC&HD).
    forwards* (h1'&v&MC&MD&ME) : (rm M) h1 h2.
    exists ((fst h1') \u (fst h2)) ((snd h1') \u (snd h2)) v.
    rewrite HD. split~.  apply* hstar_intro.
Qed.

(**====================  separation logic rule  ===========================**)

(*------------------ SL rule: block prim operations---------------*)
Lemma triple_bcreate : forall Hf ln,
  triple (bprim_create (val_listint ln))
    (\R[ Hf, \b[] ])
    (fun r => \exists b, \[r= (val_bloc b)] \* (\R[ Hf, (b ~b~> ln)]) ).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bcreate hstar_sep_l.

  intros r h M.
  destruct M as (b&M).
  apply hstar_hpure_iff in M as [M1 M].
  destruct M as (MA&MB).
  rewrite hstar_hexists. exists b.
  rewrite hstar_assoc, hstar_hpure. splits~.
  rewrite hstar_sep, state_get_eq.
  splits~. simpls.
  rewrite hbstar_hempty_l in MB. auto.
Qed.

Lemma triple_bget: forall Hf b ln,
  triple (bprim_get b)
    (\R[ Hf, (b ~b~> ln)])
    (fun r => \[r=(val_listint ln)] \* (\R[ Hf, (b ~b~> ln)])).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bget hstar_sep_l.
  intros r h R.
  apply hstar_hpure_iff in R as [R1 R].
  destruct R as (HA&HB).
  rewrite hstar_assoc, hstar_hpure. splits~.
  rewrite hstar_sep, state_get_eq.
  splits~.
Qed.

Lemma triple_bdelete: forall Hf b ln,
  triple (bprim_delete b)
    (\R[ Hf, (b ~b~> ln)])
    (fun _ =>(\R[ Hf, \b[]])).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bdelete hstar_sep_l.
  intros r h R.
  apply hstar_hpure_iff in R as [R1 R].
  destruct R as (HA&HB).
  rewrite hstar_sep, state_get_eq.
  splits~. simpls. rewrite~ hbstar_hempty_l.
Qed.

Lemma triple_bappend : forall Hf b ln1 ln2,
  triple (bprim_append b (val_listint ln2))
    ( \R[Hf, (b ~b~> ln1)] )
    (fun _ => \R[Hf, b ~b~> (ln1++ln2)]).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bappend.
  rewrite hstar_sep. apply himpl_refl.
  intros r h (RA&RB).
  rewrite hstar_sep, state_get_eq.
  splits~.
Qed.

Lemma triple_btruncate : forall Hf b l n,
  triple (bprim_trun b n)
    ( \R[Hf, (b ~b~> l)] )
    (fun _ => \R[Hf, b ~b~> (droplast (to_nat n) l)]).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_btruncate.
  rewrite hstar_sep. apply himpl_refl.
  intros r h (RA&RB).
  rewrite hstar_sep, state_get_eq.
  splits~.
Qed.

Lemma triple_bsize : forall Hf b ln1,
  triple (bprim_size b )
    ( \R[Hf, (b ~b~> ln1)] )
    (fun r => \[r = List.length ln1] \* \R[Hf, (b ~b~> ln1)]).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bsize.
  rewrite hstar_sep. apply himpl_refl.
  intros r h R.
  rewrite hstar_hpure_iff in R.
  destruct R as (RA&RB).
  rewrite hstar_assoc. rewrite hstar_hpure.
  splits~. rewrite~ hstar_sep.
Qed.

(*-------------------- SL rule: file prim operations -------------------*)
Lemma triple_fcreate : forall Hb lb,
  triple (fprim_create (val_listbloc lb))
    (\R[ \f[], Hb ])
    (fun r => \exists f, \[r = val_floc f] \* \R[(f ~f~> lb), Hb ]).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fcreate hstar_sep_l.
  introv (f&M).
  apply hstar_hpure_iff in M as (M1&(MA&MB)).
  rewrite hstar_hexists. exists f.
  rewrite hstar_assoc, hstar_hpure. splits~.
  rewrite hstar_sep. splits~.
Qed.

Lemma triple_fget: forall Hb (f:floc) lb,
  triple (fprim_get f)
    (\R[ (f ~f~> lb), Hb])
    (fun r =>\[r=(val_listbloc lb)] \* \R[(f ~f~> lb), Hb]).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fget hstar_sep_l.
  intros r h M.
  apply hstar_hpure_iff in M as (MA&(M1&M2)).
  rewrite hstar_assoc, hstar_hpure. splits~.
  rewrite hstar_sep. splits~.
Qed.

Lemma triple_fget_nth_blk : forall Hb f lb n,
  triple (fprim_nthblk f n)
    (\R[ f ~f~> lb, Hb ])
    (fun r => \[r = val_bloc (nth_default bnull (Z.to_nat n) lb)] \*
              \R[(f ~f~> lb),Hb ]).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fget_nth_blk hstar_sep_l.
  intros r h M.
  apply hstar_hpure_iff in M as [MA M].
  destruct M as (M1&M2).
  rewrite hstar_assoc, hstar_hpure. splits~.
  rewrite hstar_sep, state_get_eq. splits~.
Qed.

Lemma triple_fset_nth_blk : forall Hb f lb n b,
  triple (fprim_set f n b)
    (\R[ f ~f~> lb, Hb ])
    (fun r => \R[ (f ~f~> (LibList.update (Z.to_nat n) b lb)), Hb ]).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fset_nth_blk hstar_sep_l.
  intros r h M.
  destruct M as (M1&M2).
  rewrite hstar_sep, state_get_eq.
  splits~.
Qed.

Lemma triple_fdelete: forall Hb f lb,
  triple (fprim_delete f)
    (\R[ (f ~f~> lb), Hb])
    (fun r =>(\R[ \f[], Hb])).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fdelete hstar_sep_l.
  intros r h M.
  apply hstar_hpure_iff in M as [MA M].
  destruct M as (M1&M2).
  rewrite hstar_sep, state_get_eq.
  splits~. simpl.
  rewrite~ hfstar_hempty_l.
Qed.

Lemma triple_fattach: forall Hb f lb1 lb2,
  triple (fprim_attach f (val_listbloc lb2))
    ( \R[(f ~f~> lb1), Hb] )
    (fun r =>(\R[(f ~f~> (lb1++lb2)), Hb])).
Proof.
  intros. intros Hf' Hb'.
  applys hoare_conseq hoare_fattach.
  rewrite hstar_sep, hfstar_hempty_l.
  apply himpl_refl.
  intros r. rewrite hstar_sep. apply himpl_refl.
Qed.

Lemma triple_ftrun : forall Hb f lb n,
  triple (fprim_trun f n)
    ( \R[ (f ~f~> lb), Hb] )
    (fun _ => \R[f ~f~> (droplast (to_nat n) lb), Hb]).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_ftruncate.
  rewrite hstar_sep. apply himpl_refl.
  intros r h (RA&RB).
  rewrite hstar_sep, state_get_eq.
  splits~.
Qed.

Lemma triple_fsize : forall Hb f lb,
  triple (fprim_size f )
    ( \R[(f ~f~> lb), Hb] )
    (fun r => \[r = List.length lb] \* \R[(f ~f~> lb), Hb]).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_fsize.
  rewrite hstar_sep. apply himpl_refl.
  intros r h R.
  rewrite hstar_hpure_iff in R.
  destruct R as (RA&RB).
  rewrite hstar_assoc. rewrite hstar_hpure.
  splits~. rewrite~ hstar_sep.
Qed.

(* -------------------- SL rule: aux prim operations------------------ *)

Lemma triple_add : forall H n1 n2,
  triple (val_add n1 n2) H
    (fun r => (\[r = (n1 + n2)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (n1+n2).
  splits~. apply eval_add.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_min : forall H n1 n2,
  triple (val_min n1 n2) H
    (fun r => (\[r = (n1 - n2)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (n1-n2).
  splits~. apply eval_min.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_eq : forall H n1 n2,
  triple (val_eq n1 n2) H
    (fun r => (\[r = val_bool (n1 =? n2)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_bool (n1 =? n2)).
  splits~. apply eval_eq.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_le : forall H n1 n2,
  triple (val_le n1 n2) H
    (fun r => (\[r = (val_bool (isTrue (n1 <= n2)))] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_bool (isTrue (n1 <= n2))). splits.
  apply eval_le.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_rev : forall H ln1,
  triple (val_list_rev (val_listint ln1)) H
    (fun r => (\[r = val_listint (rev ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (rev ln1)).
  splits~. apply eval_list_rev.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_app : forall H ln1 ln2,
  triple (val_list_app (val_listint ln1) (val_listint ln2)) H
    (fun r => (\[r = val_listint (ln1 ++ ln2)] \* H)).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (val_listint (ln1 ++ ln2)). splits.
  apply eval_list_app. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_blist_rev : forall H lb,
  triple (val_blist_rev (val_listbloc lb))
    H
    ( fun r => \[r = (val_listbloc (rev lb))] \* H ).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (val_listbloc (rev lb)). splits.
  apply eval_blist_rev. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_new_buffer : forall b H,
  triple (val_new_blist b)
    H
    (fun r => \[r= val_listbloc (b::nil)] \* H ).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (val_listbloc (b::nil)). splits.
  apply eval_new_blist. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_blist_buffer : forall b lb H,
  triple (val_blist_buffer b (val_listbloc lb))
    H
    ( fun r => \[r = (val_listbloc (b::lb))] \* H ).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (val_listbloc (b::lb)). splits.
  apply eval_blist_buffer. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_list_hd_bk : forall H ln1,
  triple (val_list_hd_bk (val_listint ln1)) H
    (fun r => (\[r = val_listint (take 2%nat ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (take 2%nat ln1)).
  splits~. apply eval_list_hd_blk.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_tl_bk : forall H ln1,
  triple (val_list_tl_bk (val_listint ln1)) H
    (fun r => (\[r = val_listint (drop 2%nat ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (drop 2%nat ln1)).
  splits~. apply eval_list_tl_blk.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_hd : forall H ln1,
  triple (val_list_hd (val_listint ln1)) H
    (fun r => (\[r = val_listint (take 1%nat ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (take 1%nat ln1)).
  splits~. apply eval_list_hd.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_tl : forall H ln1,
  triple (val_list_tl (val_listint ln1)) H
    (fun r => (\[r = val_listint (drop 1%nat ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (drop 1%nat ln1)).
  splits~. apply eval_list_tl.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

Lemma triple_list_len : forall H ln1,
  triple (val_list_len (val_listint ln1)) H
    (fun r => (\[r = (LibList.length ln1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (LibList.length ln1).
  splits~. apply eval_list_len.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

(* ----------------  SL rule: terms   --------------- *)
Lemma triple_val : forall v H Q,
  H ==> Q v ->
  triple (trm_val v) H Q.
Proof.
  introv M. unfold triple. intros. applys hoare_val.
  applys~ himpl_frame_l.
Qed.

Lemma triple_val' : forall v H,
  triple (trm_val v) H (fun r => \[r = v] \* H).
Proof.
  introv M. unfold triple. intros.
  exists sf sb v. splits~. apply eval_val.
  rewrite hstar_assoc, hstar_hpure_iff.
  splits~.
Qed.

Lemma triple_fix: forall F x t1 H Q,
  H ==> Q (val_fix F x t1) ->
  triple (trm_fix F x t1) H Q.
Proof.
  unfold triple. introv M.
  intros Hf' Hb' hf hb K.
  exists hf hb __.
  splits~. apply eval_fix.
  eapply himpl_frame_l in M.
  applys M K.
Qed.

Lemma triple_eval_like : forall t1 t2 H Q,
  eval_like t1 t2 ->
  triple t1 H Q ->
  triple t2 H Q.
Proof using.
  introv E M1. intros Hf Hb. applys hoare_eval_like E. applys M1.
Qed.

Lemma triple_trm_equiv : forall t1 t2 H Q,
  trm_equiv t1 t2 ->
  triple t1 H Q <-> triple t2 H Q.
Proof using.
  introv E. unfolds trm_equiv. iff M.
  { applys triple_eval_like M. introv R. applys* E. }
  { applys triple_eval_like M. introv R. applys* E. }
Qed.

Lemma triple_fun : forall x t1 H Q,
  H ==> Q (val_fun x t1) ->
  triple (trm_fun x t1) H Q.
Proof.
  introv M.
  unfold triple. intros Hf Hb hf hb K.
  exists hf hb __. splits~. applys eval_fun.
  eapply himpl_frame_l in M.
  applys M K.
Qed.

Lemma triple_app_fun : forall x v1 v2 t1 H Q,
  v1 = val_fun x t1 ->
  triple (subst x v2 t1) H Q ->
  triple (trm_app v1 v2) H Q.
Proof.
  introv M N.
  applys triple_eval_like N.
  introv R. applys eval_app_fun M R.
Qed.

Lemma triple_app_fix : forall v1 v2 F x t1 H Q,
  v1 = val_fix F x t1 ->
  triple (subst x v2 (subst F v1 t1)) H Q ->
  triple (trm_app v1 v2) H Q.
Proof.
  introv M N.
  applys triple_eval_like N.
  introv R. applys eval_app_fix M R.
Qed.

Lemma triple_seq : forall t1 t2 H Q H1,
  triple t1 H (fun v => H1) ->
  triple t2 H1 Q ->
  triple (trm_seq t1 t2) H Q.
Proof.
  introv M1 M2. intros Hf Hb hf hb M.
  forwards* (hf1&hb1&v1&R1&K1): (rm M1).
  forwards* (hf2&hb2&v2&R2&K2): (rm M2).
  exists hf2 hb2 v2. splits~. { applys~ eval_seq R1 R2. }
Qed.

Lemma triple_let :forall x t1 t2 H Q Q1,
  triple t1 H Q1 ->
  (forall v, triple (subst x v t2) (Q1 v) Q) ->
  triple (trm_let x t1 t2) H Q.
Proof.
  introv M1 M2. intros Hf Hb hf hb M.
  forwards* (hf1&hb1&v1&R1&K1): (rm M1).
  forwards* (hf2&hb2&v2&R2&K2): (rm M2).
  exists hf2 hb2 v2. splits~. { applys~ eval_let R2. }
Qed.

Lemma triple_if : forall be t1 t2 H Q,
  triple (if be then t1 else t2) H Q ->
  triple (trm_if (val_bool be) t1 t2) H Q.
Proof.
  introv M. intros Hf Hb hf hb K.
  forwards* (hf1&hb1&v1&R1&K1): (rm M).
  exists hf1 hb1 v1. splits~. { applys* eval_if. }
Qed.

(* ------------ SL structural rules ----------------- *)

(*  _______________Frame Rule in CBS__________________  *)
Lemma triple_frame : forall t H Q Hf Hb,
  triple t H Q ->
  triple t (H \* (\R[Hf,Hb])) (Q \*+ (\R[Hf,Hb])).
Proof.
  unfold triple, hoare. introv M.
  intros Hf' Hb' sf sb.
  specializes M (Hf \f* Hf') (Hb \b* Hb'). introv N.
  rewrite hstar_assoc, hstar_sep in N.
  apply M in N as (sf'&sb'&v&N1&N2).
  exists sf' sb' v.
  rewrite hstar_assoc, hstar_sep. splits~.
Qed.

Lemma triple_conseq : forall t H' Q' H Q,
  triple t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  triple t H Q.
Proof.
  introv M N R.
  unfolds triple.
  intros Hf Hb. specializes M Hf Hb.
  applys hoare_conseq.
  applys M. applys~ himpl_frame_l.
  intros v. applys~ himpl_frame_l.
Qed.

(*prove by hoare triple*)
Lemma triple_conseq' : forall t H' Q' H Q,
  triple t H' Q' ->
  H ==> H' ->
  Q' ===> Q ->
  triple t H Q.
Proof.
  unfolds triple, hoare.
  introv M MH MQ HF.
  forwards (sf'&sb'&v&R&K): M sf sb. {applys~ himpl_frame_l MH HF. }
  exists sf' sb' v. splits~. { applys~ himpl_frame_l. }
Qed.

Lemma triple_conseq_frame : forall H Q Hf Hb H1 Q1 t ,
  triple t H1 Q1 ->
  H ==> H1 \* (\R[Hf, Hb]) ->
  Q1 \*+ (\R[Hf, Hb]) ===> Q ->
  triple t H Q.
Proof.
  introv M N R.
  unfolds triple.
  intros Hf' Hb'.
  specializes M (Hf \f* Hf') (Hb \b* Hb').
  applys hoare_conseq. applys M.
  rewrite <- hstar_sep, <- hstar_assoc;
  applys~ himpl_frame_l.
  intros v. rewrite <- hstar_sep. rewrite <- hstar_assoc.
  applys~ himpl_frame_l.
Qed.

(*prove by hoare triple*)
Lemma triple_conseq_frame' : forall H Q Hf Hb H1 Q1 t ,
  triple t H1 Q1 ->
  H ==> H1 \* (\R[Hf, Hb]) ->
  Q1 \*+ (\R[Hf, Hb]) ===> Q ->
  triple t H Q.
Proof.
  introv M N R.
  unfolds triple, hoare.
  intros Hf' Hb' sf sb ((sf1&sb1)&(sf2&sb2)&MA&MB&MC&MD).
  forwards (sf'&sb'&v&T&K): M sf sb. rewrite MD.
  lets K : himpl_frame_l (\R[Hf',Hb']) H (H1 \* (\R[Hf,Hb])).
  rewrite hstar_assoc, hstar_sep in K.
  apply K in N.  applys~ himpl_frame_l N. applys~ hstar_intro.
  exists sf' sb' v. splits~.
  applys~ himpl_frame_l. rewrite hstar_assoc, hstar_sep. auto.
Qed.

Lemma triple_ramified_frame : forall H1 t Hf Hb H Hf1 Hb1,
  triple t H1 (fun r => \R[Hf1,Hb1]) ->
  H ==> H1 \* (\R[Hf1 \f-* Hf, Hb1 \b-* Hb] ) ->
  triple t H (fun r => \R[Hf,Hb]).
Proof.
  introv M W.
  applys triple_conseq_frame M W.
  intros v.
  applys himpl_trans himpl_frame_r.
  apply hwand_refine.
  apply hwand_cancel.
Qed.

(*====== ramified_frame  ======*)
(*Lemma triple_conseq_frame_of_ramified_frame : forall H2 H1 Hf1 Hb1 t H Hf Hb,
  triple t H1 (fun r => \R[Hf1,Hb1]) ->
  H ==> H1 \* H2 ->
  (fun (r:val) => \R[Hf1,Hb1]) \*+ H2 ===> (fun r => \R[Hf,Hb]) ->
  triple t H (fun r => \R[Hf,Hb]).
Proof.
  introv M WH WQ. applys triple_ramified_frame M.
  applys himpl_trans WH.
  applys himpl_frame_r.
  applys himpl_trans.
  rewrite qwand_equiv. applys WQ.
Qed.*)

(*---------- extract the prue fact and quantifier from precondition ----------*)
Lemma triple_hpure : forall t (P:Prop) Hf Hb Q,
  (P -> triple t (\R[Hf,Hb]) Q) ->
  triple t (\[P] \* \R[Hf,Hb]) Q.
Proof.
  unfold triple. intros. rewrite hstar_assoc,hstar_sep.
  intros hf hb M. apply hstar_hpure_iff in M as [MA MB].
  applys~ H. rewrite~ hstar_sep.
Qed.

Lemma triple_hpure' : forall t (P:Prop) H Q,
  (P -> triple t H Q) ->
  triple t (\[P] \* H) Q.
Proof.
  unfold triple. intros. rewrite hstar_assoc.
  intros hf hb M. apply hstar_hpure_iff in M as [MA MB].
  applys~ H0.
Qed.

Lemma triple_hexists : forall t (A:Type) (J:A->hprop) Q,
  (forall (x:A), triple t (J x) Q) ->
  triple t (\exists (x:A), J x) Q.
Proof.
  unfold triple. intros.  intros hf hb M.
  rewrite hstar_hexists in M.
  destruct M as (v&M). specializes H v. applys~ H.
Qed.

Lemma triple_hbpure : forall t (P:Prop) Hf Hb Q,
  (P -> triple t (\R[Hf,Hb]) Q) ->
  triple t (\R[Hf,\b[P] \b* Hb]) Q.
Proof.
  unfold triple.
  intros. intros hf hb. rewrite hstar_sep.
  intros (MA&MB). simpls.
  rewrite hbstar_assoc in MB.
  apply hbstar_hpure_iff in MB as [MB1 MB2].
  eapply H in MB1. apply MB1.
  rewrite hstar_sep. splits~.
Qed.

Lemma triple_hfpure : forall t (P:Prop) Hf Hb Q,
  (P -> triple t (\R[Hf,Hb]) Q) ->
  triple t (\R[\f[P] \f* Hf,Hb]) Q.
Proof.
  unfold triple.
  intros. intros hf hb. rewrite hstar_sep.
  intros (MA&MB). simpls.
  rewrite hfstar_assoc in MA.
  apply hfstar_hpure_iff in MA as [MA1 MA2].
  eapply H in MA1. apply MA1.
  rewrite hstar_sep. splits~.
Qed.

Lemma triple_hbpure' : forall t (P:Prop) Hf Q,
  (P -> triple t (\R[Hf,\b[]]) Q) ->
  triple t (\R[Hf,\b[P]]) Q.
Proof.
  intros. lets M : triple_hbpure \b[].
  rewrite~ hbstar_hempty_r in M.
Qed.

Lemma triple_hfpure' : forall t (P:Prop) Hb Q,
  (P -> triple t (\R[\f[],Hb]) Q) ->
  triple t (\R[\f[P],Hb]) Q.
Proof.
  intros. lets M : triple_hfpure \f[].
  rewrite~ hfstar_hempty_r in M.
Qed.

Lemma triple_hbexists : forall t (A:Type) (J:A->hbprop) Hf Hb Q,
  (forall (x:A), triple t (\R[ Hf, (J x) \b* Hb]) Q) ->
  triple t (\R[ Hf, (\existsb (x:A), J x) \b* Hb]) Q.
Proof.
  unfold triple. intros. rewrite hstar_sep, hbstar_assoc.
  intros hf hb (MA&MB). simpls.
  rewrite hbstar_hexists in MB.
  destruct MB as (v&MB).
  specializes H v. apply H.
  rewrite hstar_sep. splits~. rewrite~ hbstar_assoc.
Qed.

Lemma triple_hbexists' : forall t (A:Type) (J:A->hbprop) Hf Q,
  (forall (x:A), triple t (\R[ Hf, (J x)]) Q) ->
  triple t (\R[ Hf, (\existsb (x:A), J x)]) Q.
Proof.
  intros. lets M : triple_hbexists \b[].
  rewrite~ hbstar_hempty_r in M. apply M.
  intros. rewrite~ hbstar_hempty_r.
Qed.

Lemma triple_hfexists : forall t (A:Type) (J:A->hfprop) Hf Hb Q,
  (forall (x:A), triple t (\R[(J x)\f*Hf, Hb]) Q) ->
  triple t (\R[ (\existsf (x:A), J x) \f*Hf, Hb]) Q.
Proof.
  unfold triple. intros. rewrite hstar_sep, hfstar_assoc.
  intros hf hb (MA&MB). simpls.
  rewrite hfstar_hexists in MA.
  destruct MA as (v&MA).
  specializes H v. apply H.
  rewrite hstar_sep. splits~. rewrite~ hfstar_assoc.
Qed.

Lemma triple_hfexists' : forall t (A:Type) (J:A->hfprop) Hb Q,
  (forall (x:A), triple t (\R[ (J x), Hb]) Q) ->
  triple t (\R[ (\existsf (x:A), J x), Hb]) Q.
Proof.
  intros. lets M : triple_hfexists \f[].
  rewrite~ hfstar_hempty_r in M. apply M.
  intros. rewrite~ hfstar_hempty_r.
Qed.

(*==================== AUX inner specification==============================*)
Lemma hoare_bcreate' : forall Hf Hb ln,
  hoare (bprim_create (val_listint ln))
    (\R[ Hf, Hb])
    (fun r => \R[ Hf, \existsb b, \b[r = val_bloc b] \b* b ~b~> ln \b* Hb ]).
Proof.
  intros. intros sf sb K0.
  destruct K0 as (P1&P2).
  forwards~ (b&D&N): (Fmap.single_fresh 0%nat sb ln).
  exists sf ((Fmap.single b ln) \u sb) (val_bloc b). subst.
  simpls. splits~.
  (*Notice!!*)
  - applys~ eval_bcreate_sep.
  - splits~. exists b.
    rewrite <- hbstar_assoc.
    applys~ hbstar_intro.
    rewrite~ hbstar_hpure. splits~.
    applys~ hbsingle_intro.
Qed.

Lemma triple_bcreate' : forall Hf ln,
  triple (bprim_create (val_listint ln))
    (\R[ Hf, \b[] ])
    (fun r => (\R[ Hf, (\existsb b, \b[r= (val_bloc b)] \b* b ~b~> ln)]) ).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_bcreate' hstar_sep_l.

  intros r h M.
  destruct M as (MA&MB).
  rewrite hstar_sep, state_get_eq.
  splits~. simpls.
  destruct MB as (pb&MB).
  rewrite hbstar_hexists. exists pb.
  apply hbstar_hpure_iff in MB as [MB1 MB].
  rewrite hbstar_comm, hbstar_assoc, hbstar_hempty_l in MB.
  rewrite~ hbstar_assoc. rewrite hbstar_hpure_iff.
  splits~. rewrite~ hbstar_comm.
Qed.

(*====================== Optimization for Multi arguments =========================*)

(*--- two arguments ---*)
Lemma eval_like_app_fun2 : forall v0 v1 v2 x1 x2 t1,
  v0 = val_fun x1 (trm_fun x2 t1) ->
  (x1 <> x2) ->
  eval_like (subst x2 v2 (subst x1 v1 t1)) (v0 v1 v2).
Proof using.
  introv E N. introv R.
  applys~ eval_app_args.
  - applys~ eval_app_fun E. simpl.
    rewrite var_eq_spec. case_if.
    applys eval_fun.
  - applys eval_val.
  - applys* eval_app_fun.
Qed.

Lemma eval_like_app_fix2 : forall F v0 v1 v2 x1 x2 t1,
  v0 = val_fix F x1 (trm_fun x2 t1) ->
  (x1 <> x2 /\ F <> x2) ->
  eval_like (subst x2 v2 (subst x1 v1 (subst F v0 t1))) (v0 v1 v2).
Proof using.
  introv E (N1&N2). introv R.
  applys~ eval_app_args.
  - applys~ eval_app_fix E. simpl.
    do 2 (rewrite var_eq_spec; case_if).
    applys eval_fun.
  - applys eval_val.
  - applys* eval_app_fun.
Qed.

Lemma triple_app_fun2 : forall x1 x2 v0 v1 v2 t1 H Q,
  v0 = val_fun x1 (trm_fun x2 t1) ->
  (x1 <> x2) ->
  triple (subst x2 v2 (subst x1 v1 t1)) H Q ->
  triple (v0 v1 v2) H Q.
Proof using.
  introv E N M1. applys triple_eval_like M1. applys* eval_like_app_fun2.
Qed.

Lemma triple_app_fix2 : forall F x1 x2 v0 v1 v2 t1 H Q,
  v0 = val_fix F x1 (trm_fun x2 t1) ->
  (x1 <> x2 /\ F <> x2) ->
  triple (subst x2 v2 (subst x1 v1 (subst F v0 t1))) H Q ->
  triple (v0 v1 v2) H Q.
Proof using.
  introv E N M1. applys triple_eval_like M1. applys* eval_like_app_fix2.
Qed.

(* --- three args --- *)

Lemma eval_like_app_fun3 : forall v0 v1 v2 v3 x1 x2 x3 t1,
  v0 = val_fun x1 (trm_fun x2 (trm_fun x3 t1)) ->
  (x1 <> x2  /\ x1 <> x3 /\ x2 <> x3) ->
  eval_like (subst x3 v3 (subst x2 v2 (subst x1 v1 t1))) (v0 v1 v2 v3).
Proof.
  introv E (N1&N2&N3). introv R. applys* eval_app_args.
  { applys* eval_like_app_fun2 E. simpl. do 2 (rewrite var_eq_spec; case_if). applys eval_fun. }
  { applys eval_val. }
  { applys* eval_app_fun. }
Qed.

Lemma triple_app_fun3 : forall x1 x2 x3 v0 v1 v2 v3 t1 H Q,
  v0 = val_fun x1 (trm_fun x2 (trm_fun x3 t1)) ->
  (x1 <> x2  /\ x1 <> x3 /\ x2 <> x3) ->
  triple (subst x3 v3 (subst x2 v2 (subst x1 v1 t1))) H Q ->
  triple (v0 v1 v2 v3) H Q.
Proof.
  introv E (N1&N2&N3) M.
  applys triple_eval_like M. applys* eval_like_app_fun3.
Qed.

(*================== Reasoning rules for mapreduce ===========================*)
(** ++++++++++++++++++++  Hoare Reasoning rules  ++++++++++++++++++++ **)

(*------------ mapper opertions -------------------*)
Lemma hoare_wdmap : forall Hf Hb b ln,
  hoare (bMR_mapper (val_bloc b))
    (\R[ Hf, ( (b ~b~> ln) \b* Hb) ])
    ( fun r => \[r = (WCval_listwdpair (List.map init ln))] \* \R[ Hf, ((b ~b~> ln) \b* Hb)] ).
Proof.
  intros. intros sf sb K0.
  destruct K0 as (P1&P2).
  destruct P2 as (sb1&sb2&D1&D2&D3&D4).
  exists sf sb (WCval_listwdpair (List.map init ln)). subst.
  splits~.
  - lets (E1&N) : hbsingle_inv D1. subst. simpls.
    applys~ eval_wdmap_sep. apply D4.
  - rewrite~ hstar_hpure. splits~. splits~. simpls. substs~.
    applys~ hbstar_intro.
Qed.

(*-------- reducer --------*)

Lemma hoare_wdmerge : forall H Lwd,
  hoare (fMR_merge (WCval_Listwd Lwd)) H
    (fun r => (\[r = WCval_listwdpair (fold_right app nil Lwd)] \* H)).
Proof.
  intros. intros sf sb.
  intros M.
  exists sf sb (WCval_listwdpair (fold_right app nil Lwd)). splits.
  apply eval_merge.
  applys* hstar_hpure_iff.
Qed.

Lemma hoare_wdreduce : forall H Lwd,
  hoare (fMR_reducer (WCval_Listwd Lwd)) H
    (fun r => (\[r = WCval_listwdpair (List.map accmulate Lwd)] \* H)).
Proof.
  intros. intros sf sb.
  intros M.
  exists sf sb (WCval_listwdpair (List.map accmulate Lwd)). splits.
  apply eval_wdreduce.
  applys* hstar_hpure_iff.
Qed.
(*------------------ SL rule: mapper ---------------*)

(** WordCount mapper rules **)
Lemma triple_wdmap : forall Hf b ln,
  triple (bMR_mapper (val_bloc b))
    (\R[ Hf, (b ~b~> ln) ])
    ( fun r => \[r = (WCval_listwdpair (List.map init ln))] \* \R[ Hf, (b ~b~> ln)] ).
Proof.
  intros. unfold triple. intros Hf' Hb'.
  applys hoare_conseq hoare_wdmap.
  rewrite hstar_sep. apply himpl_refl.
  intros r h R.
  rewrite hstar_hpure_iff in R.
  destruct R as (RA&RB).
  rewrite hstar_assoc. rewrite hstar_hpure.
  splits~. rewrite~ hstar_sep.
Qed.

(*------------------ SL rule: reducer ---------------*)

(** WordCount reducer rules **)
Lemma triple_wdmerge : forall H Lwd,
  triple (fMR_merge (WCval_Listwd Lwd)) H
    (fun r => (\[r = WCval_listwdpair (fold_right app nil Lwd)] \* H)).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (WCval_listwdpair (fold_right app nil Lwd)). splits.
  apply eval_merge. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_wdgroup : forall H lwd,
  triple (fMR_group (WCval_listwdpair lwd)) H
    (fun r => (\[r = WCval_Listwd (remove_duplicates (classify lwd lwd))] \* H)).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (WCval_Listwd (remove_duplicates (classify lwd lwd))). splits.
  apply eval_group. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_wdreduce : forall H Lwd,
  triple (fMR_reducer (WCval_Listwd Lwd)) H
    (fun r => (\[r = WCval_listwdpair (List.map accmulate Lwd)] \* H)).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (WCval_listwdpair (List.map accmulate Lwd)). splits.
  apply eval_wdreduce. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

(* rules for aux list operations *)
Lemma triple_app_wdlist : forall H l L,
  triple (val_app_wdlist (WCval_listwdpair l) (WCval_Listwd L)) H
    (fun r => (\[r = WCval_Listwd (l :: L)] \* H)).
Proof.
  intros. intros Hf Hb sf sb M.
  exists sf sb (WCval_Listwd (l :: L)). splits.
  apply eval_app_wdlist. rewrite hstar_assoc.
  applys* hstar_hpure_iff.
Qed.

Lemma triple_MRlist_reform : forall H l1,
  triple (val_reform (WCval_listwdpair l1)) H
    (fun r => (\[r = val_listint (kv2int l1)] \* H)).
Proof.
  intros. unfold triple. intros Hf Hb sf sb M.
  exists sf sb (val_listint (kv2int l1)).
  splits~. apply eval_reform.
  rewrite hstar_assoc.
  apply* hstar_hpure_iff.
Qed.

(* ================================================================================ *)


Require Import Category.Theory.

Require Import Core.Basics.
Require Import Core.Tagged.
Require Import Core.HVec.
Require Import FOL.Signature.
Require Import FOL.Algebra.
Require Import FOL.Sentence.
Require Import Institutions.InsFOPEQ.
Require Import Lib.Institutions.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Program.Equality.
Require Import ProofIrrelevance.

Definition Indexed (I : Type) : Category.
  refine {|
    obj := I -> Type ;
    hom := λ X Y, ∀ i : I, X i -> Y i ;
    homset := Morphism_equality ;
    id := λ I i x, x ;
    compose := λ X Y Z f g i, f i ∘ g i ;
  |}; reflexivity.
Defined.

Definition indexed_coprod {I : Type} (X Y : Indexed I) : Indexed I :=
  λ i : I, (X i + Y i)%type.

Notation "X ⊕ᵢ Y" := (indexed_coprod X Y) (at level 30).

(* a reindexing map u : I -> J induces a functor Setᴶ → Setᴵ *)
Program Definition reindexing_functor {I J} (u : I -> J) : Indexed J ⟶ Indexed I := {|
  fobj := λ X i, X (u i) ;
  fmap := λ X Y f i x, f (u i) x ;
|}.

Record Vars Σ := {
  tvars :> Tagged (Sorts Σ);
  vars_dec : EqDec (tagged_data tvars) eq ;
}.

Arguments tvars [Σ].
Arguments vars_dec [Σ].

(*****************************************************************************)
(** * EVT Signatures *)

Inductive Status := ordinary | anticipated | convergent.

Derive NoConfusion EqDec for Status.

Global Instance status_eqdec : EqDec Status eq.
Proof. apply Status_EqDec. Qed.

Lemma status_eqdec_prop : ∀ x y : Status, x = y \/ x ≠ y.
Proof.
  intros x y; destruct (status_eqdec x y); auto.
Qed.

Definition status_nat (s : Status) : nat :=
  match s with
  | ordinary    => 0
  | anticipated => 1
  | convergent  => 2
  end.

Definition status_le (x y : Status) := le (status_nat x) (status_nat y).

Global Instance status_nat_inj : WeaklyInjective status_nat.
Proof.
  intros x y H; destruct x, y; (discriminate || reflexivity).
Qed.

Global Instance status_le_preorder : PreOrder status_le.
Proof.
  pose proof PeanoNat.Nat.le_preorder.
  split; auto with solve_subterm.
Qed.

Global Instance status_le_partial_order : PartialOrder eq status_le.
Proof.
  intros x y; cbn.
  split; intros.
  - apply PeanoNat.Nat.le_partialorder.
    now rewrite H.
  - apply status_nat_inj.
    apply PeanoNat.Nat.le_partialorder.
    exact H.
Qed.

(* A very similar treatment of these sorts of morphisms is given here:
   https://github.com/peterlefanulumsdaine/general-type-theories/blob/master/Auxiliary/Family.v
   Their way of spelling out the proofs such that they compute better works
   quite well here too. *)
Definition var_morphism [A B : FOSig] (σ : Sorts A -> Sorts B) (X : Vars A) (Y : Vars B) :=
  tagged_morphism σ X Y.

Definition var_morphism_map
    [A B : FOSig] (σ : Sorts A -> Sorts B) (X : Vars A) (Y : Vars B)
    : var_morphism σ X Y -> (X -> Y) :=
  @proj1_sig _ _.

Coercion var_morphism_map : var_morphism >-> Funclass.

Definition var_morphism_commutes
    [A B : FOSig] [σ : Sorts A -> Sorts B] [X Y]
    : ∀ (f : var_morphism σ X Y) (i : X), Y (f i) = σ (X i) :=
  @proj2_sig _ _.

Definition var_morphism_compose
  [A B C : FOSig] [σ : Sorts B -> Sorts C] [τ : Sorts A -> Sorts B] [X Y Z]
  (g : var_morphism σ Y Z) (f : var_morphism τ X Y)
  : var_morphism (σ ∘ τ) X Z.
Proof.
  exists (g ∘ f).
  intros. refine (eq_trans _ _).
  * apply var_morphism_commutes.
  * apply f_equal. apply var_morphism_commutes.
Defined.

Definition varmap_id [Σ] (X : Vars Σ) : var_morphism idmap X X :=
  exist _ idmap (λ _, eq_refl).

Lemma var_morphism_left_id [A B : FOSig] [σ : A ~> B] [X Y] (f : var_morphism σ X Y) :
  var_morphism_compose (varmap_id Y) f = f.
Proof.
  (* unfold var_morphism_compose. destruct f. apply subset_eq_compat. reflexivity. *)
  unfold var_morphism_compose; destruct f; cbn.
  unfold eq_trans. f_equal.
  f_equal; ext. cbn.
  now case (e H).
Qed.

(* eq_trans computes w/o ext in this proof *)
Lemma var_morphism_right_id [A B : FOSig] [σ : A ~> B] [X Y] (f : var_morphism σ X Y) :
  var_morphism_compose f (varmap_id X) = f.
Proof.
  unfold var_morphism_compose; destruct f; f_equal.
Qed.

Lemma var_morphism_assoc
  [A B C D : FOSig] [σ : A ~> B] [τ : B ~> C] [γ : C ~> D] [X Y Z W]
  (f : var_morphism σ X Y) (g : var_morphism τ Y Z) (h : var_morphism γ Z W)
  : var_morphism_compose h (var_morphism_compose g f) = var_morphism_compose (var_morphism_compose h g) f.
Proof.
  (* alternatively: apply subset_eq_compat; reflexivity. *)
  destruct f, g, h.
  unfold var_morphism_compose; f_equal; ext; cbn.
  rewrite <- eq_trans_assoc, eq_trans_map_distr, f_equal_compose; auto.
Qed.

Lemma varmap_id_on_index [Σ] [X Y : Vars Σ] (f : var_morphism idmap X Y) :
  ∀ x, get_tag (f x) = get_tag x.
Proof.
  intros ?; rewrite <- (proj2_sig f); auto.
Qed.

Class Primed [Σ] (X Y : Vars Σ) := {
  prime : var_morphism id{FOSig} X Y ;
  unprime : var_morphism id{FOSig} Y X ;
  p_unp : ∀ y : Y, prime (unprime y) = y ;
  unp_p : ∀ x : X, unprime (prime x) = x ;
}.

Record EvtSignature := {
  base :> Signature ;
  vars  : Vars base ;
  vars' : Vars base ;
  prime_rel : Primed vars vars' ;
}.

Global Instance prel_vars Σ : Primed (vars Σ) (vars' Σ).
Proof.
  exact (prime_rel Σ).
Defined.

(* Idea: create injection [Tagged A ↪ Tagged (List A * A)] and then use regular
   tagged sum *)

Definition lift_vars [Σ] (X : Vars Σ) : Tagged (list (Sorts Σ) * Sorts Σ) := {|
  tagged_data := tagged_data X ;
  get_tag x := ([], get_tag x) ;
|}.

Definition SigExpansion (Σ : FOSig) (X : Vars Σ) : FOSig := {|
  Sorts := Sorts Σ ;
  Funcs := tagged_sum (Funcs Σ) (lift_vars X) ;
  Preds := Preds Σ ;
|}.

Program Definition EvtSigExpansion (Σ : EvtSignature) (X : Vars Σ) : EvtSignature := {|
  base := SigExpansion Σ X ;
  vars := {|
    tvars := vars Σ ;
    vars_dec := vars_dec (vars Σ) ;
  |} ;
  vars' := {|
    tvars := vars' Σ ;
    vars_dec := vars_dec (vars' Σ) ;
  |};
  prime_rel := _ ;
|}.
Next Obligation.
  pose (prime_rel Σ).
  unshelve esplit; cbn.
  - eexact prime.
  - eexact unprime.
  - eexact p_unp.
  - eexact unp_p.
Defined.

Record EvtSigMorphism (Σ Σ' : EvtSignature) : Type := {
  on_base :> SignatureMorphism Σ Σ' ;
  on_vars : var_morphism on_base (vars Σ) (vars Σ') ;
}.

Arguments on_base {Σ Σ'} σ : rename.
Arguments on_vars {Σ Σ'} σ : rename.

(* By proving it exactly like this we can use the structure later. *)
Definition on_vars' {Σ Σ'} (σ : EvtSigMorphism Σ Σ') : var_morphism σ (vars' Σ) (vars' Σ').
  refine (exist _ (λ x, prime (on_vars σ (unprime x))) _); intros; cbn.
  refine (eq_trans _ _). { apply var_morphism_commutes. }
  refine (eq_trans _ _). { apply var_morphism_commutes. }
  apply f_equal, var_morphism_commutes.
Defined.

Lemma eq_evtsigmorphism
    (Σ Σ' : EvtSignature) (σ σ' : EvtSigMorphism Σ Σ')
    (p' : on_sorts σ = on_sorts σ')
    (p : on_base σ = on_base σ')
    (q : rew [λ os, var_morphism os (vars Σ) (vars Σ')] p' in @on_vars Σ Σ' σ = @on_vars Σ Σ' σ')
    : σ = σ'.
Proof.
  destruct σ, σ'.
  cbn in *.
  destruct p, q.
  now simplify_eqs.
Qed.

Definition varsum [Σ] (X Y : Vars Σ) : Vars Σ := {|
  tvars := tagged_sum X Y ;
  vars_dec := sum_eqdec (vars_dec X) (vars_dec Y)
|}.

Notation "X ⊕ Y" := (varsum X Y).

Inductive EVT (Σ : EvtSignature) : Type :=
| Init  : Sen[INS_FOPEQ] (SigExpansion Σ (vars' Σ)) -> EVT Σ
| Event : Sen[INS_FOPEQ] (SigExpansion Σ (vars Σ ⊕ vars' Σ)) -> EVT Σ.

Arguments Event {Σ}.
Arguments Init {Σ}.

(* Arguably, Env should be defined in a similar way … but I don’t quite see the
  advantage. *)
Definition Env [Σ] (X : Vars Σ) (A : Sorts Σ -> Type) :=
  ∀ (x : X), A (get_tag x).

Equations alg_exp_funcs {Σ : FOSig} {X : Vars Σ}
    (A : Algebra Σ) (θ : Env X A) (F : Funcs (SigExpansion Σ X) )
    : HVec (interp_sorts A) (ar F) -> interp_sorts A (res F) :=
  alg_exp_funcs _ _ (Datatypes.inr C) := λ _, θ C ;
  alg_exp_funcs _ _ (Datatypes.inl F) := interp_funcs A F .

Global Transparent alg_exp_funcs.

Definition AlgExpansion {Σ : FOSig} {X : Vars Σ}
    (A : Algebra Σ) (θ : Env X A) : Mod[INS_FOPEQ] (SigExpansion Σ X) := {|
  interp_sorts := λ (s : Sorts (SigExpansion Σ X)), @interp_sorts Σ A s ;
  interp_funcs := alg_exp_funcs A θ ;
  interp_preds := @interp_preds Σ A ;
|}.

Definition join_envs
    {Σ : FOSig} {X X' : Vars Σ} {M : Algebra Σ}
    (θ : Env X M) (θ' : Env X' M) : Env (X ⊕ X') M :=
  λ x, match x with
  | Datatypes.inl x => θ x
  | Datatypes.inr x => θ' x
  end.

Definition join_envs2
    {Σ Σ' : FOSig} {X X' : Vars Σ} {Y Y' : Sorts Σ' -> Type} {σ : Σ ~> Σ'}
    (θ : Env X (Y ∘ σ)) (θ' : Env X' (Y' ∘ σ)) : Env (X ⊕ X') ((Y ⊕ᵢ Y') ∘ σ) :=
  λ x, match x with
  | Datatypes.inl x => Datatypes.inl (θ x)
  | Datatypes.inr x => Datatypes.inr (θ' x)
  end.

Record EvtModel (Σ : EvtSignature) := {
  base_alg :> Algebra Σ ;
  env  : Env (vars Σ) base_alg ;
  env' : Env (vars' Σ) base_alg ;
}.

Arguments base_alg {Σ} M : rename.
Arguments env  {Σ} M : rename.
Arguments env' {Σ} M : rename.

Lemma eq_evt_model {Σ} (M M' : EvtModel Σ)
    (p' : interp_sorts (base_alg M) = interp_sorts (base_alg M'))
    (p : base_alg M = base_alg M')
    (q : rew [λ M', Env (vars Σ) M'] p' in (@env Σ M) = @env Σ M')
    (r : rew [λ M', Env (vars' Σ) M'] p' in (@env' Σ M) = @env' Σ M')
    : M = M'.
Proof.
  destruct M, M'.
  cbn in *.
  destruct p, q, r.
  now simplify_eqs.
Qed.

Definition EvtModelMorphism [Σ] (M N : EvtModel Σ) := AlgebraHom M N.

Program Instance EvtMod (Σ : EvtSignature) : Category := {|
  obj := EvtModel Σ ;
  hom := @EvtModelMorphism Σ ;
  homset := Morphism_equality ;
  id := λ _, id (Category := Alg Σ) ;
  compose := λ _ _ _, compose (Category := Alg Σ)
|}.
Next Obligation. refine (eq_alghom _ _ _ _ _); reflexivity. Qed.
Next Obligation. refine (eq_alghom _ _ _ _ _); reflexivity. Qed.
Next Obligation. refine (eq_alghom _ _ _ _ _); reflexivity. Qed.
Next Obligation. refine (eq_alghom _ _ _ _ _); reflexivity. Qed.

Definition interp_evt {Σ : EvtSignature} (M : EvtModel Σ) (φ : EVT Σ) : Prop :=
  match φ with
  | Init  ψ => AlgExpansion (base_alg M) (env' M) ⊨ ψ
  | Event ψ => AlgExpansion (base_alg M) (join_envs (env M) (env' M)) ⊨ ψ
  end.


(* QuickChick Prelude *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List. Open Scope string.

From QuickChick Require Import QuickChick Tactics.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(* End prelude *)

Require Export Lists.

Inductive list (X:Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Instance dec_list' {A} (p q : list A)
         (D : forall (x y : A), Dec (x = y)) : Dec (p = q).
Proof. constructor; unfold decidable.
       decide equality. apply D.
Defined.

Derive (Arbitrary, Show) for list.
Derive (Sized, CanonicalSized) for list.
Derive SizeMonotonic for list using genSlist.
Derive SizedMonotonic for list.
Derive SizedCorrect for list using genSlist and SizeMonotoniclist.

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Module MumbleGrumble.

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Instance dec_mumble (p q : mumble) : Dec (p = q).
Proof. constructor; unfold decidable; repeat decide equality. Defined.

Derive (Arbitrary, Show) for mumble.
Derive (Sized, CanonicalSized) for mumble.
Derive SizeMonotonic for mumble using genSmumble.
Derive SizedMonotonic for mumble.
Derive SizedCorrect for mumble using genSmumble and SizeMonotonicmumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

Instance dec_grumble' {A} (p q : grumble A)
         (D : forall (x y : A), Dec (x = y)) : Dec (p = q).
Proof. constructor; unfold decidable.
       repeat decide equality.
       apply D.
Defined.

Derive (Arbitrary, Show) for grumble.
Derive (Sized, CanonicalSized) for grumble.
Derive SizeMonotonic for grumble using genSgrumble.
Derive SizedMonotonic for grumble.
Derive SizedCorrect for grumble using genSgrumble and SizeMonotonicgrumble.

End MumbleGrumble.

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

Instance dec_list'' {A} (p q : @list' A)
         (D : forall (x y : A), Dec (x = y)) : Dec (p = q).
Proof. constructor; unfold decidable.
       decide equality. apply D.
Defined.

Derive (Arbitrary, Show) for list'.
Derive (Sized, CanonicalSized) for list'.
Derive SizeMonotonic for list' using genSlist'.
Derive SizedMonotonic for list'.
Derive SizedCorrect for list' using genSlist' and SizeMonotoniclist'.

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Notation "x :: y" := (cons x y)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y)
                     (at level 60, right associativity).

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Admitted. (* QuickChick app_nil_r. *)

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Admitted. (* QuickChick app_assoc. *)

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Admitted. (* QuickChick app_length. *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l1 ++ rev l2.
Admitted. (* QuickChick rev_app_distr. *)

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Admitted. (* QuickChick rev_involutive. *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).

Notation "X * Y" := (prod X Y) : type_scope.

Instance dec_prod' {A} {B} (p q : prod A B)
         (DA : forall (x y : A), Dec (x = y))
         (DB : forall (x y : B), Dec (x = y)) : Dec (p = q).
Proof. constructor; unfold decidable.
       decide equality;
         try solve [apply DA];
         try solve [apply DB].
Defined.

Derive Arbitrary for prod.
Derive Show for prod.
Derive Sized for prod.
Derive CanonicalSized for prod.
Derive SizeMonotonic for prod using genSprod.
Derive SizedMonotonic for prod.

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(*
Fixpoint split {X Y : Type} (l : list (X*Y))
               : (list X) * (list Y)
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
*)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

Instance dec_option' {A} (p q : option A)
         (D : forall (x y : A), Dec (x = y)) : Dec (p = q).
Proof. constructor; unfold decidable.
       decide equality. apply D.
Defined.

Derive Arbitrary for option.
Derive Show for option.
Derive Sized for option.
Derive CanonicalSized for option.
Derive SizeMonotonic for option using genSoption.
Derive SizedMonotonic for option.
Derive SizedCorrect for option using genSoption and SizeMonotonicoption.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
  end.

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

From QuickChick Require Import CoArbitrary.
Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Admitted. (* LEO: CoArbitrary *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

(** **** Exercise: 2 stars (fold_length)  *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternative definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Admitted. (* QuickChick fold_length_correct. *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z
  := let (x,y) := p in f x y.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Admitted. (* QuickChick uncurry_curry. *)

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Admitted. (* CoArbitrary *)


(** * Reduction from typechecking in the Normal System Fsub with arrows to typechecking in the full System Fsub with arrows *)
(* begin details : Imports *)
Require Import Fsub FsubN FsubN_to_Fsub Utils.Various_utils.
From Equations Require Import Equations.

Require Import Undecidability.Synthetic.Definitions.
(* end details *)

Section argument.

Fixpoint encode_term (t:term) : Fsub.term.
Proof. destruct t eqn:?.
  -exact (Fsub.var_term n).
  -apply Fsub.app. apply encode_term,t0_1. apply encode_term,t0_2.
  -apply Fsub.lam. apply encode_on,t0. apply encode_term,t1.
  -apply Fsub.tapp. apply encode_term,t0. apply encode_on,t1.
  -apply Fsub.tlam. apply encode_on,t0. apply encode_term,t1.
Defined.

Definition encoding : @ctx arrow_on * @ctx arrow_on * (term * type)
  -> list Fsub.type * list Fsub.type * (Fsub.term * Fsub.type).
Proof. intros [[Γ Δ] [t τ]]. split.
  -split. exact (map encode_on Γ). exact (map encode_on Δ).
  -split. exact (encode_term t). exact (encode_on τ).
Defined.

Fact chk_ctx_congr {Γ Γ' Δ Δ' t τ} : Δ=Δ' -> Γ=Γ' -> Δ;Γ |- t : τ -> Δ';Γ' |- t : τ.
Proof. congruence. Qed.

Fact encode_on_subst θ τ : encode_on (subst_type θ τ) = Fsub.subst_type (θ >> encode_on) (encode_on τ).
Proof. revert θ. depind τ; intro; cbn; auto.
  -inversion H. rewrite (DPI H1). cbn. now rewrite IHτ1,IHτ2.
  -rewrite IHτ1,IHτ2. unfold up_type_type.
   enough (((var_type var_zero, θ >> ren_type ↑) >> encode_on)
      =(Fsub.var_type 0, (θ >> encode_on) >> Fsub.ren_type ↑)) as ->. auto.
   fext. auto_case. apply encode_on_ren.
Qed.

Fact encode_arr {t σ τ} : encode_on t = Fsub.arr σ τ
  -> {σ0 & { τ0 & t=arr σ0 τ0 /\ encode_on σ0 = σ /\ encode_on τ0=τ}}.
Proof. depind t; try discriminate. inversion H. rewrite (DPI H1).
  intro. inversion H0. exists t1,t2. tauto.
Qed.

Fact encode_all {t σ τ} : encode_on t = Fsub.all σ τ
  -> {σ0 & { τ0 & t=all σ0 τ0 /\ encode_on σ0 = σ /\ encode_on τ0=τ}}.
Proof. depind t; try discriminate.
  -inversion H. rewrite (DPI H1). discriminate.
  -intro. inversion H. exists t1,t2. tauto.
Qed.

Derive Signature for chk.

End argument.

(** ** Synthetic Reduction
*)

Theorem reduction : FsubN_TYPECHK ⪯  Fsub_TYPECHK.
Proof. exists encoding. intros [[Γ Δ] [σ τ]]. cbn. split.
  -intros [i H]. depind H; cbn.
    +eapply Subs. exact IHchkN. apply subN_iff_sub_on,H0.
    +rewrite nth_default_eq,<- map_nth,<-nth_default_eq. apply TVar.
    +now apply Abst.
    +eapply Inst; eassumption.
    +eapply TAbst. revert IHchkN. apply chk_ctx_congr.
      *repeat rewrite map_map. apply map_ext. intro. apply encode_on_ren.
      *rewrite <- map_cons. repeat rewrite map_map. apply map_ext. intro. apply encode_on_ren.
    +cbn in IHchkN. eapply TInst; try eassumption. apply subN_iff_sub_on,H0.
     rewrite H1. rewrite encode_on_subst. enough ((σ1.. >> encode_on)=(encode_on σ1, Fsub.var_type)) as ->. auto.
     fext. auto_case.
  -intro H.  depind H.
    +destruct (encode_on_inv σ) as [σ' Hs]. edestruct IHchk as [i HN].
     2:{ exists (S i). eapply NSubs. exact HN. apply subN_iff_sub_on. now rewrite Hs. }
     now rewrite Hs.
    +depind σ; try discriminate. inversion H. rewrite <- H2 in *.
     rewrite nth_default_eq in H0. change (Fsub.var_type n0) with (encode_on (var_type n0)) in H0.
     rewrite map_nth in H0. rewrite (encode_on_inj H0),<-nth_default_eq.
     exists 0. apply NTVar.
    +depind σ0; try discriminate. inversion H0. destruct (encode_arr H1) as [τ1 [τ2 [H5 [H6 H7]]]].
     rewrite H5. rewrite <- H3 in H6. rewrite (encode_on_inj H6).
     edestruct IHchk as [i HN]. 2:{ exists (S i). eapply NAbst,HN. }
     cbn. now rewrite H3,H4,H7.
    +destruct (encode_on_inv σ) as [σ' Hs]. depind σ0; try discriminate.
     inversion H1. edestruct IHchk1 as [i HN1]. 2: { edestruct IHchk2 as [j HN2].
     2: { exists (S (max i j)). eapply NInst. exact HN1. exact HN2. }
     rewrite H4. now erewrite Hs. } rewrite H3. cbn. now rewrite Hs.
    +depind σ0; try discriminate. inversion H0. destruct (encode_all H1) as [τ1 [τ2 [H5 [H6 H7]]]].
     rewrite H5. rewrite <- H3 in H6. rewrite (encode_on_inj H6).
     edestruct IHchk as [i HN]. 2:{ exists (S i). eapply NTAbst,HN. } cbn.
     rewrite H4,H7. repeat rewrite map_map. rewrite encode_on_ren,H3.
     enough ((fun x : type' => encode_on (ren_type ↑ x))=(fun x : type' => Fsub.ren_type ↑ (encode_on x))) as ->.
     auto. fext. intro. now rewrite encode_on_ren.
    +destruct (encode_on_inv σ) as [σ' Hs]. destruct (encode_on_inv τ) as [τ' Ht].
     depind σ0; try discriminate. inversion H2. edestruct IHchk as [i HN].
     2:{ exists (S i). eapply NTInst; try eassumption. apply subN_iff_sub_on. rewrite H5,Hs. exact H0.
     apply encode_on_inj. rewrite H1,encode_on_subst. enough ((σ1, Fsub.var_type)=(t0.. >> encode_on)) as ->.
     now rewrite Ht. fext. auto_case. } cbn. now rewrite H4,Hs,Ht.
Qed.