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

 Type indexed enriched coproducts

 In this file, we define type indexed coproducts for enriched
 categories. The ideas are similar as for binary coproducts; the
 only difference being that instead of having two summands, the
 summands are indexed by a type.

 Content
 1. Cocones of enriched coproducts
 2. Coproducts in an enriched category
 3. Being a coproduct is a proposition
 4. Coproducts in the underlying category
 5. Builders for coproducts
 6. Coproducts are closed under iso
 7. Coproducts are isomorphic
 8. Enriched categories with coproducts

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.coproducts.

Import MonoidalNotations.
Local Open Scope cat.
Local Open Scope moncat.

Section EnrichedCoproducts.
  Context {V : monoidal_cat}
          {C : category}
          (E : enrichment C V)
          {J : UU}
          (D : J → C).

  (**
   1. Cocones of enriched coproducts
   *)
  Definition enriched_coprod_cocone
    : UU
    := ∑ (a : C), ∏ (j : J), I_{V} --> E ⦃ D j , a ⦄.

  Coercion ob_enriched_coprod_cocone
           (a : enriched_coprod_cocone)
    : C
    := pr1 a.

  Definition enriched_coprod_cocone_in
             (a : enriched_coprod_cocone)
             (j : J)
    : D j --> a
    := enriched_to_arr E (pr2 a j).

  Definition make_enriched_coprod_cocone
             (a : C)
             (p : ∏ (j : J), I_{V} --> E ⦃ D j , a ⦄)
    : enriched_coprod_cocone
    := a ,, p.

  (**
   2. Coproducts in an enriched category
   *)
  Definition is_coprod_enriched
             (a : enriched_coprod_cocone)
    : UU
    := ∏ (w : C),
       isProduct
         J V
         (λ j, E ⦃ D j , w ⦄)
         (E ⦃ a , w ⦄)
         (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)).

  Definition is_coprod_enriched_to_Product
             {a : enriched_coprod_cocone}
             (Ha : is_coprod_enriched a)
             (w : C)
    : Product
        J V
        (λ j, E ⦃ D j , w ⦄).
  Proof.
    use make_Product.
    - exact (E ⦃ a , w ⦄).
    - exact (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)).
    - exact (Ha w).
  Defined.

  Definition coprod_enriched
    : UU
    := ∑ (a : enriched_coprod_cocone),
       is_coprod_enriched a.

  Coercion cocone_of_coprod_enriched
           (a : coprod_enriched)
    : enriched_coprod_cocone
    := pr1 a.

  Coercion coprod_enriched_is_coprod
           (a : coprod_enriched)
    : is_coprod_enriched a
    := pr2 a.

  (**
   3. Being a coproduct is a proposition
   *)
  Proposition isaprop_is_coprod_enriched
              (a : enriched_coprod_cocone)
    : isaprop (is_coprod_enriched a).
  Proof.
    repeat (use impred ; intro).
    apply isapropiscontr.
  Qed.

  (**
   4. Coproducts in the underlying category
   *)
  Section InUnderlying.
    Context {a : enriched_coprod_cocone}
            (Ha : is_coprod_enriched a).

    Definition is_coprod_enriched_arrow
               {w : C}
               (f : ∏ (j : J), D j --> w)
      : a --> w.
    Proof.
      refine (enriched_to_arr E _).
      use (ProductArrow _ _ (is_coprod_enriched_to_Product Ha w)).
      exact (λ j, enriched_from_arr E (f j)).
    Defined.

    Proposition is_coprod_enriched_arrow_in
                {w : C}
                (f : ∏ (j : J), D j --> w)
                (j : J)
      : enriched_coprod_cocone_in a j · is_coprod_enriched_arrow f
        =
        f j.
    Proof.
      unfold is_coprod_enriched_arrow, enriched_coprod_cocone_in.
      use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E _ _))) ; cbn.
      refine (_ @ ProductPrCommutes
                    _ _ _
                    (is_coprod_enriched_to_Product Ha w)
                    _
                    (λ j, enriched_from_arr E (f j))
                    j).
      cbn.
      unfold precomp_arr, enriched_coprod_cocone_in.
      rewrite enriched_from_arr_comp.
      rewrite !assoc.
      apply maponpaths_2.
      rewrite tensor_rinvunitor.
      rewrite !assoc'.
      rewrite mon_linvunitor_I_mon_rinvunitor_I.
      apply maponpaths.
      rewrite <- tensor_split'.
      rewrite !enriched_from_to_arr.
      apply idpath.
    Qed.

    Proposition is_coprod_enriched_arrow_eq
                {w : C}
                {f g : a --> w}
                (q : ∏ (j : J),
                     enriched_coprod_cocone_in a j · f
                     =
                     enriched_coprod_cocone_in a j · g)
      : f = g.
    Proof.
      refine (!(enriched_to_from_arr E _) @ _ @ enriched_to_from_arr E _).
      apply maponpaths.
      use (ProductArrow_eq
               _ _ _
               (is_coprod_enriched_to_Product Ha w)).
      intro j.
      cbn.
      unfold precomp_arr.
      rewrite !assoc.
      rewrite !tensor_rinvunitor.
      rewrite !assoc'.
      rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
      rewrite <- !tensor_split'.
      use (invmaponpathsweq (make_weq _ (isweq_enriched_to_arr E _ _))) ; cbn.
      rewrite !assoc.
      rewrite mon_rinvunitor_I_mon_linvunitor_I.
      rewrite <- !(enriched_to_arr_comp E).
      exact (q j).
    Qed.

    Definition underlying_Coproduct
      : Coproduct J C D.
    Proof.
      use make_Coproduct.
      - exact a.
      - exact (enriched_coprod_cocone_in a).
      - intros w f.
        use iscontraprop1.
        + abstract
            (use invproofirrelevance ;
             intros φ₁ φ₂ ;
             use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ;
             exact (is_coprod_enriched_arrow_eq
                      (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))).
        + exact (is_coprod_enriched_arrow f
                 ,,
                 is_coprod_enriched_arrow_in f).
    Defined.
  End InUnderlying.

  (**
   5. Builders for coproducts
   *)
  Definition make_is_coprod_enriched
             (a : enriched_coprod_cocone)
             (sum : ∏ (w : C) (v : V)
                      (f : ∏ (j : J), v --> E ⦃ D j , w ⦄),
                     v --> E ⦃ a , w ⦄)
             (in_sum : ∏ (w : C) (v : V)
                         (f : ∏ (j : J), v --> E ⦃ D j , w ⦄)
                         (j : J),
                       sum w v f · precomp_arr E w (enriched_coprod_cocone_in a j)
                       =
                       f j)
             (sum_eq : ∏ (w : C) (v : V)
                         (φ₁ φ₂ : v --> E ⦃ a , w ⦄)
                         (q : ∏ (j : J),
                          φ₁ · precomp_arr E w (enriched_coprod_cocone_in a j)
                          =
                          φ₂ · precomp_arr E w (enriched_coprod_cocone_in a j)),
                       φ₁ = φ₂)
    : is_coprod_enriched a.
  Proof.
    intro w.
    use make_isProduct.
    { apply homset_property. }
    intros v f.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intros φ₁ φ₂ ;
         use subtypePath ; [ intro ; use impred ; intro ; apply homset_property | ] ;
         exact (sum_eq
                  w v
                  (pr1 φ₁) (pr1 φ₂)
                  (λ j, pr2 φ₁ j @ !(pr2 φ₂ j)))).
    - simple refine (_ ,, _).
      + exact (sum w v f).
      + exact (in_sum w v f).
  Defined.

  Definition coprod_enriched_to_prod
             (PV : Products J V)
             (a : enriched_coprod_cocone)
             (w : C)
    : E ⦃ a , w ⦄ --> PV (λ j, E ⦃ D j , w ⦄).
  Proof.
    use ProductArrow.
    exact (λ j, precomp_arr E w (enriched_coprod_cocone_in a j)).
  Defined.

  Definition make_is_coprod_enriched_from_z_iso
             (PV : Products J V)
             (a : enriched_coprod_cocone)
             (Ha : ∏ (w : C),
                   is_z_isomorphism (coprod_enriched_to_prod PV a w))
    : is_coprod_enriched a.
  Proof.
    intro w.
    use (isProduct_z_iso _ _ _ _ (pr2 (PV (λ j, E ⦃ D j , w ⦄)))).
    - exact (z_iso_inv (_ ,, Ha w)).
    - abstract
        (intro j ;
         unfold coprod_enriched_to_prod ; cbn ;
         refine (!_) ;
         apply (ProductPrCommutes _ _ _ (PV (λ j, E ⦃ D j , w ⦄)))).
  Defined.

  Section CoproductFromUnderlying.
    Context (PV : Products J V)
            (a : enriched_coprod_cocone)
            (coprod : isCoproduct J C D a (enriched_coprod_cocone_in a))
            (w : C).

    Definition coprod_from_underlying_arr_map
               (f : I_{V} --> PV (λ j, E ⦃ D j , w ⦄))
      : I_{V} --> E ⦃ a , w ⦄.
    Proof.
      apply enriched_from_arr.
      use (CoproductArrow _ _ (make_Coproduct _ _ _ _ _ coprod)).
      intro j.
      exact (enriched_to_arr E (f · ProductPr _ _ _ j)).
    Defined.

    Proposition coprod_from_underlying_arr_map_eq₁
                (f : I_{V} --> E ⦃ a , w ⦄)
      : coprod_from_underlying_arr_map (f · coprod_enriched_to_prod PV a w)
        =
        f.
    Proof.
      unfold coprod_from_underlying_arr_map.
      refine (_ @ enriched_from_to_arr E f).
      apply maponpaths.
      use (CoproductArrow_eq
             _ _ _
             (make_Coproduct _ _ _ _ _ coprod)).
      unfold coprod_enriched_to_prod.
      intro j.
      rewrite CoproductInCommutes ; cbn.
      rewrite (enriched_to_arr_comp E).
      apply maponpaths.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ D k , w ⦄)) _ _ j).
      }
      unfold precomp_arr.
      rewrite !assoc.
      rewrite tensor_rinvunitor.
      rewrite mon_linvunitor_I_mon_rinvunitor_I.
      rewrite !assoc'.
      apply maponpaths.
      rewrite !assoc.
      rewrite <- tensor_split'.
      rewrite enriched_from_to_arr.
      apply idpath.
    Qed.

    Proposition coprod_from_underlying_arr_map_eq₂
                (f : I_{V} --> PV (λ j, E ⦃ D j , w ⦄))
      : coprod_from_underlying_arr_map f · coprod_enriched_to_prod PV a w
        =
        f.
    Proof.
      unfold coprod_from_underlying_arr_map.
      use (ProductArrow_eq
             _ _ _
             (PV (λ j, E ⦃ D j , w ⦄))).
      unfold coprod_enriched_to_prod.
      intro j.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        apply (ProductPrCommutes _ _ _ (PV (λ k, E ⦃ D k , w ⦄)) _ _ j).
      }
      rewrite enriched_from_arr_precomp.
      refine (_ @ enriched_from_to_arr E _).
      apply maponpaths.
      apply (CoproductInCommutes _ _ _ (make_Coproduct _ _ _ _ _ coprod)).
    Qed.
  End CoproductFromUnderlying.

  Definition make_is_coprod_enriched_from_underlying
             (PV : Products J V)
             (a : enriched_coprod_cocone)
             (prod : isCoproduct
                       J C D
                       a
                       (enriched_coprod_cocone_in a))
             (HV : conservative_moncat V)
    : is_coprod_enriched a.
  Proof.
    use (make_is_coprod_enriched_from_z_iso PV).
    intros w.
    use HV.
    use isweq_iso.
    - exact (coprod_from_underlying_arr_map PV a prod w).
    - exact (coprod_from_underlying_arr_map_eq₁ PV a prod w).
    - exact (coprod_from_underlying_arr_map_eq₂ PV a prod w).
  Defined.

  (**
   6. Coproducts are closed under iso
   *)
  Section CoprodIso.
    Context (a : enriched_coprod_cocone)
            (Ha : is_coprod_enriched a)
            (b : C)
            (f : z_iso b a).

    Definition enriched_coprod_cocone_from_iso
      : enriched_coprod_cocone
      := make_enriched_coprod_cocone
           b
           (λ j, enriched_from_arr E (enriched_coprod_cocone_in a j · inv_from_z_iso f)).

    Definition is_coprod_enriched_from_iso
      : is_coprod_enriched enriched_coprod_cocone_from_iso.
    Proof.
      intros w.
      use (isProduct_z_iso _ _ _ _ (Ha w)).
      - exact (precomp_arr_z_iso E w f).
      - abstract
          (intro j ;
           cbn ;
           rewrite <- precomp_arr_comp ;
           apply maponpaths ;
           unfold enriched_coprod_cocone_from_iso ; cbn ;
           unfold  enriched_coprod_cocone_in ; cbn ;
           rewrite enriched_to_from_arr ;
           apply idpath).
    Defined.
  End CoprodIso.

  (**
   7. Coproducts are isomorphic
   *)
  Definition map_between_coproduct_enriched
             {a b : enriched_coprod_cocone}
             (Ha : is_coprod_enriched a)
             (Hb : is_coprod_enriched b)
    : b --> a
    := is_coprod_enriched_arrow
         Hb
         (enriched_coprod_cocone_in a).

  Lemma iso_between_coproduct_enriched_inv
        {a b : enriched_coprod_cocone}
        (Ha : is_coprod_enriched a)
        (Hb : is_coprod_enriched b)
    : map_between_coproduct_enriched Ha Hb · map_between_coproduct_enriched Hb Ha
      =
      identity _.
  Proof.
    unfold map_between_coproduct_enriched.
    use (is_coprod_enriched_arrow_eq Hb).
    intro j.
    rewrite !assoc.
    rewrite !is_coprod_enriched_arrow_in.
    rewrite id_right.
    apply idpath.
  Qed.

  Definition iso_between_coproduct_enriched
             {a b : enriched_coprod_cocone}
             (Ha : is_coprod_enriched a)
             (Hb : is_coprod_enriched b)
    : z_iso a b.
  Proof.
    use make_z_iso.
    - exact (map_between_coproduct_enriched Hb Ha).
    - exact (map_between_coproduct_enriched Ha Hb).
    - split.
      + apply iso_between_coproduct_enriched_inv.
      + apply iso_between_coproduct_enriched_inv.
  Defined.
End EnrichedCoproducts.

(**
 8. Enriched categories with coproducts
 *)
Definition enrichment_coprod
           {V : monoidal_cat}
           {C : category}
           (E : enrichment C V)
           (J : UU)
  : UU
  := ∏ (D : J → C),
     ∑ (a : enriched_coprod_cocone E D),
     is_coprod_enriched E D a.

Proposition isaprop_enrichment_coprod
            {V : monoidal_cat}
            {C : category}
            (HC : is_univalent C)
            (E : enrichment C V)
            (J : UU)
  : isaprop (enrichment_coprod E J).
Proof.
  use invproofirrelevance.
  intros φ₁ φ₂.
  use funextsec ; intro D.
  use subtypePath.
  {
    intro.
    apply isaprop_is_coprod_enriched.
  }
  use total2_paths_f.
  - use (isotoid _ HC).
    use iso_between_coproduct_enriched.
    + exact (pr2 (φ₁ D)).
    + exact (pr2 (φ₂ D)).
  - rewrite transportf_sec_constant.
    use funextsec.
    intro j.
    rewrite transportf_enriched_arr_r.
    rewrite idtoiso_isotoid.
    cbn.
    refine (_ @ enriched_from_to_arr E _).
    apply maponpaths.
    unfold map_between_coproduct_enriched ; cbn.
    etrans.
    {
      apply is_coprod_enriched_arrow_in.
    }
    apply idpath.
Qed.

Definition cat_with_enrichment_coproduct
           (V : monoidal_cat)
           (J : UU)
  : UU
  := ∑ (C : cat_with_enrichment V), enrichment_coprod C J.

Coercion cat_with_enrichment_coproduct_to_cat_with_enrichment
         {V : monoidal_cat}
         {J : UU}
         (C : cat_with_enrichment_coproduct V J)
  : cat_with_enrichment V
  := pr1 C.

Definition coproducts_of_cat_with_enrichment
           {V : monoidal_cat}
           {J : UU}
           (C : cat_with_enrichment_coproduct V J)
  : enrichment_coprod C J
  := pr2 C.


Require Import PerformanceExperiments.LetIn.
Require Import PerformanceExperiments.Lock.

Reserved Notation "'nllet' x := v 'in' f"
         (at level 200, f at level 200,
          format "'nllet'  x  :=  v  'in' '//' f").
Definition LockedLet_In_nat : nat -> (nat -> nat) -> nat
  := lock (@Let_In_nd nat nat).
Notation "'nllet' x := v 'in' f"
  := (LockedLet_In_nat v (fun x => f)).
Definition lock_Let_In_nat : @Let_In_nd nat nat = LockedLet_In_nat
  := eq_sym (unlock _).


(**********************************************************************************
 * The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
 * Traversal of Instruction Code) verification framework
 *
 * Developed by Kenneth Roe
 * For more information, check out www.cs.jhu.edu/~roe
 *
 * StateImplication.v
 * This file contains many defintions and tactics useful in proving that one state
 * implies another.  The key tactic is one that pairs off components of a state.
 *
 * Key definitions:
 *     stateImplication
 *     prove_implication
 *
 **********************************************************************************)

Require Import Omega.
Require Export SfLib.
Require Export ImpHeap.
Require Export AbsState.
Require Export PickElement.
Require Export AbsStateInstance.

(* Glue stuff *)
Fixpoint no_cell_terms (s : absState) : bool :=
    match s with
    | AbsStar a b => if no_cell_terms a then no_cell_terms b else false
    | AbsExists e s => no_cell_terms s
    | AbsExistsT s => no_cell_terms s
    | AbsAll e s => no_cell_terms s
    | AbsEach e s => no_cell_terms s
    | AbsLeaf (AbsCellId) l => false
    | _ => true
    end.

Fixpoint no_r_terms (s : absState) : bool :=
    match s with
    | AbsStar a b => if no_r_terms a then no_r_terms b else false
    | AbsExists e s => no_r_terms s
    | AbsExistsT s => no_r_terms s
    | AbsAll e s => no_r_terms s
    | AbsEach e s => no_r_terms s
    | AbsLeaf (Id x) l => if (beq_nat x 3) (*AbsCell*) then true else if (beq_nat x 1) (*AbsPredicate*) then true else false
    | _ => true
    end.

Fixpoint r_term_list (s : absState) : list absState :=
    match s return list (absState) with
    | AbsStar a b => (r_term_list a)++(r_term_list b)
    | AbsExists e s => r_term_list s
    | AbsExistsT s => r_term_list s
    | AbsAll e s => r_term_list s
    | AbsEach e s => r_term_list s
    | AbsLeaf (Id x) l => if beq_nat x 1 then nil else if beq_nat x 3 then nil else (AbsLeaf (Id x) l)::nil
    | _ => nil
    end.

Fixpoint predicate_list(s : absState) : list absState :=
    match s return list absState with
    | AbsStar a b => (predicate_list a)++(predicate_list b)
    | AbsExists e s => predicate_list s
    | AbsExistsT s => predicate_list s
    | AbsAll e s => predicate_list s
    | AbsEach e s => predicate_list s
    | AbsLeaf (AbsPredicateId) l => (AbsLeaf (AbsPredicateId) l)::nil
    | _ => nil
    end.

Fixpoint strip_front_exists (s : absState) : (absState * nat) :=
    match s with
    | AbsExistsT s => match strip_front_exists s with
                      (st,n) => (st,n+1)
                      end
    (*| AbsExists i l s => match strip_front_exists s with
                         (st,n) => (st,n+1)
                         end*)
    | _ => (s,0)
    end.

Fixpoint map_over (l : list (nat * nat)) (v : nat) :=
    match l with
    | nil => 0
    | ((x1,x2)::r) => if beq_nat x2 v then x1 else map_over r v
    end.

Fixpoint map_over_exp (l : list (nat * nat)) (limit1 : nat) (limit2 : nat) (e : absExp) : absExp :=
   match e return absExp with
   | AbsConstVal v => AbsConstVal v
   | AbsVar v => AbsVar v
   | AbsQVar v => AbsQVar (if ble_nat limit2 v then (v+limit1)-limit2 else map_over l v)
   | AbsFun i ll => AbsFun i (map (map_over_exp l limit1 limit2) ll)
   end.

Fixpoint map_over_state (l : list (nat * nat)) (limit1 : nat) (limit2 : nat) (s : absState) : absState :=
   match s return absState with
    | AbsStar s1 s2 => (AbsStar (map_over_state l limit1 limit2 s1) (map_over_state l limit1 limit2 s2))
    | AbsOrStar s1 s2 => (AbsOrStar (map_over_state l limit1 limit2 s1) (map_over_state l limit1 limit2 s2))
    | AbsExists e s => AbsExists (map_over_exp l limit1 limit2 e) (map_over_state (push_pairs l) (S limit1) (S limit2) s)
    | AbsExistsT s => AbsExistsT (map_over_state (push_pairs l) (S limit1) (S limit2) s)
    | AbsAll e s => AbsAll (map_over_exp l limit1 limit2 e) (map_over_state (push_pairs l) (S limit1) (S limit2) s)
    | AbsEach e s => AbsEach (map_over_exp l limit1 limit2 e) (map_over_state (push_pairs l) (S limit1) (S limit2) s)
    | AbsEmpty => AbsEmpty
    | AbsNone => AbsNone
    | AbsAny => AbsAny
    | AbsLeaf i ll => AbsLeaf i (map (map_over_exp l limit1 limit2) ll)
    | AbsAccumulate i e1 e2 e3 => AbsAccumulate i (map_over_exp l limit1 limit2 e1) (map_over_exp (push_pairs l) (S limit1) (S limit2) e2) (map_over_exp l limit1 limit2 e3)
    | AbsMagicWand s1 s2 => AbsMagicWand (map_over_state l limit1 limit2 s1) (map_over_state l limit1 limit2 s2)
    | AbsUpdateVar s i e => AbsUpdateVar (map_over_state l limit1 limit2 s) i (map_over_exp l limit1 limit2 e)
    | AbsUpdateWithLoc s i e => AbsUpdateWithLoc (map_over_state l limit1 limit2 s) i (map_over_exp l limit1 limit2 e)
    | AbsUpdateLoc s i e => AbsUpdateLoc (map_over_state l limit1 limit2 s) (map_over_exp l limit1 limit2 i) (map_over_exp l limit1 limit2 e)
    | AbsUpdState s1 s2 s3 => AbsUpdState (map_over_state l limit1 limit2 s1) (map_over_state l limit1 limit2 s2) (map_over_state l limit1 limit2 s3)
    | AbsClosure s ll => AbsClosure s (map (map_over_exp l limit1 limit2) ll)
   end.

Fixpoint mem1 (x : nat) (m : list (nat * nat)) :=
    match m with
    | nil => false
    | ((a,b)::r) => if beq_nat a x then true else mem1 x r
    end.

Fixpoint mem2 (x : nat) (m : list (nat * nat)) :=
    match m with
    | nil => false
    | ((a,b)::r) => if beq_nat b x then true else mem2 x r
    end.

Fixpoint complete_mapping1 (x1 : nat) (l1 : nat) (l2 : nat) (s2 : absState) (m : list (nat * nat)) :=
    match x1 with
    | 0 => (m,l1,l2,s2)
    | S x1' => if mem1 x1' m then complete_mapping1 x1' l1 l2 s2 m
               else complete_mapping1 x1' l1 (l2+1) (addStateVar l2 s2) ((x1',l2)::m)
    end.

Fixpoint complete_mapping2 (x2 : nat) (l1 : nat) (l2 : nat) (s1 : absState) (m : list (nat * nat)) :=
    match x2 with
    | 0 => (m,l1,l2,s1)
    | S x2' => if mem2 x2' m then complete_mapping2 x2' l1 l2 s1 m
               else complete_mapping2 x2' (l1+1) l2 (addStateVar l1 s1) ((l1,x2')::m)
    end.

Fixpoint complete_mapping (l1 : nat) (l2 : nat) (m : list (nat * nat))
                          (s1 : absState) (s2 : absState) :=
    match complete_mapping1 l1 l1 l2 s2 m with
    | (m',l1',l2',s2') => match complete_mapping2 l2' l1' l2' s1 m' with
                          | (m'',l1'',l2'',s1'') => (m'',l1'',l2'',s1'',s2')
                          end
    end.

Fixpoint prove_state_implication (tl : nat) (s1: absState) (s2 : absState) (e : env) (h : heap) : Prop :=
    match tl return Prop with
    | 0 => realizeState s1 nil (e,h) -> realizeState s2 nil (e,empty_heap)
    | S n => exists x, prove_state_implication n (instantiateState s1 x) (instantiateState s2 x) e h
    end.

Fixpoint incrementLeft (pairs : list (nat * nat)) :=
    match pairs with
    | ((a,b)::c) => ((S a),b)::(incrementLeft c)
    | nil => nil
    end.

Fixpoint incrementRight (pairs : list (nat * nat)) :=
    match pairs with
    | ((a,b)::c) => (a,(S b))::(incrementLeft c)
    | nil => nil
    end.

(*
 * This top level definition is responsible for proving implications.  It works by first pairing off
 * identical components and then setting up a proof goal for the remainder.
 *)
Inductive prove_implication : list (nat * nat) -> absState -> nat -> absState -> nat -> list (nat * nat) -> absState -> Prop :=
    | CILPairR : forall s1 s2 s1' s2' l1 l2 vars vars' vars'' limit1 limit2 tl,
               Some (s1',s2',l1,l2,vars') = pick2RsNiF s1 s2 vars limit1 limit2 (@nil (list absExp)) (@nil (list absExp)) ->
               (*pick2RsNi s1 s2 vars limit1 limit2 (@nil (list absExp)) (@nil (list absExp )) l1 l2 s1' s2' vars' ->*)
               prove_implication vars' s1' limit1 s2' limit2 vars'' tl ->
               prove_implication vars s1 limit1 s2 limit2 vars'' tl
    | CILPairUpdateWithLoc : forall s1 s2 s1' s2' i1 i2 s1'' s2'' l1 l2 vars vars' vars'' limit1 limit2 tl tl' vars''',
               Some (s1',s2',(AbsUpdateWithLoc s1'' i1 l1),(AbsUpdateWithLoc s2'' i2 l2),vars') = pick2UpdateWithLocsNiF s1 s2 vars limit1 limit2 (@nil (list absExp)) (@nil (list absExp)) ->
               prove_implication vars' s1' limit1 s2' limit2 vars'' tl ->
               prove_implication vars'' s1'' limit1 s2'' limit2 vars''' tl' ->
               prove_implication vars s1 limit1 s2 limit2 vars''' (tl ** (AbsUpdateWithLoc tl' i1 l1))
    (*| CILPairCell : forall s1 s2 s1' s2' loc1 loc2 val1 val2 vars vars' vars'' limit1 limit2 tl,
               pick2Cells s1 s2 vars limit1 limit2 nil nil loc1 loc2 val1 val2 s1' s2' vars' ->
               prove_implication vars' s1' limit1 s2' limit2 vars'' tl ->
               prove_implication vars s1 limit1 s2 limit2 vars'' tl*)
    | CILFinish : forall vars limit1 limit2 s1 s2,
                  prove_implication vars s1 limit1 s2 limit2 vars s1.

Ltac prove_implication := (eapply CILPairR;[solve [compute;reflexivity] | prove_implication]) ||
                          (eapply CILPairUpdateWithLoc;[solve [compute;reflexivity] | prove_implication | prove_implication]) ||
                          (eapply CILFinish;simpl;reflexivity).

Function  stripUpdateWithLocs (s : absState) :=
    match s with
    | AbsUpdateWithLoc ss i v => match substVarState (addStateVar 0 (stripUpdateWithLocs ss)) i v(0) with
                                 | Some x => (AbsExistsT x)
                                 | _ => AbsUpdateWithLoc ss i v
                                 end
    | (a ** b) => ((stripUpdateWithLocs a) ** (stripUpdateWithLocs b))
    | AbsUpdateVar ss i v => AbsUpdateVar (stripUpdateWithLocs ss) i v
    | x => x
    end.

(*
 * The top level state implication theorem.  One state implies another if we
 * can first pair off many of the identical components and then prove that
 * the first state implies the remaining components.
 *)
Theorem stateImplication : forall s state1 (state2 : absState) state1' tl1 tl2 state2' state2'' vars mx l1x l2x state1x state2x state2x' bb,
    realizeState state1 bb s ->
    (state1',tl1) = remove_top_existentials state1 ->
    (state2',tl2) = remove_top_existentials state2 ->
    prove_implication nil state2' tl2 state1' tl1 vars state2'' ->
    (mx,l2x,l1x,state2x,state1x) = complete_mapping tl2 tl1 vars state2'' state1' ->
    state2x' = map_over_state mx l1x l2x state2x ->
    (forall e h b, length b=l1x-> (realizeState state1x (bb++b) (e,h)) -> (exists bbb, realizeState (stripUpdateWithLocs state2x') (bb++bbb) (e,empty_heap))) ->
    realizeState state2 bb s.
Proof. admit. Admitted.

Definition basicStateImplication := stateImplication.

(*
 * The tactics below are all useful in applying the stateImplication
 * theorem above and performing other useful tasks in proving an
 * implication
 *)
Ltac stateImplication :=
    eapply stateImplication;[
        crunch |
        (simpl; reflexivity) |
        (simpl; reflexivity) |
        prove_implication |
        (simpl; reflexivity) |
        (simpl; reflexivity) |
        idtac].
Ltac basicStateImplication :=
    eapply stateImplication;[
        crunch |
        (simpl; reflexivity) |
        (simpl; reflexivity) |
        prove_implication |
        (simpl; reflexivity) |
        (simpl; reflexivity) |
        idtac].

Ltac reduceHyp :=
    match goal with
    | [ H: 1 = 0 |- _ ] => inversion H
    | [ H: 0 = 1 |- _ ] => inversion H
    | [ H: true = false |- _ ] => inversion H
    | [ H: false = true |- _ ] => inversion H
    | [ H: None = Some _ |- _ ] => inversion H
    | [ H: Some _ = None |- _ ] => inversion H
    | [ H: 0 <> 0 |- _ ] => omega
    | [ H: 1 <> 1 |- _ ] => omega
    | [H: context [if beq_nat ?X ?Y then _ else _] |- _] => let x:= fresh in remember (beq_nat X Y) as x; destruct x; compute in H
    | [ H: true = beq_nat _ _ |- _ ] => apply beq_nat_eq in H;subst
    (*| [H: absEval (AbsVar _) _ _ |- _] => inversion H;subst;clear H
    | [H: absEval (AbsNatVal _) _ _ |- _] => inversion H;subst;clear H
    | [H: absEval (AbsHeapVal _) _ _ |- _] => inversion H;subst;clear H
    | [H: context [beq_nat 1 1] |- _ ] => compute in H
    | [H: context [beq_nat 1 0] |- _ ] => compute in H
    | [H: context [beq_nat 0 1] |- _ ] => compute in H
    | [H: context [beq_nat 0 0] |- _ ] => compute in H*)
    | [H: 1 = 1 |- _] => inversion H; subst; clear H
    | [H: 1 = 0 |- _] => inversion H; subst; clear H
    | [H: 0 = 1 |- _] => inversion H; subst; clear H
    | [H: 0 = 0 |- _] => inversion H; subst; clear H
    | [H: NatValue _ = NatValue _ |- _] => inversion H; subst; clear H
    (*| [H: HeapValue _ = HeapValue _ |- _] => inversion H; subst; clear H*)
    | [H: OtherValue _ = OtherValue _ |- _] => inversion H; subst; clear H
    | [H: NoValue = NoValue |- _] => inversion H; subst; clear H
    | [H: realizeState _ _ _ |- _] => inversion H; subst; clear H
    | [H: basicState _ _ _ |- _] => inversion H; subst; clear H
    (*| [H: absEval (AbsQVar _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsHeapRef _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsPlus _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsMinus _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsTimes _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsImply _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsNot _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsAnd _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsOr _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsIte _ _ _) _ _ |- _] => inversion H; subst; clear H
    | [H: absEval (AbsEqual _ _) _ (NatValue 0) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsEqual _ _) _ (NatValue 1) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsLess _ _) _ (NatValue 0) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsLess _ _) _ (NatValue 1) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsRMember _ _ _ _ _) _ (NatValue 0) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsRInclude _ _ _ _ _) _ (NatValue 0) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsRMember _ _ _ _ _) _ (NatValue 1) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsRInclude _ _ _ _ _) _ (NatValue 1) |- _] => inversion H; subst; clear H
    | [H: absEval (AbsEqual _ _) _ (NatValue 1) |- _] => inversion H; subst; clear H*)
    | [H: context [instantiateState _ _] |- _ ] => compute in H
    | [H: exists _, _ |- _] => inversion H; subst; clear H
    | [H: context [(match env_p ?Y ?Z with | Some _ => _ | None => _ end)] |- _] => let xx:=fresh in remember (env_p Y Z) as xx; destruct xx; compute in H
    (*| [H: context [btnat _] |- _] => unfold btnat in H*)
    | [H: context [basicEval _ _] |- _] => unfold basicEval in H
    (*| [H: context [AbsEqualId] |- _] => unfold AbsEqualId in H*)
    (*| [H: context [absCanEvalList _ _] |- _] => compute in H*)
    | [H: Some _ = Some _ |- _] => inversion H; subst; clear H
    end.

Ltac propagate :=
           match goal with
           | [H: fst ?s _ = Some _, C:concreteCompose ?s _ _ |- _] => erewrite composeEnvPropagate1 in H;[idtac|apply C]
           | [H: fst ?s _ = Some _, C:concreteCompose _ ?s _ |- _] => erewrite composeEnvPropagate2 in H;[idtac|apply C]
           | [H: Some _ = fst ?s _, C:concreteCompose ?s _ _ |- _] => erewrite composeEnvPropagate1 in H;[idtac|apply C]
           | [H: Some _ = fst ?s _, C:concreteCompose _ ?s _ |- _] => erewrite composeEnvPropagate2 in H;[idtac|apply C]
           end.

Ltac reduceHypothesis := repeat reduceHyp.

Ltac simplHyp := repeat match goal with
                 | [H: _ = fst (_,_) _ |- _] => simpl in H
                 | [H: fst (_,_) _ = _ |- _] => simpl in H
                 | [H1: ?x ?y = Some _, H2: ?x ?y = Some _ |- _] => rewrite H1 in H2
                 | [H1: Some _ = ?x ?y, H2: Some _ = ?x ?y |- _] => rewrite <- H1 in H2
                 | [H: Some _ = Some _ |- _] => inversion H; subst; clear H
                 end.

Ltac tryEmptyCompose := apply emptyConcreteCompose || idtac.

Ltac simplifyEval :=
     match goal with
     | [H: Some _ = ?e ?v |- context [?e ?v]] => rewrite <- H;simpl;try simplifyEval
     | [H: ?e ?v = Some _ |- context [?e ?v]] => rewrite H;simpl;try simplifyEval
     | [ |- context [env_p _ _]] => unfold env_p;simpl;try simplifyEval
     | [ |- context [env_p _]] => unfold env_p;simpl;try simplifyEval
     (*| [ |- context [btnat _]] => unfold btnat*)
     | [ |- _ = _] => reflexivity
     (*| [ |- context [AbsEqualId] ] => unfold AbsEqualId; simpl; try simplifyEval
     | [ |- context [AbsEqualId] ] => unfold AbsOrId; simpl; try simplifyEval
     | [ |- context [AbsEqualId] ] => unfold AbsRMemberId; simpl; try simplifyEval*)
     | [ |- context [basicEval (Id _) _] ] => unfold basicEval; simpl; try simplifyEval
     end.

Ltac decomposeR :=
    match goal with
    | [ |- Tree 0 _ _ _ empty_heap ] => eapply TreeBase;[omega | unfold empty_heap; reflexivity ]
    end.

Ltac decomposeBasicState :=
    match goal with
    (*| [ |- context [Id 2] ] => try decomposeBasicState*)
    | [ |- basicState (AbsTreeId) (NatValue _::_::NatValue _::_) _] => eapply BStateTree; [try decomposeR | simplifyStripNatValues]
    | [ |- basicState (AbsPredicateId) _ _] => eapply BTStatePredicate;[ omega | intros; simpl; reflexivity ]
    | [ |- _ ] => simpl; simplifyEval; try decomposeBasicState
    end.

Ltac decomposeTheState :=
    match goal with
    | [ |- realizeState (AbsStar _ _) _ _] => eapply RSCompose;[try decomposeTheState | try decomposeTheState | tryEmptyCompose]
    | [ |- realizeState AbsEmpty _ _] => (eapply RSEmpty;simpl;unfold empty_heap;reflexivity)
    | [ |- realizeState (AbsLeaf _ _) _ _] => eapply RSR;[simpl;reflexivity | idtac]
    | [ |- realizeState (AbsAll _ _) _ _] => eapply RSAll;[simpl;reflexivity | simpl;reflexivity | simpl | idtac]
    (*| [ |- realizeStateList ((AbsExistsT _)::_) _] => eapply RSLExistsU;eapply ex_intro;simpl
    | [ |- realizeStateList ((AbsExists _ _ _)::_) _] => eapply RSLExists;eapply ex_intro;simpl
    | [ |- realizeStateList ((AbsEach _ _ _)::_) _] => eapply RSLEach;intros;simpl;decomposeTheState
    | [ |- realizeStateList ((AbsAccumulate _ _ _ _ _ _)::_) _ ] => eapply RSLAccumulate;[simpl;reflexivity|simpl;reflexivity|idtac|simpl;reflexivity]
    | [ |- absEval _ _ _] => decomposeEval
    | [ H:?X <>?X |- _] => let H1 := fresh in assert (X = X) as H1; reflexivity; apply H in H; inversion H*)
    end.
(*
 * The following definition is used to simplify the reduction of realizeState
 *)
Fixpoint destructState (a : absState) (bindings : list (@Value unit)) (s : state) : Prop :=
    match a with
    | AbsStar as1 as2 => exists h1 h2,
                         (destructState as1 bindings (fst s,h1) /\
                          destructState as2 bindings (fst s,h2) /\
                          (forall v, h1 v=None \/ h2 v=None) /\
                          compose_heaps h1 h2=(snd s))
    | AbsOrStar as1 as2 => (destructState as1 bindings s) \/ (destructState as2 bindings s)
    | AbsExists e a => forall  e rl,
                       absEval (env_p s) bindings e = (ListValue rl) ->
                       (exists x, In x rl /\
                           destructState a (bindings++(x::nil)) s)
    | AbsExistsT a => (exists x, destructState a (bindings++(x::nil)) s)
    | AbsAccumulate i e1 e2 e3 => forall v3 vl,
                    absEval (env_p s) bindings e1 = (ListValue vl) ->
                    absEval (env_p s) bindings e3 = v3 ->
                    basicAccumulate i (env_p s) bindings vl e2 v3
    | AbsAll e a => forall rl,
                    absEval (env_p s) bindings e = ListValue rl ->
                    (forall x, In x rl ->
                               destructState a (bindings++(x::nil)) s)
    | AbsEach e a => forall v rl states l,
                     absEval (env_p s) bindings e = v ->
                     v = ListValue rl ->
                     allFirsts rl l ->
                     allSeconds states l ->
                     (forall x y, In (x,y) l -> destructState a (bindings++(x::nil)) y) ->
                     fold_compose states s
    | AbsEmpty => (forall x, snd s x=None)
    | AbsAny => True
    | AbsNone => False
    | AbsLeaf i el => basicState i (map (absEval (env_p s) bindings) el) (snd s)
    | AbsMagicWand as1 as2 => exists h1 h2,
                            (destructState as1 bindings (fst s,h1) /\
                             destructState as2 bindings (fst s,h2) /\
                             (forall v, ~(h1 v=None) \/ h2 v=None) /\
                             compose_heaps h2 (snd s)=h1)
    | AbsUpdateVar ss i e => destructState ss bindings s
    | AbsUpdateWithLoc ss i e => destructState ss bindings s
    | AbsUpdateLoc ss i e => destructState ss bindings s
    | AbsUpdState s1 s2 s3 => destructState s1 bindings s
    | AbsClosure ss el => destructState ss (map (absEval (env_p s) bindings) el) (empty_env,heap_p s)
    end.

Theorem realizeDestructThm : forall s b st,
    @realizeState s b st -> destructState s b st.
Proof. admit. Admitted.

Ltac removeExistentials :=
    repeat (match goal with
     | [ H:realizeState (AbsExistsT _) _ _ |- _ ] => (inversion H; subst; clear H)
     | [ H: exists _, _ |- _ ] => (inversion H;subst;clear H)
     end).

Theorem pickAssertion : forall fs s e P P' bind bind2 x,
    realizeState P bind s ->
    spickElement P ([e]) P' ->
    fst s = fs ->
    x<>0 ->
    noQVarExp e=true ->
    absEval fs bind2 e = NatValue x.
Proof. admit. Admitted.

Theorem pickTerm : forall P bind s fs e P',
    realizeState P bind s ->
    spickElement P e P' ->
    allPredicates e ->
    fst s = fs ->
    realizeState e bind (fs,empty_heap).
Proof. admit. Admitted.

Ltac solvePickTerm X := eapply pickTerm;[apply X | solveSPickElement | solveAllPredicates | simpl; reflexivity].

Theorem pickData : forall P bind s fs e P',
    realizeState P bind s ->
    spickElement P e P' ->
    fst s = fs ->
    (exists h, realizeState e bind (fs,h)).
Proof. admit. Admitted.

Ltac solvePickData X := eapply pickData;[apply X | solveSPickElement | simpl; reflexivity].

Theorem concreteComposeEmpty : forall s1 s2 eee,
    concreteCompose s1 s2 (eee, empty_heap) <-> s1=(eee, empty_heap) /\ s2=(eee, empty_heap).
Proof. admit. Admitted.

Theorem nth_replace_same {t} : forall l m n (vv:t) x, m=n -> n < length l -> nth m (replacenth l n vv) x=vv.
        Proof.
            induction l.
            intros. inversion H0.
            destruct n. intros. rewrite H. simpl. reflexivity.
            intros. rewrite H. simpl. rewrite IHl. reflexivity. reflexivity. simpl in H0. inversion H0.
            omega. omega.
        Qed.

Theorem nth_replace_diff {t} : forall l m n (vv:t) x, m<>n -> nth m (replacenth l n vv) x=nth m l x.
        Proof.
            induction l.
            intros. simpl. reflexivity.
            intros. simpl. destruct n. destruct m. elim H. reflexivity. simpl. reflexivity.
            destruct m. simpl. reflexivity. simpl. rewrite IHl. reflexivity. omega.
        Qed.

Definition validPredicate {ev} (p : @Value ev) :=
    match p with
    | NatValue 0 => false
    | NatValue _ => true
    | _ => false
    end.

Fixpoint replaceExp (e : absExp ) (val: absExp) (rep:absExp) : absExp :=
   if beq_absExp e val then rep
   else
   match e with
   | AbsConstVal x => AbsConstVal x
   | AbsVar v => AbsVar v
   | AbsQVar v => AbsQVar v
   | AbsFun i l => AbsFun i (map (fun x => replaceExp x val rep) l)
   end.

Fixpoint replaceState (s : absState) (val: absExp) (rep: absExp) : absState :=
   match s with
    | AbsStar s1 s2 => (AbsStar (replaceState s1 val rep) (replaceState s2 val rep))
    | AbsOrStar s1 s2 => (AbsOrStar (replaceState s1 val rep) (replaceState s2 val rep))
    | AbsExistsT s => AbsExistsT (replaceState s val rep)
    | AbsExists e s => AbsExists (replaceExp e val rep) (replaceState s val rep)
    | AbsAll e s => AbsAll (replaceExp e val rep) (replaceState s val rep)
    | AbsEach e s => AbsEach (replaceExp e val rep) (replaceState s val rep)
    | AbsEmpty => AbsEmpty
    | AbsNone => AbsNone
    | AbsAny => AbsAny
    | AbsLeaf i l => AbsLeaf i (map (fun x => replaceExp x val rep) l)
    | AbsAccumulate id e1 e2 e3 => AbsAccumulate id (replaceExp e1 val rep) (replaceExp e2 val rep) (replaceExp e3 val rep)
    | AbsMagicWand s1 s2 => AbsMagicWand (replaceState s1 val rep) (replaceState s2 val rep)
    | AbsUpdateVar s i v => AbsUpdateVar (replaceState s val rep) i (replaceExp v val rep)
    | AbsUpdateWithLoc s i v => AbsUpdateWithLoc (replaceState s val rep) i (replaceExp v val rep)
    | AbsUpdateLoc s i v => AbsUpdateLoc (replaceState s val rep) (replaceExp i val rep) (replaceExp v val rep)
     | AbsUpdState s1 s2 s3 => AbsUpdState (replaceState s1 val rep) (replaceState s2 val rep) (replaceState s3 val rep)
    | AbsClosure s l => AbsClosure s (map (fun x => replaceExp x val rep) l)
   end.

Fixpoint pair_check {a} (f : a -> a -> bool) (l1 : list a) (l2 : list a) :=
    match l1,l2 with
    | nil,nil => true
    | (a::b),(c::d) => if f a c then pair_check f b d else false
    | _,_ => false
    end.

Fixpoint equivExp (e1 : absExp) (e2 : absExp) (val:absExp) (rep:absExp) : bool :=
   if beq_absExp e1 e2 then true
   else if beq_absExp e1 val && beq_absExp e2 rep then true
   else if beq_absExp e1 rep && beq_absExp e2 val then true
   else
   match e1,e2 with
   | AbsFun i1 l1,AbsFun i2 l2 => if beq_id i1 i2 then
                                      (fix go ll1 ll2 := match ll1,ll2 with
                                                        | nil, nil => true
                                                        | (ff1::rr1), (ff2::rr2) =>
                                                          if equivExp ff1 ff2 val rep then go rr1 rr2 else false
                                                        | _, _ => false
                                                        end) l1 l2
                                  else false
   | _,_ => false
   end.

Fixpoint equivState (s1 : absState) (s2 : absState) (val: absExp) (rep: absExp) : bool :=
   match s1,s2 with
    | AbsStar s1a s1b,AbsStar s2a s2b => (equivState s1a s2a val rep) && (equivState s1b s2b val rep)
    | AbsOrStar s1a s1b,AbsOrStar s2a s2b => (equivState s1a s2a val rep) && (equivState s1b s2b val rep)
    | AbsExistsT s1, AbsExistsT s2 => (equivState s1 s2 val rep)
    | AbsExists e1 s1, AbsExists e2 s2 => (equivExp e1 e2 val rep) && (equivState s1 s2 val rep)
    | AbsAll e1 s1, AbsAll e2 s2 => (equivExp e1 e2 val rep) && (equivState s1 s2 val rep)
    | AbsEach e1 s1, AbsEach e2 s2 => (equivExp e1 e2 val rep) && (equivState s1 s2 val rep)
    | AbsEmpty, AbsEmpty => true
    | AbsLeaf i1 l1, AbsLeaf i2 l2 =>
                                  if beq_id i1 i2 then
                                      (fix go ll1 ll2 := match ll1,ll2 with
                                                        | nil, nil => true
                                                        | (ff1::rr1), (ff2::rr2) =>
                                                          if equivExp ff1 ff2 val rep then go rr1 rr2 else false
                                                        | _, _ => false
                                                        end) l1 l2
                                  else false
    | AbsAccumulate i1 e1a e1b e1c, AbsAccumulate i2 e2a e2b e2c =>
             (equivExp e1a e2a val rep) && (equivExp e1b e2b val rep) && (equivExp e1c e2c val rep)
    | _, _ => false
   end.

Fixpoint maxBindingExp (e : absExp ) : nat :=
   match e with
   | AbsConstVal x => 0
   | AbsVar v => 0
   | AbsQVar v => S v
   | AbsFun i l => fold_left (fun x y => if ble_nat x y then y else x) (map maxBindingExp l) 0
   end.

Fixpoint clipBinding {ev} (b : list (@Value ev)) (n : nat) :=
    match b,n with
    | (f::r),(S n') => f::(clipBinding r n')
    | _,_ => nil
    end.

Theorem expressionSubLR : forall b b' b'' p st e h exp1 exp2 p',
    realizeState ([p]) b st ->
    validPredicate (absEval e b'' (exp1====exp2))=true ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    st = (e,h) ->
    p' = replaceExp p exp1 exp2 ->
    realizeState ([p']) b st.
Proof. admit. Admitted.

Theorem expressionNotEqualZero1 : forall b b' b'' p st e h exp p',
    realizeState (p) b st ->
    false=validPredicate (absEval e b'' (#0====exp)) ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    st = (e,h) ->
    p' = replaceState p ((#0) <<<< exp) (#1) ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionNotEqualZero2 : forall b b' b'' p st e h exp p',
    realizeState (p) b st ->
    false=validPredicate (absEval e b'' (#0====exp)) ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    st = (e,h) ->
    p' = replaceState p ((#0) ==== exp) (#0) ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionNotEqualZero3 : forall b b' b'' p st e h exp p',
    realizeState (p) b st ->
    false=validPredicate (absEval e b'' (#0====exp)) ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    st = (e,h) ->
    p' = replaceState p (exp ==== (#0)) (#0) ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubRL : forall b b' b'' p st e h exp1 exp2 p',
    realizeState (p) b st ->
    validPredicate (absEval e b'' (exp1====exp2))=true ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    st = (e,h) ->
    p' = replaceState p exp2 exp1 ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubRSLR : forall b b' b'' p st exp1 exp2 p',
    realizeState ([exp1====exp2]) b'' st ->
    realizeState (p) b st ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceState p exp1 exp2 ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubRSNeg : forall b b' b'' p st exp1 p',
    realizeState ([~~exp1]) b'' st ->
    realizeState (p) b st ->
    b' = clipBinding b (maxBindingExp (exp1)) ->
    b' = clipBinding b'' (maxBindingExp (exp1)) ->
    p' = replaceState p exp1 (#0) ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubRSRL : forall b b' b'' p st exp1 exp2 p',
    realizeState ([exp1====exp2]) b'' st ->
    realizeState (p) b st ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceState p exp2 exp1 ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubEval : forall b b' b'' p st exp val p' e,
    @NatValue unit val = absEval e b' exp ->
    realizeState (p) b'' st ->
    e = (fst st) ->
    p' = replaceState p  exp (#val) ->
    b = clipBinding b' (maxBindingExp exp) ->
    b = clipBinding b'' (maxBindingExp exp) ->
    realizeState (p') b'' st.
Proof. admit. Admitted.

Theorem expressionSubEvalEval : forall b p st exp1 exp2 p' e,
    absEval e b exp2 = absEval e b exp1 ->
    realizeState (p) b st ->
    e = (fst st) ->
    p' = replaceState p  exp1 exp2 ->
    realizeState (p') b st.
Proof. admit. Admitted.

Theorem expressionSubGRSLR : forall b b' b'' p st exp1 exp2 p',
    realizeState ([exp1====exp2]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceExp p exp1 exp2 ->
    realizeState ([p']) b st ->
    realizeState ([p]) b st.
Proof. admit. Admitted.

Theorem expressionSubGRSRL : forall b b' b'' p st exp1 exp2 p',
    realizeState ([exp1====exp2]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceExp p exp2 exp1 ->
    realizeState ([p']) b st ->
    realizeState ([p]) b st.
Proof. admit. Admitted.

Theorem expressionSubGLR : forall b b' e b'' p st exp1 exp2 p',
    validPredicate (absEval e b'' (exp1====exp2))=true ->
    e = (fst st) ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceExp p exp1 exp2 ->
    realizeState ([p']) b st ->
    realizeState ([p]) b st.
Proof. admit. Admitted.

Theorem expressionSubGRL : forall b b' b'' p st exp1 exp2 p' e,
    validPredicate (absEval e b'' (exp1====exp2))=true ->
    e = (fst st) ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceState p exp2 exp1 ->
    realizeState (p') b st ->
    realizeState (p) b st.
Proof. admit. Admitted.

Theorem expressionSubGRSNeg : forall b b' b'' p st exp p' e,
    realizeState ([exp]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    p' = replaceExp p (~~exp) (#0) ->
    e = (fst st) ->
    absEval e b p=
    absEval e b p'.
Proof. admit. Admitted.

Theorem expressionSubGRSOr1 : forall b b' b'' p st exp p' e x y,
    realizeState ([exp]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    p' = replaceState p ((exp\\//x)//\\y) (y) ->
    e = (fst st) ->
    realizeState (p') b st ->
    realizeState (p) b st.
Proof. admit. Admitted.

Theorem expressionSubGRSOr2 : forall b b' b'' p st exp p' e x y,
    realizeState ([exp]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    p' = replaceState p ((x\\//exp)//\\y) (y) ->
    e = (fst st) ->
    realizeState (p') b st ->
    realizeState (p) b st.
Proof. admit. Admitted.

Theorem expressionSubGRSNeg1 : forall b b' b'' p st exp p' e,
    realizeState ([exp]) b'' st ->
    b' = clipBinding b (maxBindingExp (exp)) ->
    b' = clipBinding b'' (maxBindingExp (exp)) ->
    p' = replaceState p (~~exp) (#0) ->
    e = (fst st) ->
    realizeState (p') b st ->
    realizeState (p) b st.
Proof. admit. Admitted.

Theorem expressionSubRSVP : forall b b' b'' p st exp1 exp2 p' eee,
    realizeState ([exp1====exp2]) b st ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    p' = replaceExp p exp1 exp2 ->
    eee = fst st ->
    validPredicate (absEval eee b'' p)=validPredicate (absEval eee b'' p').
Proof. admit. Admitted.

Theorem removeQuantVar : forall n b e h var exp1 exp2,
    realizeState exp2 b (e,h) ->
    nth n b NoValue = NatValue (e var) ->
    equivState exp1 exp2 (!!var) (v(n)) = true ->
    realizeState exp1 b (e,h).
Proof. admit. Admitted.

Fixpoint removeReplaceExp (loc1 : absExp) (loc2 : absExp) (exp : absExp) :=
    match exp with
    | AbsFun (AbsNthId) (p::q::nil) =>
                match p,q with
                | (AbsFun (AbsReplaceNthId) (base::l1::val::nil)),l2 =>
                    if (beq_absExp loc1 l1 && beq_absExp loc2 l2) ||
                       (beq_absExp loc1 l2 && beq_absExp loc2 l1) then
                        AbsFun (AbsNthId) (base::l2::nil)
                    else
                        AbsFun (AbsNthId) (p::q::nil)
                | _,_ => AbsFun (AbsNthId) (p::q::nil)
                end
    | (AbsFun i l) => AbsFun i (map (removeReplaceExp loc1 loc2) l)
    | x => x
    end.

Fixpoint removeReplaceState (loc1 : absExp) (loc2 : absExp) (s:absState) : absState :=
   match s with
    | AbsStar s1 s2 => (AbsStar (removeReplaceState loc1 loc2 s1) (removeReplaceState loc1 loc2 s2))
    | AbsOrStar s1 s2 => (AbsOrStar (removeReplaceState loc1 loc2 s1) (removeReplaceState loc1 loc2 s2))
    | AbsExistsT s => AbsExistsT (removeReplaceState loc1 loc2 s)
    | AbsExists e s => AbsExists (removeReplaceExp loc1 loc2 e) (removeReplaceState loc1 loc2 s)
    | AbsAll e s => AbsAll (removeReplaceExp loc1 loc2 e) (removeReplaceState loc1 loc2 s)
    | AbsEach e s => AbsEach (removeReplaceExp loc1 loc2 e) (removeReplaceState loc1 loc2 s)
    | AbsEmpty => AbsEmpty
    | AbsNone => AbsNone
    | AbsAny => AbsAny
    | AbsLeaf i l => AbsLeaf i (map (removeReplaceExp loc1 loc2) l)
    | AbsAccumulate i e1 e2 e3 => AbsAccumulate i (removeReplaceExp loc1 loc2 e1) (removeReplaceExp loc1 loc2 e2) (removeReplaceExp loc1 loc2 e3)
    | AbsMagicWand s1 s2 => AbsMagicWand (removeReplaceState loc1 loc2 s1) (removeReplaceState loc1 loc2 s2)
    | AbsUpdateVar s i v => AbsUpdateVar (removeReplaceState loc1 loc2 s) i (removeReplaceExp loc1 loc2 v)
    | AbsUpdateWithLoc s i v => AbsUpdateWithLoc (removeReplaceState loc1 loc2 s) i (removeReplaceExp loc1 loc2 v)
    | AbsUpdateLoc s i v => AbsUpdateLoc (removeReplaceState loc1 loc2 s) (removeReplaceExp loc1 loc2 i) (removeReplaceExp loc1 loc2 v)
    | AbsUpdState s1 s2 s3 => AbsUpdState (removeReplaceState loc1 loc2 s1) (removeReplaceState loc1 loc2 s2) (removeReplaceState loc1 loc2 s3)
    | AbsClosure s l => AbsClosure s (map (removeReplaceExp loc1 loc2) l)
   end.

Theorem removeReplace : forall b b' b'' p st e h exp1 exp2 p',
    realizeState (p) b st ->
    validPredicate (absEval e b'' (exp1====exp2))=false ->
    b' = clipBinding b (maxBindingExp (exp1====exp2)) ->
    b' = clipBinding b'' (maxBindingExp (exp1====exp2)) ->
    st = (e,h) ->
    p' = removeReplaceState exp1 exp2 p ->
    realizeState (p') b st.
Proof. admit. Admitted.

Fixpoint removeReplaceSameExp (l : absExp) (loc : absExp) (exp : absExp) :=
    match exp with
    | AbsFun (AbsNthId) (p::q::nil) =>
                match p,q with
                | (AbsFun (AbsReplaceNthId) (base::l1::val::nil)),l2 =>
                    if beq_absExp base l && beq_absExp l1 l2 &&
                       beq_absExp l1 loc then
                        val
                    else
                        AbsFun (AbsNthId) (p::q::nil)
                | _,_ => AbsFun (AbsNthId) (p::q::nil)
                end
    | (AbsFun i ll) => AbsFun i (map (removeReplaceSameExp l loc) ll)
    | x => x
    end.

Fixpoint removeReplaceSameState (loc1 : absExp) (loc2 : absExp) (s:absState) : absState :=
   match s with
    | AbsStar s1 s2 => (AbsStar (removeReplaceSameState loc1 loc2 s1) (removeReplaceSameState loc1 loc2 s2))
    | AbsOrStar s1 s2 => (AbsOrStar (removeReplaceSameState loc1 loc2 s1) (removeReplaceSameState loc1 loc2 s2))
    | AbsExistsT s => AbsExistsT (removeReplaceSameState loc1 loc2 s)
    | AbsExists e s => AbsExists (removeReplaceSameExp loc1 loc2 e) (removeReplaceSameState loc1 loc2 s)
    | AbsAll e s => AbsAll (removeReplaceSameExp loc1 loc2 e) (removeReplaceSameState loc1 loc2 s)
    | AbsEach e s => AbsEach (removeReplaceSameExp loc1 loc2 e) (removeReplaceSameState loc1 loc2 s)
    | AbsEmpty => AbsEmpty
    | AbsNone => AbsNone
    | AbsAny => AbsAny
    | AbsLeaf i l => AbsLeaf i (map (removeReplaceSameExp loc1 loc2) l)
    | AbsAccumulate i e1 e2 e3 => AbsAccumulate i (removeReplaceSameExp loc1 loc2 e1) (removeReplaceSameExp loc1 loc2 e2) (removeReplaceSameExp loc1 loc2 e3)
    | AbsMagicWand s1 s2 => AbsMagicWand (removeReplaceSameState loc1 loc2 s1) (removeReplaceSameState loc1 loc2 s2)
    | AbsUpdateVar s i v => AbsUpdateVar (removeReplaceSameState loc1 loc2 s) i (removeReplaceSameExp loc1 loc2 v)
    | AbsUpdateWithLoc s i v => AbsUpdateWithLoc (removeReplaceSameState loc1 loc2 s) i (removeReplaceSameExp loc1 loc2 v)
    | AbsUpdateLoc s i v => AbsUpdateLoc (removeReplaceSameState loc1 loc2 s) (removeReplaceSameExp loc1 loc2 i) (removeReplaceSameExp loc1 loc2 v)
    | AbsUpdState s1 s2 s3 => AbsUpdState (removeReplaceSameState loc1 loc2 s1) (removeReplaceSameState loc1 loc2 s2) (removeReplaceSameState loc1 loc2 s3)
    | AbsClosure s l => AbsClosure s (map (removeReplaceSameExp loc1 loc2) l)
   end.

Theorem removeReplaceSame : forall b p st l loc p' ll n,
    realizeState ([p]) b st ->
    p' = removeReplaceSameExp l loc p ->
    ListValue ll = absEval (fst st) b l ->
    NatValue n = absEval (fst st) b loc ->
    n < length ll ->
    realizeState ([p']) b st.
Proof. admit. Admitted.

Theorem realizeValidPredicate : forall st e h exp b,
    st = (e,h) ->
    (validPredicate (absEval e b exp)=true <-> realizeState ([exp]) b st).
Proof. admit. Admitted.

Theorem validPredicateSymmetry : forall b e exp1 exp2,
    validPredicate (absEval e b (exp1====exp2))=
    validPredicate (absEval e b (exp2====exp1)).
Proof. admit. Admitted.

Function mapSum (env : id -> nat) (b : list (@Value unit)) (values : list (@Value unit)) (e : absExp) : nat :=
  match values with
  | nil => 0
  | (ff::rr) => match (absEval env (b++(ff::nil)) e) with
                | NatValue x => (mapSum env b rr e)+x
                | _ => mapSum env b rr e
                end
  end.

Function singlePred (s : absState) :=
    match s with
    | [x] => Some x
    | (a ** b) => match singlePred a,singlePred b with
                | Some a,Some b => Some (a //\\ b)
                | _,_ => None
                end
    | (a *\/* b) => match singlePred a,singlePred b with
                  | Some a,Some b => Some (a \\// b)
                  | _,_ => None
                  end
    | _ => None
    end.

Theorem andSum8 : forall v0 v1 v2 v3 v4 v5 v6 v7 vv v r e s state ee,
    realizeState (SUM(r,e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::nil) s ->
    (forall x, In x vv ->
               realizeState state (v0::v1::v2::v3::v4::v5::v6::v7::x::nil) s) ->
    Some ee = singlePred state ->
    (@ListValue unit vv) = absEval (fst s) (v0::v1::v2::v3::v4::v5::v6::v7::nil) r ->
    realizeState (SUM(r,ee //\\ e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::nil) s.
Proof. admit. Admitted.

Theorem implySum8x10 : forall v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vv v r e s state ee,
    realizeState (SUM(r,e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s ->
    (forall x, In x vv ->
               realizeState state (v0::v1::v2::v3::v4::v5::v6::v7::x::nil) s) ->
    Some ee = (singlePred state) ->
    (@ListValue unit vv) = absEval (fst s) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) r ->
    realizeState (SUM(r,(~~(addExpVar 8 (addExpVar 8 ee))) \\// e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s.
Proof. admit. Admitted.

Theorem andSum8x10 : forall v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vv v r e s state ee,
    realizeState (SUM(r,e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s ->
    (forall x, In x vv ->
               realizeState state (v0::v1::v2::v3::v4::v5::v6::v7::x::nil) s) ->
    Some ee = (singlePred state) ->
    (@ListValue unit vv) = absEval (fst s) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) r ->
    realizeState (SUM(r,((addExpVar 8 (addExpVar 8 ee))) //\\ e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s.
Proof. admit. Admitted.

Theorem resolveSum8x10 : forall v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vv v r e s state ee ff,
    realizeState (SUM(r,e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s ->
    (forall x, In x vv ->
               realizeState state (v0::v1::v2::v3::v4::v5::v6::v7::x::nil) s) ->
    Some ee = (singlePred state) ->
    (forall x s, In x vv ->
                 realizeState ([((addExpVar 8 (addExpVar 8 ee)))]) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::x::nil) (s,empty_heap) ->
                 realizeState ([e====ff]) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::x::nil) (s,empty_heap)) ->
    (@ListValue unit vv) = absEval (fst s) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) r ->
    realizeState (SUM(r,ff,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s.
Proof. admit. Admitted.

Theorem resolveSum9x10 : forall v0 v1 v2 v3 v4 v5 v6 v7 v8 v9 vv v r e s state ee ff,
    realizeState (SUM(r,e,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s ->
    (forall x, In x vv ->
               realizeState state (v0::v1::v2::v3::v4::v5::v6::v7::v8::x::nil) s) ->
    Some ee = (singlePred state) ->
    (forall x s, In x vv ->
                 realizeState ([(addExpVar 9 ee)]) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::x::nil) (s,empty_heap) ->
                 realizeState ([e====ff]) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::x::nil) (s,empty_heap)) ->
    (@ListValue unit vv) = absEval (fst s) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) r ->
    realizeState (SUM(r,ff,v)) (v0::v1::v2::v3::v4::v5::v6::v7::v8::v9::nil) s.
Proof. admit. Admitted.

Theorem sumDiff : forall s b r e s1 s2 sd x,
    realizeState (SUM(r,(e //\\ x),(#s1))) b s ->
    realizeState (SUM(r,e,(#s2))) b s ->
    sd = s2-s1 ->
    realizeState (SUM(r,(e //\\ (~~x)),(#sd))) b s.
Proof. admit. Admitted.

Theorem sumAllConv : forall r e b s,
    realizeState (SUM(r,e,#0)) b s ->
    realizeState (AbsAll r ([~~e])) b s.
Proof. admit. Admitted.

Function deletenth {t} (x : nat) (l : list t) :=
    match x,l with
    | 0, (f::r) => Some r
    | (S n),(f::r) => match deletenth n r with
                      | Some l => Some (f::l)
                      | _ => None
                      end
    | _,_ => None
    end.

Theorem dumpVar : forall state b s n b',
    realizeState state b s ->
    hasVnState state n=false ->
    Some b' = deletenth n b ->
    realizeState (removeStateVar n state) b' s.
Proof. admit. Admitted.

Theorem dumpVar2 : forall state b s n b',
    realizeState (removeStateVar n state) b' s ->
    hasVnState state n=false ->
    Some b' = deletenth n b ->
    realizeState state b s.
Proof. admit. Admitted.

Theorem mapSumExists : forall v e b vals exp,
    S v = mapSum e b vals exp ->
    exists x, In x vals /\ realizeState ([exp]) (b++(x::nil)) (e,empty_heap).
Proof. admit. Admitted.

Theorem mapSumNeg : forall e b vals exp,
    0 = mapSum e b vals exp ->
    forall x, In x vals -> realizeState ([~~exp]) (b++(x::nil)) (e,empty_heap).
Proof. admit. Admitted.

Theorem subRangeSet {ev} : forall x rl rl0 n v,
    rangeSet (ListValue (@findRecord ev n v)) = ListValue rl0 ->
    In x rl0 ->
    In (@NatValue ev n) rl ->
    rangeSet v = ListValue rl ->
    In x rl.
Proof. admit. Admitted.

Function replacenth {t} (x : nat) (e : t) (l : list t) :=
    match x,l with
    | 0, (f::r) => Some (e::r)
    | (S n),(f::r) => match replacenth n e r with
                      | Some l => Some (f::l)
                      | _ => None
                      end
    | _,_ => None
    end.

Theorem subBoundVar : forall b eee exp b' p p' n,
    nth n b' NoValue = absEval eee b exp ->
    realizeState p b' (eee, empty_heap) ->
    Some b = replacenth n (nth n b NoValue) b' ->
    p' = replaceState p v(n) exp ->
    realizeState p' b (eee,empty_heap).
Proof. admit. Admitted.

Theorem arrayLength : forall v len n b st l,
    realizeState (ARRAY(v,#len,v(n))) b st ->
    nth n b NoValue = ListValue l ->
    length l = len.
Proof. admit. Admitted.

Theorem sumExists : forall b eee r e n,
    realizeState (SUM(r,e,(#(S n)))) b (eee,empty_heap) ->
    realizeState (AbsExists r ([e])) b (eee,empty_heap).
Proof. admit. Admitted.

Theorem reverse: forall st x y b,
    realizeState ([x====y]) b st ->
    realizeState ([y====x]) b st.
Proof. admit. Admitted.

Theorem entailmentUnusedUpdated : forall s b state v e,
     realizeState (AbsUpdateVar state v e) b s ->
     hasVarState state v=false ->
     realizeState state b s.
Proof.
    admit.
Admitted.

Function allEmpty (s : absState) :=
    match s with
    | AbsEmpty => true
    | AbsStar a b => if allEmpty a then allEmpty b else false
    | AbsOrStar a b => if allEmpty a then allEmpty b else false
    | _ => false
    end.

Theorem emptyRealizeState : forall s b e,
    allEmpty(s)=true ->
    @realizeState s b (e,empty_heap).
Proof.
    admit.
Admitted.


Require Import Common.
Require RTL Core.
Import Core.
Section t.

  Variable Phi : state.
  Notation updates := (Tuple.of_list (option ∘ Core.eval_sync) Phi).

  Section defs.
  Variable R : type -> Type.

  (** Combinational bindings (expressions, register reads)  *)
  (* Inductive bind (t : type) : Type :=  *)
  (* | bind_expr :  expr R t ->  bind t *)
  (* | bind_reg_read : var Phi (Treg t) -> bind t *)
  (* | bind_regfile_read : forall n, var Phi (Tregfile n t) -> forall p, R (Tlift (W p)) -> bind t.  *)

  (* Inductive telescope (A : Type): Type := *)
  (* | telescope_end : A -> telescope A *)
  (* | telescope_bind : forall arg, bind arg -> (R arg -> telescope A) -> telescope A.  *)

  Inductive effect  : sync -> Type :=
  | effect_reg_write : forall t,  R t -> R Bool -> effect (Treg t)
  | effect_regfile_write : forall n t,  R t -> R (Tlift (Tfin n)) -> R Bool ->
                                                effect (Tregfile n t).

  Definition effects := Tuple.of_list (effect) Phi.

  Definition block t := RTL.telescope Phi R (R t * expr R Bool *  effects).

  (* Fixpoint compose {t B}  *)
  (*                  (tA : block t) *)
  (*                  (f : R t -> expr R Bool -> effects -> telescope B) : *)
  (*   telescope B := *)
  (*   match tA with *)
  (*     | telescope_end ((r,g),e) => f r g e *)
  (*     | telescope_bind arg b cont => telescope_bind _ arg b (fun x => compose (cont x) f)  *)
  (*   end.  *)

  Notation "x <- e1 ; e2" := (telescope_bind _ _ e1 (fun x => e2)) (right associativity, at level 80, e1 at next level).

  Notation "[< r , g , e >] :- t1 ; t2 " := (compose t1 (fun r g e => t2)) (right associativity, at level 80, e1 at next level).
  Notation " & e " := (telescope_end _ e) (at level 71).
  Arguments Tuple.set {T F l t} _ _ _.
  Definition compile {t} (B : RTL.block Phi R) : block t.

  Definition compile_effect t (E : RTL.effect Phi R) (B : block t) : block t.
  refine (let compile := fix compile {t} (G : R Bool) E (U : block t) : block t :=
              match E with
                | RTL.effect_guard guard L =>
                    x <- bind_expr _ (!G && guard)%expr;
                    List.fold_right
                        (fun e acc => compile x e acc
                        ) U L
                | RTL.effect_reg_write t var val =>
                    [< r, g, acc >] :- U; _
                | RTL.effect_regfile_write n t var adr val =>
                    [< r, g, acc >] :- U; _
                                  end in _).
  (* reg write *)
  refine (let old := Tuple.get _ _ var acc in _).
  inversion old. subst.
  refine (we <- bind_expr _ (!X0 || !G)%expr ;
          w <- bind_expr _ (Emux _ _ (!X0) (!X) (!val) )%expr ;
          & (Tuple.set var (effect_reg_write _ w we) acc )
         ).

  (* regfile write *)
  refine (let old := Tuple.get _ _ var acc in _).
  inversion old. subst.
  refine
    (
      we <- bind_expr _ (!X1 || !G)%expr;
      wadr <- bind_expr _ (Emux _ _ (!X1) (!X0) (!adr));
      wdata <- bind_expr _ (Emux _ _ (!X1) (!X) (!val));
      & (Tuple.set var (effect_regfile_write _ _ wdata wadr we) acc)
    )%expr.

  refine (true <- bind_expr _ (#b true);
          compile true E B
         )%expr.
  Defined.

  let compile := fix compile B :=
      match B with
        | RTL.telescope_end E

  induction B.
  refine (acc :- B; _).

  Arguments effect_guard guard%expr effects%list.

  (** * Compilation *)
  (** This 'smart constructor' reduces the size of the guard, by using
  the fact that [true] is a neutral element for [&&] *)

  Definition andb (a b : expr R Bool): expr R Bool :=
    match a, b with
      | Econstant Tbool x, o
      | o, Econstant Tbool x => if x then o else (#b false)%expr
      | _, _ => (a && b)%expr
    end.

  (**  The compilation function itself *)
  Variable varunit : R Unit.

  Definition convert  l : DList.T (expr R) l -> Tuple.of_list (expr R) l := DList.to_tuple (fun t X => X).

  Fixpoint map T F F' (G : forall t, F t -> F' t) (l : list T) : Tuple.of_list F l -> Tuple.of_list F' l:=
    match l with
      | nil => fun x => x
      | cons t q => fun x => (G t (fst x), map T F F' G q (snd x))
    end.

  Arguments map {T F F'} G l _.
  (*  fst (DList.T_fold' eval_expr [t] exprs) =
   eval_expr t
     (fst
        (DList.T_fold' (fun (t0 : type) (X : expr eval_type t0) => X) [t] exprs))

*)

  Definition compile  t (a : action Phi R t) : telescope (R t * expr R Bool * list effect).
  refine (
      let f := fix compile t (a : action Phi R t) : telescope (R t * expr R Bool * list effect):=
          match a with
            | Return t exp =>
                x <- (bind_expr _ exp);
                & (x, #b true, nil)
            | Bind t u A F =>
                [< rA, gA, eA >] :- compile _ A;
                [< rB, gB, eB >] :- compile _ (F rA);
                & (rB, andb gA gB, List.app eA eB)
            | Assert exp =>
                x <- (bind_expr _ exp);
                & (varunit, !x, nil)%expr
            | Primitive args res p exprs => _
            (* | Try A =>  *)
            (*     [< rA, gA, eA >] :- compile _ A; *)
            (*     let e := effect_guard gA eA in *)
            (*       & (varunit, #b true, [e])%list *)
            (*     (* & (varunit, gA, eA) *) *)
            | OrElse t A A' =>
                [< rA, gA, eA >] :- compile _ A;
                [< rA', gA', eA' >] :- compile _ A';
                let e := effect_guard gA eA in
                let e' := effect_guard ((~ gA) &&  gA')%expr eA' in
                  r <- (bind_expr _ (Emux _ _ gA (!rA) (!rA'))%expr);
                  & ( r , (gA || gA')%expr , [e;e'])%list
          end in f t a).
  (* primitive *)
  revert exprs.
  refine (match p with
            | register_read t v => _
            | register_write t v => _
            | regfile_read n t v p => _
            | regfile_write n t v p => _
          end); clear p; intros exprs.
  (* register read *)
  refine (x <- (bind_reg_read _ v); &(x, #b true, nil)).
  (* register write *)
  refine ( let env := convert _ exprs in
             let w := fst env in
               x <- bind_expr _ w;
           let e := ([effect_reg_write _ v x])%list  in
             &( varunit, #b true, e)
         ).
  (* register file read *)
  refine ( let env := convert _ exprs in
             let adr := fst env in
               adr <- bind_expr _ adr;
           x <- bind_regfile_read _ _ v _ adr;
           &( x, #b true, nil)
         ).
  (* register file write *)
  refine ( let env := convert _ exprs in
             match env with
               | (adr, (w, _)) =>
                   adr <- bind_expr _ adr;
                   w <- bind_expr _ w;
                   let e :=  ([effect_regfile_write _ _ v _ adr w])%list in
                     &( varunit, #b true, e)
             end
         ).
    (* or else *)

  Defined.

  Definition wrap t (T : preblock t) : block.
  Proof.
    eapply compose. apply T.
    intros _ g e.
    refine (            let e := effect_guard g e in
                          & (cons e nil )).
  Defined.
  End defs.

  (** * Semantics *)
  Section sem.
    Variable st : eval_state Phi.
    Definition eval_bind t (b : bind eval_type t) : (eval_type t).
    refine (match b with
              | bind_expr x =>  (eval_expr _ x)
              | bind_reg_read v => (Tuple.get _ _ v st)
              | bind_regfile_read n v p adr =>
                  let rf := Tuple.get Phi (Tregfile n t) v st in
                    Regfile.get rf (Word.unsigned adr)
            end
           ).
    Defined.

    Definition up {A} (x : option A) y := match x with None => y | Some y => y end.

    Fixpoint eval_effect (e :effect eval_type) (Delta : updates) : updates :=
      match e with
        | effect_guard g l' =>
            let fix eval_effects l Delta :=
                match l with
                  | nil => Delta
                  | cons e q =>
                      let Delta := eval_effect e Delta in
                        eval_effects q Delta
                end in
              match eval_expr _ g with
                | true =>  (* match eval_effects l' Delta with *)
                    (*     | Some Delta => Some Delta *)
                    (*     | None => Some Delta *)
                        (* end                         *)
                    eval_effects l' Delta
                | false => Delta
            end
      | effect_reg_write t v w =>
          Core.Diff.add Phi Delta (Treg t) v w
      | effect_regfile_write  n t v p adr w  =>
          let rf := Tuple.get Phi (Tregfile n t) v st in
            let rf := Regfile.set rf (Word.unsigned adr) w in
              Core.Diff.add Phi Delta (Tregfile n t) v rf
    end.

    Fixpoint eval_effects ( l : list (effect eval_type)) Delta : updates :=
      match l with
        | nil =>  Delta
        | cons e q => (* do Delta <- eval_effect e Delta;  *)
            let Delta :=  (eval_effect e Delta) in
            eval_effects q Delta
      end.

    Lemma fold_eval_effects :
      (fix eval_effects l Delta :=
       match l with
                | nil =>  Delta
                | cons e q =>
                    let Delta := (eval_effect e Delta) in
                      (* do Delta <- eval_effect e Delta;  *)
                      eval_effects q Delta
       end)= eval_effects .
    Proof.
      unfold eval_effects. reflexivity.
    Qed.

    (* Lemma eval_effects_cons  t q Delta :  *)
    (*   eval_effects (t :: q) Delta = do Delta' <- eval_effect  t Delta; eval_effects q Delta'.  *)
    (* Proof. *)
    (*   reflexivity.  *)
    (* Qed.  *)

    (* Lemma eval_effect_guard (gA : expr eval_type Bool) eA Delta:  *)
    (*   eval_expr  _ gA = true -> *)
    (*   eval_effect  (effect_guard eval_type gA eA) Delta = eval_effects eA Delta.  *)
    (* Proof.  *)
    (*   intros. simpl. rewrite (fold_eval_effects).  *)
    (*   rewrite H. reflexivity.  *)
    (* Qed.  *)

    Fixpoint eval_preblock t  (T : preblock  eval_type t) :
      updates -> option (eval_type t * updates) :=
      match T with
        | telescope_bind arg bind cont =>
            fun Delta =>
              let res := eval_bind _ bind in
              eval_preblock _ (cont res) Delta
        | telescope_end (p, g, e) => fun Delta =>
                                      let g := eval_expr _ g  in
                                      if g then
                                        Some (p, eval_effects e Delta)
                                      else None
    end.

    Fixpoint eval_block (a : block eval_type) {struct a}: updates ->  updates :=
      match a with
        | telescope_bind arg bind cont =>
            fun Delta =>
              let res  := eval_bind _ bind in
                eval_block (cont res) Delta
        | telescope_end effects => eval_effects effects
      end.

  End sem.

  Notation "x <-- e1 ; e2" := (telescope_bind  _ _ _ e1 (fun x => e2)) (right associativity, at level 80, e1 at next level).
  Notation " & e " := (telescope_end  _ _ e) (at level 71).
  Notation "[< r , g , e >] :- t1 ; t2 " := (compose  _ t1 (fun r g e => t2)) (right associativity, at level 80, t1 at next level).

  Section correctness.

    Notation C := (compile eval_type tt).
    Lemma eval_andb_true x y : (eval_expr Bool (andb eval_type x y)) = (eval_expr Bool x && eval_expr Bool y)%bool.
    Proof.
      Require Import Equality.
      dependent destruction x. simpl.
    Admitted.

    Lemma eval_effects_append  st e f (Delta : updates) :
      eval_effects st (e ++ f) Delta =
                   eval_effects st f (eval_effects st e Delta).
    Proof.
      revert Delta.
      induction e.
      + reflexivity.
      + intros Delta.

        simpl. rewrite IHe. reflexivity.

    Qed.

    Variable st : eval_state Phi.

    Notation "B / Delta " := (eval_preblock st _ B Delta).
    Theorem CPS_compile_correct t (a : action Phi eval_type t)  Delta:
      eval_preblock st _ (C t a ) Delta =  (Core.Sem.eval_action a st Delta).
    Proof.
      revert Delta.
      induction a.
      - intros.  reflexivity.
      - intros Delta. simpl. unfold  Sem.Dyn.Bind. rewrite <- IHa.
        transitivity (do ed <- (C t a) / Delta ;
                      let (e,d) := ed in
                      eval_preblock st u (C u (f e)) d
                   );
        [|destruct  ((C t a) / Delta) as [[ e d ]| ]; simpl; easy].
        clear IHa H.
        generalize (C t a) as T. intros T. clear a.

        induction T. destruct a as [[rA gA] eA].
        simpl in *.
        case_eq (eval_expr Bool gA); intros H.  simpl.
        induction (C u (f rA)). destruct a as [[rB gB] eB]. simpl.
        * rewrite eval_effects_append. rewrite eval_andb_true. rewrite H. simpl. reflexivity.
        * simpl. rewrite H0. reflexivity.

        * induction (C u (f rA)). destruct a as [[rB gB] eB]. simpl.
          rewrite eval_andb_true. rewrite H. reflexivity.
          simpl. rewrite H0. reflexivity.
        * simpl. rewrite H. reflexivity.

      - simpl. intros.
          Ltac t :=
            repeat match goal with
                     | |- context [check ?x ; ?y] =>
                         let H := fresh "check" in
                           case_eq x; intros H
                   end.
          t; trivial.
      -                         (* primitive *)
      intros. destruct p.
        +  simpl. reflexivity.
        + simpl.

          set (x := DList.to_tuple eval_expr exprs).
          replace (x) with (fst x, snd x) by (destruct x; reflexivity).

          Lemma convert_commute  l (dl : DList.T (expr eval_type) l): map  _ _ _ (eval_expr) l (convert _ l dl) = DList.to_tuple (eval_expr) dl.
          Proof.
            induction dl. simpl. reflexivity.
            simpl. f_equal. apply IHdl.
          Qed.
          simpl.

          replace (eval_expr t (fst (convert eval_type [t] exprs))) with (fst x). reflexivity.
          subst x. rewrite <- convert_commute. simpl. reflexivity.

        + simpl.
          rewrite <- convert_commute. simpl. reflexivity.
        + simpl.
          rewrite <- convert_commute. simpl.
          case_eq (convert eval_type ([Tlift (W p); t])%list exprs).
          intros adr [value tt] H.  simpl. simpl in tt.
          reflexivity.

      - intros. simpl.   unfold Sem.Dyn.OrElse.
        rewrite <- IHa1, <- IHa2 . clear IHa1 IHa2.
        generalize (C t a1); intros T; generalize (C t a2); intros T'.
        induction T as [[[rA gA] eA] |]; simpl.
        induction T' as [[[rA' gA'] eA'] |]. simpl compose.
        t. simpl. rewrite check0. simpl.  t. reflexivity.
        simpl. rewrite check0. simpl. t; reflexivity.
        simpl. rewrite H. reflexivity.
        simpl. rewrite H. reflexivity.

    Qed.
End correctness.
End t.
Arguments telescope_bind {Phi R A arg}  _ _.
Notation "'DO' X <- E ; F" := (telescope_bind E (fun X => F)).
Notation "'RETURN' X" := (telescope_end _ _ _ X).
Arguments bind_expr  {Phi R t} _%expr.
Notation "[: v ]" := (bind_reg_read _ _ _ v).
(* Section test.  *)
(*   Require Import MOD.  *)
(*   Definition Z (t : type) := unit.  *)
(*   Eval compute in compile _ Z _ _  (iterate 5 Z) .  *)

(*   Eval compute in compile _ Z _ _ (done 5 Z).  *)

(* End test.  *)

(* Section test2.  *)
(*   Require Import Isa.  *)
(*   Eval compute in compile _ _ 0 _ (loadi_rule 5 (fun _ => nat)).  *)

(*   Eval compute in compile _ _ 0 _ (store_rule 5 (fun _ => nat)).  *)

(* End test2.  *)


Require Export Iron.Language.SystemF2Effect.Step.TypeC.
Require Export Iron.Language.SystemF2Effect.Store.LiveS.
Require Export Iron.Language.SystemF2Effect.Store.LiveE.

(* When a well typed expression transitions to the next state
   then its type is preserved. *)
Theorem preservation
 :  forall se sp sp' ss ss' fs fs' x x' t e
 ,  WfFS   se sp ss  fs
 -> LiveS ss fs -> LiveE  fs e
 -> TypeC  nil nil se sp fs  x   t  e
 -> StepF  ss  sp  fs x  ss' sp' fs' x'
 -> (exists se' e'
    ,  WfFS  se' sp' ss' fs'
    /\ LiveS ss' fs'
    /\ LiveE fs' e'
    /\ SubsVisibleT  nil sp' sp  e  e'
    /\ TypeC nil nil se' sp' fs' x' t e').
Proof.
 intros se sp sp' ss ss' fs fs' x x' t e.
 intros HH HLS HLE HC HS.
 gen t e.
 induction HS; intros.

 (*********************************************************)
 (* Pure evaluation. *)
 Case "SfStep".
 { inverts_typec.
   exists se.
   exists e.
   intuition.

   (* Original effect visibly subsumes effect of result. *)
   - apply subsVisibleT_refl.
     eauto.

   (* Resulting configuration is well typed. *)
   - eapply TcExp; eauto.
     eapply stepp_preservation; eauto.
 }

 (*********************************************************)
 (* Push let context. *)
 Case "SfLetPush".
 { exists se.
   exists e.
   intuition.

   (* Frame stack with new FLet frame is well formed. *)
   - inverts HH. split; auto.
     unfold StoreP in *. rip.
     + inverts H3. nope. eauto.
     + inverts H3. nope. eauto.

   (* All store bindings mentioned by frame stack are still live. *)
   - eapply liveS_push_flet; auto.

   (* Original effect visibly subsumes effect of result. *)
   - inverts_typec.
     eapply subsVisibleT_refl; eauto.

   (* Resulting configuation is well typed. *)
   - inverts_typec.
     eapply TcExp
      with (t1 := t) (e1 := e0) (e2 := TSum e3 e2).
      + eapply EqTrans.
        * eapply EqSumAssoc; eauto.
        * auto.
      + auto.
      + eapply TfConsLet; eauto.
 }

 (*********************************************************)
 (* Pop let context and substitute. *)
 Case "SfLetPop".
 { exists se.
   exists e.
   intuition.

   (* Store is still well formed. *)
   - inverts HH. split; auto.
     unfold StoreP in *.
     rip; firstorder.

   (* After popping top FLet frame, effects of result are still
      to live regions. *)
   - eapply liveE_pop_flet; eauto.

   (* Original effect visibly subsumes effect of result. *)
   - inverts_typec.
     eapply subsVisibleT_refl; eauto.

   (* Resulting configuration is well typed. *)
   - inverts_typec.
     eapply TcExp
      with (t1 := t3) (e1 := e0) (e2 := e3).
      + eapply EqTrans.
        * eapply equivT_sum_left; auto.
          have (KindT nil sp e0 KEffect).
          have (KindT nil sp e3 KEffect).
          eapply KiSum; eauto.
        * auto.
      + eapply subst_val_exp; eauto.
      + auto.
 }

 (*********************************************************)
 (* Create a private region. *)
 Case "SfPrivatePush".
 { inverts_typec.
   set (r := TRgn p).
   exists se.
   exists (TSum (substTT 0 r e0) (substTT 0 r e2)).

   have (SumKind KEffect).

   have (KindT (nil :> KRegion) sp e0 KEffect).

   have (KindT nil sp e1 KEffect)
    by  (eapply equivT_kind_left; eauto).
   have (ClosedT e1).

   have (KindT nil sp e2 KEffect)
    by  (eapply equivT_kind_left; eauto).
   have (ClosedT e2).
   intuition.

   (* All store bindings mentioned by resulting frame stack
      are still live. *)
   - inverts HH.
     subst p.
     eapply liveS_push_fpriv_none_allocRegion; eauto.

   (* Resulting effect is to live regions. *)
   - eapply liveE_sum_above.
     + eapply liveE_phase_change.

       have HLL: (liftTT 1 0 e1 = maskOnVarT 0 e0)
        by  (eapply lowerTT_some_liftTT; eauto).
       rrwrite (liftTT 1 0 e1 = e1) in HLL.

       have (SubsT nil sp e e1 KEffect)
        by  (eapply EqSym in H0; eauto).

       have (LiveE fs e1).

       have HLW: (LiveE (fs :> FPriv None p) e1).
       rewrite HLL in HLW.

       have HL0: (LiveE (fs :> FPriv None p) e0)
        by (eapply liveE_maskOnVarT; eauto).

       trivial.

     + have (SubsT nil sp e e2 KEffect)
        by  (eapply EqSym in H0; eauto).

       have (LiveE fs e2).
       have (LiveE (fs :> FPriv None p) e2).
       rrwrite (substTT 0 r e2 = e2); auto.

   (* Effect of result is subsumed by previous. *)
   - rrwrite ( TSum (substTT 0 r e0) (substTT 0 r e2)
             = substTT 0 r (TSum e0 e2)).
     have (ClosedT e).
     rgwrite (e = substTT 0 r e)
      by (symmetry; eauto).

     simpl.
     set (sp' := SRegion p <: sp).
     assert (SubsVisibleT nil sp' sp (substTT 0 r e) (substTT 0 r e0)).
     { have HE: (EquivT       nil sp' e (TSum e1 e2) KEffect)
        by (subst sp'; eauto).

       have HS: (SubsT        nil sp' e e1 KEffect)
        by (subst sp'; eauto).

       apply lowerTT_some_liftTT in H5.

       assert   (SubsVisibleT nil sp' sp (liftTT 1 0 e) (liftTT 1 0 e1)) as HV.
        rrwrite (liftTT 1 0 e  = e).
        rrwrite (liftTT 1 0 e1 = e1).
        eapply subsT_subsVisibleT.
        auto.
       rewrite H5 in HV.

       rrwrite (liftTT  1 0 e = e) in HV.
       rrwrite (substTT 0 r e = e).
       eapply subsVisibleT_mask; eauto.
     }

     assert (SubsVisibleT nil sp' sp (substTT 0 r e) (substTT 0 r e2)).
     { rrwrite (substTT 0 r e  = e).
       rrwrite (substTT 0 r e2 = e2).

       have HE: (EquivT nil sp' e (TSum e1 e2) KEffect)
        by (subst sp'; eauto).

       eapply SbEquiv in HE.
       eapply SbSumAboveRight in HE.
       eapply subsT_subsVisibleT. auto. auto.
     }

     unfold SubsVisibleT.
      simpl.
      apply SbSumAbove; auto.

   (* Result expression is well typed. *)
   - rrwrite (substTT 0 r e2 = e2).
     eapply TcExp
       with (sp := SRegion p <: sp)
            (t1 := substTT 0 r t0)
            (e1 := substTT 0 r e0)
            (e2 := substTT 0 r e2); auto.

     (* Type of result is equivlent to before *)
     + rrwrite (substTT 0 r e2 = e2).
       eapply EqRefl.
        eapply KiSum; auto.
         * eapply subst_type_type.
            eauto.
            subst r. eauto.

     (* Type is preserved after substituting region handle. *)
     + rgwrite (nil = substTE 0 r nil).
       rgwrite (se  = substTE 0 r se)
        by (inverts HH; symmetry; auto).

       eapply subst_type_exp with (k2 := KRegion).
       * rrwrite (liftTE 0 nil = nil).
         rrwrite (liftTE 0 se  = se)
          by (inverts HH; auto).
         auto.
       * subst r.
         eapply KiRgn.
         rgwrite (SRegion p <: sp = sp ++ (nil :> SRegion p)).
         eapply in_app_right; auto.

     (* New frame stack is well typed. *)
     + eapply TfConsPriv; eauto 2.

       (* Effect of frame stack is still to live regions *)
       * rrwrite (substTT 0 r e2 = e2).
         have    (SubsT nil sp e e2 KEffect)
          by     (eapply EqSym in H0; eauto).
         eapply  liveE_subsT; eauto.

       (* Frame stack is well typed after substituting region handle.
          The initial type and effect are closed, so substituting
          the region handle into them doesn't do anything. *)
       * assert (ClosedT t0).
         { have HK: (KindT  (nil :> KRegion) sp t0 KData).
           eapply kind_wfT in HK.
           simpl in HK.

           have (~FreeT 0 t0)
            by (eapply lowerTT_freeT; eauto).
           eapply freeT_wfT_drop; eauto.
         }

         rrwrite (substTT 0 r t0 = t0).
         rrwrite (substTT 0 r e2 = e2).
         rrwrite (t1 = t0)
          by (eapply lowerTT_closedT; eauto).
         eauto.
 }

 (*********************************************************)
 (* Pop a private region from the frame stack. *)
 Case "SfPrivatePop".
 { inverts_typec.

   (* We can only pop if there is at least on region in the store. *)
   destruct sp.

   (* No regions in store. *)
   - inverts HH. rip.
     unfold StoreP in *. rip.
     have (In (FPriv None p) (fs :> FPriv None p)).
     have (In (SRegion p) nil) by firstorder.
     nope.

   (* At least one region in store. *)
   - destruct s.
     exists se.
     exists e2.
     intuition.

     (* Frame stack is still well formed after popping the top FUse frame *)
     + eapply wfFS_region_deallocate; auto.

     (* After popping top FUse,
        all store bindings mentioned by frame stack are still live. *)
     + eapply liveS_deallocRegion; eauto.

     (* New effect subsumes old one. *)
     + eapply subsT_subsVisibleT.
       have (EquivT nil (sp :> SRegion n) e2 e KEffect).
       eauto.

     (* Resulting configuation is well typed. *)
     + eapply TcExp
         with (sp := sp :> SRegion n)
              (e1 := TBot KEffect)
              (e2 := e2); eauto.

       eapply EqSym; eauto.
 }

 (*********************************************************)
 (* Push an extend frame on the stack. *)
 Case "SfExtendPush".
 { inverts_typec.
   set (r1 := TRgn p1).
   set (r2 := TRgn p2).
   exists se.
   exists (TSum (substTT 0 r2 e0) (TSum e2 (TAlloc r1))).
   intuition.

   (* Updated store is well formed. *)
   - inverts_kind.
     eapply wfFS_push_priv_ext; auto.

   (* Updated store is live relative to frame stack. *)
   - inverts HH.
     subst p2.
     eapply liveS_push_fpriv_some_allocRegion; eauto.

     assert (SubsT nil sp e (TAlloc (TRgn p1)) KEffect).
     { have (SubsT nil sp e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
       eapply SbSumAboveLeft; eauto.
     }

     have (LiveE fs (TAlloc (TRgn p1))).
     eapply liveSP_from_effect; eauto.
      snorm.

   (* Frame stack is live relative to effect. *)
   - apply liveE_sum_above.
     + assert (ClosedT eL).
       { have (KindT nil sp (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
         inverts_kind. eauto.
       }

       have HLL: (liftTT 1 0 eL = maskOnVarT 0 e0)
        by  (eapply lowerTT_some_liftTT; eauto).
       rrwrite (liftTT 1 0 eL = eL) in HLL.

       have (LiveE fs (TSum (TSum eL (TAlloc (TRgn p1))) e2))
        by (eapply liveE_equivT_left; eauto).
       have (LiveE fs eL).

       apply liveE_phase_change.

       have HLW: (LiveE (fs :> FPriv (Some p1) p2) eL).
       rewrite HLL in HLW.

       eapply liveE_maskOnVarT; eauto.

    + have (SubsT nil sp e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
      apply liveE_sum_above.
      * have (SubsT nil sp e e2 KEffect).
        eapply liveE_subsT; eauto.
      * have (SubsT nil sp e (TAlloc (TRgn p1)) KEffect).
        eapply liveE_subsT; eauto.

   (* Effect of result is subsumed by previous. *)
   - set (sp' := SRegion p2 <: sp).
     have (KindT nil sp    (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
     have (SubsT nil sp' e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect)
      by (subst sp'; eapply subsT_stprops_snoc; eauto).

     inverts_kind.

     assert (SubsVisibleT nil sp' sp e (substTT 0 r2 e0)) as HE1.
     { eapply subsVisibleT_mask
        with (p := p2); auto.

       have HL: (liftTT 1 0 eL = maskOnVarT 0 e0)
        by (apply lowerTT_some_liftTT; auto).

       rewrite <- HL.
       rgwrite (liftTT 1 0 eL = eL).
       eapply subsT_subsVisibleT.
       eapply SbSumAboveLeft; eauto.
      }

     assert (SubsVisibleT nil sp' sp e e2)          as HE2.
     { eapply subsT_subsVisibleT.
       eapply SbSumAboveRight; eauto.
     }

     assert (SubsVisibleT nil sp' sp e (TAlloc r1)) as HE3.
     { subst r1.
       eapply subsT_subsVisibleT.
       eapply SbSumAboveLeft; eauto.
     }
     eauto.

   (* Resulting state is well typed. *)
   - eapply TcExp
       with (e1 := substTT 0 r2 e0)
            (e2 := TSum e2 (TAlloc r1))
            (t1 := substTT 0 r2 t0).
     (* Equivalence of result effect *)
     + eapply EqRefl.
       eapply KiSum; auto.
       * subst r2.
         have (KindT (nil :> KRegion) sp                 e0 KEffect).
         have (KindT (nil :> KRegion) (SRegion p2 <: sp) e0 KEffect).
         have (KindT nil (SRegion p2 <: sp) (TRgn p2) KRegion).
         eapply subst_type_type. eauto. eauto.
       * apply equivT_kind_left in H0.
         inverts_kind. subst r1.
         eapply KiSum; auto.
         eapply KiCon1. snorm. eauto.

     (* Expression with new region subst is well typed. *)
     + rgwrite (nil = substTE 0 r2 nil).
       rgwrite (se  = substTE 0 r2 se)
        by (inverts HH; symmetry; auto).

       eapply subst_type_exp.
       * eapply typex_stprops_snoc.
         rgwrite (nil = liftTE 0 nil).
         rgwrite (se  = liftTE 0 se)
          by (inverts HH; symmetry; auto).
         eauto.
       * subst r2. eauto.

     (* Extended frame stack is well typed. *)
     + have (KindT (nil :> KRegion) sp t0 KData).
       have (not (In (SRegion p2) sp))
        by (subst p2; auto).
       eapply TfConsExt; eauto.
       * inverts_kind. eauto.
       * eapply typeF_freshSuppFs; eauto.
       * have (LiveE fs (TSum (TSum eL (TAlloc (TRgn p1))) e2))
          by (eapply liveE_equivT_left; eauto).
         eapply liveE_sum_above.
          eapply liveE_sum_above_right; eauto.
          eapply liveE_sum_above_left  in H4.
          eapply liveE_sum_above_right in H4.
          trivial.
       * erewrite mergeT_substTT.
         eapply typeF_stprops_snoc. auto.
         eauto. eauto.
  }

 (*********************************************************)
 (* Pop and extend frame from the stack,
    and merge the new region with the old one. *)
 Case "SfExtendPop".
 { inverts_typec.
   set (r1 := TRgn p1).
   set (r2 := TRgn p2).
   exists (mergeTE p1 p2 se).
   exists e0.
   intuition.

   (* Updated store is well formed. *)
   - rrwrite (map (mergeB p1 p2) ss = mergeBs p1 p2 ss).
     eapply wfFS_pop_priv_ext; eauto.

   (* Updated store is live relative to frame stack. *)
   - SCase "LiveS".
     eapply liveS_mergeB.
     + have (LiveSF ss (FPriv (Some p1) p2)).
       unfold LiveSF in H0.
       unfold LiveSP. intros.
       eapply H0 in H1. inverts H1. auto.
     + have (LiveS ss fs).
       auto.

   (* Frame stack is live relative to effect. *)
   - SCase "LiveE".
     eapply liveE_sum_above_left; eauto.

   (* Effect of result is subsumed by previous. *)
   - SCase "SubsVisibleT".
     eapply subsT_subsVisibleT.
     set (e' := (TSum (TBot KEffect) (TSum e0 (TAlloc (TRgn p1))))).
     have (KindT  nil sp e'   KEffect).
     have (EquivT nil sp e e' KEffect).
     eapply SbSumAboveRight; eauto.

   (* Resulting state is well typed. *)
   - SCase "TypeC".
     eapply TcExp
       with (t1 := mergeT p1 p2 t1)
            (e1 := TBot KEffect)
            (e2 := e0).

     (* Equivalence of result effect. *)
     + have (KindT nil sp (TSum (TBot KEffect)
                          (TSum e0 (TAlloc (TRgn p1)))) KEffect).
       inverts_kind.
       eapply EqSym; eauto.

     (* Result value is well typed. *)
     + rgwrite (nil                    = mergeTE p1 p2 nil).
       rgwrite (XVal (mergeV p1 p2 v1) = mergeX  p1 p2 (XVal v1)).
       rgwrite (TBot KEffect           = mergeT  p1 p2 (TBot KEffect)).
       eapply mergeX_typeX. auto. eauto.

     (* Popped frame stack is well typed. *)
     + rgwrite (nil = mergeTE p1 p2 nil).
       eapply typeF_mergeTE; eauto.
 }

 (*********************************************************)
 (* Allocate a reference. *)
 Case "SfStoreAlloc".
 { inverts HC.
   inverts H0.
   exists (TRef   (TRgn p1) t2 <: se).
   exists e2.
   intuition.

   (* Store is well formed after adding a binding. *)
   - remember (TRgn p1) as r.

     have (SubsT nil sp e (TAlloc r) KEffect)
      by  (eapply EqSym in H; eauto).

     have (LiveE fs (TAlloc r)).
     subst r.

     eapply wfFS_stbind_snoc; auto.
     inverts_kind. auto.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
   - eapply EqSym in H.
      eapply subsT_subsVisibleT; eauto.
      eauto. eauto.

   (* Resulting configuation is well typed. *)
   - eapply TcExp
      with (t1 := TRef (TRgn p1) t2)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym.
        * eauto.
        * eapply KiSum; eauto.
        * eapply equivT_sum_left; eauto.
     + eapply TxVal.
       eapply TvLoc.
        have    (length se = length ss).
        rrwrite (length ss = length se).
        eauto. eauto.
     + eapply typeF_stenv_snoc; eauto.
 }

 (*********************************************************)
 (* Read from a reference. *)
 Case "SfStoreRead".
 { inverts HC.
   exists se.
   exists e2.
   intuition.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H0; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
   - eapply EqSym in H0.
      eapply subsT_subsVisibleT; eauto.
      eauto. eauto.

   (* Resulting configutation is well typed. *)
   - eapply TcExp
      with (t1 := t1)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym; eauto.
     + inverts H1.
       inverts H12.
       eapply TxVal.
        inverts HH. rip.
        eapply storet_get_typev; eauto.
     + eauto.
 }

 (*********************************************************)
 (* Write to a reference. *)
 Case "SfStoreWrite".
 { inverts HC.
   exists se.
   exists e2.
   intuition.

   (* Resulting store is well formed. *)
   - inverts_type.
     eapply wfFS_stbind_update; eauto.
     inverts_kind; auto.

   (* All store bindings mentioned by frame stack are still live. *)
   - eapply liveS_stvalue_update.
     + inverts_type.
       remember (TRgn p) as r.

       have (SubsT nil sp e (TWrite r) KEffect)
        by  (eapply EqSym in H0; eauto).

       have (LiveE fs (TWrite r))
        by  (eapply liveE_subsT; eauto).

       eapply liveE_fpriv_in with (e := TWrite r).
       * subst r. snorm.
       * subst r. snorm.
     + auto.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H0; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
    - eapply EqSym in H0.
      eapply subsT_subsVisibleT; eauto.
       eauto. eauto.

   (* Resulting configuration is well typed. *)
   - eapply TcExp
      with (t1 := t1)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym; eauto.
     + inverts_type.
       eapply TxVal.
        inverts HH. rip.
     + eauto.
 }
Qed.


Require Import Coq.Lists.List.
Require Import BinNums ZArith Lia.

Import ListNotations.

From compcert Require Import Integers Floats.

Require Import Types.

Inductive value : Type :=
| Vunit
| Vbool: bool -> value
| Vint: intsize -> signedness -> int -> value
| Vint64: signedness -> int64 -> value
| Vfloat32: float32 -> value
| Vfloat64: float -> value
(* | Vmutarr: positive -> value *)
| Varr: positive -> list value -> value.

(* Definition Vzero64 := Vint64 Unsigned Int64.zero.
   Definition Vone64 := Vint64 Unsigned Int64.one.

   Definition Vzero32 := Vint I32 Unsigned Int.zero.
   Definition Vone32 := Vint I32 Unsigned Int.one.

   Definition Vzero16 := Vint I16 Unsigned Int.zero.
   Definition Vone16 := Vint I16 Unsigned Int.one.

   Definition Vzero8 := Vint I8 Unsigned Int.zero.
   Definition Vone8 := Vint I8 Unsigned Int.one. *)

Definition Vtrue := Vbool true.
Definition Vfalse := Vbool false.

Definition shrink (v: value) :=
  match v with
  | Vint I8 Unsigned n => Vint I8 Unsigned (Int.zero_ext 8 n)
  | Vint I8 Signed n => Vint I8 Signed (Int.sign_ext 8 n)
  | Vint I16 Unsigned n => Vint I16 Unsigned (Int.zero_ext 16 n)
  | Vint I16 Signed n => Vint I16 Signed (Int.sign_ext 16 n)
  | _ => v
  end.

Theorem shrink_shrink:
  forall v, shrink v = shrink (shrink v).
Proof.
  intro. destruct v; try reflexivity.
  destruct i, s; try reflexivity; simpl;
    ((rewrite Int.sign_ext_idem by lia) || (rewrite Int.zero_ext_idem by lia));
    reflexivity.
Qed.