Require Import Coq.Program.Equality.
Require Import Coq.Sets.Ensembles.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.FSets.FSetWeakList.
Require Import Coq.MSets.MSetWeakList.
Require Import Coq.FSets.FSetFacts.
Require Import Coq.FSets.FMapAVL.
Require Import Coq.FSets.FMapFacts.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Mult.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Minus.
Require Import Coq.Init.Peano.
Require Import Ascii.
Require Import Keys.
Require Import Tactics.
Require Export Nameless2.
Require Export TypeLemmas.

Inductive Expr :=
  | Const     : nat -> Expr
  | Bool      : bool -> Expr
  | Var       : Name -> Expr
  | Mu        : Name -> Name -> Expr -> Expr -> Expr
  | Lambda    : Name -> Expr -> Expr
  | Mu_App    : Expr -> Expr -> Expr
  | Rgn_App   : Expr -> rgn2_in_exp -> Expr
  | Eff_App   : Expr -> Expr -> Expr
  | Pair_Par  : Expr -> Expr -> Expr -> Expr -> Expr
  | Cond      : Expr -> Expr -> Expr -> Expr
  | Ref       : rgn2_in_exp -> Expr -> Expr
  | DeRef     : rgn2_in_exp -> Expr -> Expr
  | Assign    : rgn2_in_exp -> Expr -> Expr -> Expr
  | Plus      : Expr -> Expr -> Expr
  | Minus     : Expr -> Expr -> Expr
  | Times     : Expr -> Expr -> Expr
  | Eq        : Expr -> Expr -> Expr
  | AllocAbs  : rgn2_in_exp -> Expr
  | ReadAbs   : rgn2_in_exp -> Expr
  | WriteAbs  : rgn2_in_exp -> Expr
  | ReadConc  : Expr -> Expr
  | WriteConc : Expr -> Expr
  | Concat    : Expr -> Expr -> Expr
  | Top       : Expr
  | Empty     : Expr.
Notation "'(|' a ',' b '|)" := (Pair_Par a b) (at level 60).

Module E := FMapAVL.Make (AsciiVars).
Module Raw := E.Raw.

(* Computed Actions; for effect specification *)
Inductive ComputedAction : Set :=
| CA_ReadConc  : Region -> nat -> ComputedAction
| CA_WriteConc : Region -> nat -> ComputedAction
| CA_AllocAbs : Region -> ComputedAction
| CA_ReadAbs  : Region -> ComputedAction
| CA_WriteAbs : Region -> ComputedAction.

Definition Theta := option (Ensemble ComputedAction).
Definition Theta_Top : Theta := None.
Definition Theta_Empty : Theta := Some empty_set.

Definition Union_Theta (theta1 theta2 : Theta) :=
  match theta1,theta2 with
    | None, _ => None
    | _, None => None
    | Some acts1, Some acts2 => Some (set_union acts1 acts2)
  end.

Inductive Val :=
  | Loc  : rgn2_in_exp -> nat -> Val
  | Num  : nat -> Val
  | Bit  : bool -> Val
  | Cls  : (Raw.t Val * R.t Region * Expr) -> Val
  | Eff  : Theta -> Val
  | Unit : Val
  | Pair : nat * nat -> Val.

(* Dynamic Actions; for operational semantics *)
Inductive DynamicAction : Type :=
| DA_Alloc : Region -> nat -> Val -> DynamicAction
| DA_Read  : Region -> nat -> Val -> DynamicAction
| DA_Write : Region -> nat -> Val -> DynamicAction.

Definition Trace := list DynamicAction.
Inductive Phi :=
 | Phi_Nil : Phi
 | Phi_Elem : DynamicAction -> Phi
 | Phi_Par : Phi -> Phi -> Phi
 | Phi_Seq : Phi -> Phi -> Phi.

Fixpoint phi_as_list (phi : Phi) : Trace :=
  match phi with
    | Phi_Nil => nil
    | Phi_Elem a => a::nil
    | Phi_Seq phi1 phi2 =>  (phi_as_list phi1) ++ (phi_as_list phi2)
    | Phi_Par phi1 phi2 =>  (phi_as_list phi1) ++ (phi_as_list phi2)
  end.

Inductive ReadOnlyPhi : Phi -> Prop :=
 | Phi_RO_Nil  : ReadOnlyPhi (Phi_Nil)
 | Phi_RO_Elem : forall r a v, ReadOnlyPhi (Phi_Elem (DA_Read r a v))
 | Phi_RO_Seq  : forall phi1 phi2, ReadOnlyPhi phi1 -> ReadOnlyPhi phi2 -> ReadOnlyPhi (Phi_Seq phi1 phi2)
 | Phi_RO_Par  : forall phi1 phi2, ReadOnlyPhi phi1 -> ReadOnlyPhi phi2 -> ReadOnlyPhi (Phi_Par phi1 phi2).

Definition Empty_Dynamic_Action := Empty_set DynamicAction.
Definition Singleton_Dynamic_Action (e : DynamicAction) :=  Singleton DynamicAction e.
Definition Union_Dynamic_Action (a b : Ensemble DynamicAction) :=  Union DynamicAction a b.

(* Static Actions; for type-and-effect system *)
Definition StaticAction := StaticAction2.
Definition Epsilon := Epsilon2.
Definition SA_Alloc:= SA2_Alloc.
Definition SA_Read:= SA2_Read.
Definition SA_Write:= SA2_Write.

Definition Empty_Static_Action := Empty_set StaticAction.
Definition Singleton_Static_Action (e : StaticAction) :=  Singleton StaticAction e.
Definition Union_Static_Action (a b : Ensemble StaticAction) :=  Union StaticAction a b.

Inductive ReadOnlyStatic : Epsilon -> Prop :=
 | Static_RO_Empty     : ReadOnlyStatic (Empty_Static_Action)
 | Static_RO_Singleton : forall r, ReadOnlyStatic (Singleton_Static_Action (SA_Read r))
 | Static_RO_Union     : forall eps1 eps2, ReadOnlyStatic eps1 -> ReadOnlyStatic eps2 -> ReadOnlyStatic (Union_Static_Action eps1 eps2).

Inductive DA_in_Phi : DynamicAction -> Phi -> Prop :=
| DAP_Trace : forall da, DA_in_Phi da (Phi_Elem da)
| DAP_Par   : forall da phi1 phi2, DA_in_Phi da phi1 \/ DA_in_Phi da phi2 -> DA_in_Phi da (Phi_Par phi1 phi2)
| DAP_Seq   : forall da phi1 phi2, DA_in_Phi da phi1 \/ DA_in_Phi da phi2 -> DA_in_Phi da (Phi_Seq phi1 phi2).

Inductive DA_in_Theta : DynamicAction -> Theta -> Prop :=
| DAT_Top :
    forall da, DA_in_Theta da None
| DAT_Alloc_Abs :
    forall s l v acts,
      set_elem acts (CA_AllocAbs s) ->
      DA_in_Theta (DA_Alloc s l v) (Some acts)
| DAT_Read_Abs :
    forall s l v acts,
      set_elem acts (CA_ReadAbs s) ->
      DA_in_Theta (DA_Read s l v) (Some acts)
| DAT_Read_Conc :
    forall s l v acts,
      set_elem acts (CA_ReadConc s l) ->
      DA_in_Theta (DA_Read s l v) (Some acts)
| DAT_Write_Abs :
    forall s l v acts,
      set_elem acts (CA_WriteAbs s) ->
      DA_in_Theta (DA_Write s l v) (Some acts)
| DAT_Write_Conc :
    forall s l v acts,
      set_elem acts (CA_WriteConc s l) ->
      DA_in_Theta (DA_Write s l v) (Some acts)
| DAT_intror :
    forall da a acts, DA_in_Theta da (Some acts) ->
                      DA_in_Theta da (Some (set_union acts a))
| DAT_introl :
    forall da a acts, DA_in_Theta da (Some acts) ->
                      DA_in_Theta da (Some (set_union a acts)).

Inductive Disjoint_Dynamic : DynamicAction -> DynamicAction -> Prop :=
| DD_Alloc_Alloc  : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Alloc r1 l1 v1) (DA_Alloc r2 l2 v2)
| DD_Alloc_Read   : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Alloc r1 l1 v1) (DA_Read r2 l2 v2)
| DD_Alloc_Write  : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Alloc r1 l1 v1) (DA_Write r2 l2 v2)
| DD_Read_Alloc   : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Read r1 l1 v1) (DA_Alloc r2 l2 v2)
| DD_Read_Read   : forall r1 l1 r2 l2 v1 v2, Disjoint_Dynamic (DA_Read r1 l1 v1) (DA_Read r2 l2 v2)
| DD_Read_Write   : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Read r1 l1 v1) (DA_Write r2 l2 v2)
| DD_Write_Alloc  : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Write r2 l2 v2) (DA_Alloc r1 l1 v1)
| DD_Write_Write  : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Write r2 l2 v2) (DA_Write r1 l1 v1)
| DD_Write_Read   : forall r1 l1 r2 l2 v1 v2, (r1, l1) <> (r2, l2) -> Disjoint_Dynamic (DA_Write r2 l2 v2) (DA_Read r1 l1 v1).

Inductive Disjoint_Traces : Trace -> Trace -> Prop :=
| D_Trace_DA     : forall phi1 phi2,
                     (forall p1 p2, In p1 phi1 -> In p2 phi2 -> Disjoint_Dynamic p1 p2) ->
                     Disjoint_Traces phi1 phi2.

Axiom Disjoint_Traces_Sym :
  forall t1 t2, Disjoint_Traces t1 t2 -> Disjoint_Traces t2 t1.

Inductive Disjoint_Static : StaticAction2 -> StaticAction2 -> Prop :=
 | DS_Read_Read   : forall r1 r2, Disjoint_Static (SA2_Read r1) (SA2_Read r2)
 | DS_Write_Write : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA2_Write r1) (SA2_Write r2)
 | DS_Read_Write  : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA2_Read r1) (SA2_Write r2)
 | DS_Write_Read  : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA2_Write r1) (SA2_Read r2).

Inductive Disjoint_Computed_Actions : ComputedAction -> ComputedAction -> Prop :=
| D_CA_ReadConc_ReadConc    : forall r1 l1 r2 l2, Disjoint_Computed_Actions (CA_ReadConc r1 l1) (CA_ReadConc r2 l2)
| D_CA_ReadConc_Alloc       : forall r1 l1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_ReadConc r1 l1) (CA_AllocAbs r2)
| D_CA_ReadConc_ReadAbs     : forall r1 l1 r2, Disjoint_Computed_Actions (CA_ReadConc r1 l1) (CA_ReadAbs r2)
| D_CA_ReadConc_WriteAbs    : forall r1 l1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_ReadConc r1 l1) (CA_WriteAbs r2)
| D_CA_ReadConc_WriteConc   : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_ReadConc r1 l1) (CA_WriteConc r2 l2)
 | D_CA_ReadAbs_ReadConc    : forall r1 r2 l2, Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_ReadConc r2 l2)
 | D_CA_ReadAbs_ReadAbs     : forall r1 r2, Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_ReadAbs r2)
 | D_CA_ReadAbs_Alloc       : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_AllocAbs r2)
 | D_CA_ReadAbs_WriteAbs    : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_WriteAbs r2)
 | D_CA_ReadAbs_WriteConc   : forall r1 r2 l2, r1 <> r2 -> Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_WriteConc r2 l2)
 | D_CA_WriteConc_WriteConc : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_WriteConc r1 l1) (CA_WriteConc r2 l2)
 | D_CA_WriteAbs_WriteConc  : forall r1 r2 l2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_WriteConc r2 l2)
 | D_CA_WriteAbs_WriteAbs   : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_WriteAbs r2)
 | D_CA_WriteAbs_Alloc      : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_AllocAbs r2)
 | D_CA_WriteConc_ReadConc  : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_WriteConc r1 l1) (CA_ReadConc r2 l2)
 | D_CA_WriteConc_ReadAbs   : forall r1 l1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteConc r1 l1) (CA_ReadAbs r2)
 | D_CA_WriteConc_Alloc     : forall r1 l1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteConc r1 l1) (CA_AllocAbs r2)
 | D_CA_WriteAbs_ReadConc   : forall r1 r2 l2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_ReadConc r2 l2)
 | D_CA_WriteAbs_ReadAbs    : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_ReadAbs r2)
 | D_CA_Alloc_Alloc         : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_AllocAbs r1) (CA_AllocAbs r2)
 | D_CA_Alloc_ReadAbs       : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_AllocAbs r1) (CA_ReadAbs r2)
 | D_CA_Alloc_ReadConc      : forall r1 r2 l2, r1 <> r2 -> Disjoint_Computed_Actions (CA_AllocAbs r1) (CA_ReadConc r2 l2)
 | D_CA_Alloc_WriteAbs      : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_AllocAbs r1) (CA_WriteAbs r2)
 | D_CA_Alloc_WriteConc     : forall r1 r2 l2, r1 <> r2 -> Disjoint_Computed_Actions (CA_AllocAbs r1) (CA_WriteConc r2 l2).

Inductive Disjoint_Sets_Computed_Actions : Ensemble (ComputedAction) -> Ensemble (ComputedAction) -> Prop :=
 | D_Set_CA   : forall theta1 theta2,
                  (forall d1 d2,
                     set_elem theta1 d1 ->
                     set_elem theta2 d2 ->
                     Disjoint_Computed_Actions d1 d2) ->
                 Disjoint_Sets_Computed_Actions theta1 theta2.

Inductive Disjointness : Theta -> Theta -> Prop :=
 | D_Theta  : forall theta1 theta2, Disjoint_Sets_Computed_Actions theta1 theta2 -> Disjointness (Some theta1) (Some theta2).

Axiom Disjointness_Sym : forall theta1 theta2, Disjointness theta1 theta2 -> Disjointness theta2 theta1.

Inductive Conflict_Dynamic_Actions : DynamicAction -> DynamicAction -> Prop :=
| D_Read_Write : forall r l v (a : DynamicAction),
                   Conflict_Dynamic_Actions ( DA_Read r l v) (DA_Write r l v)
| D_Write_Write : forall r l v (a : DynamicAction),
              Conflict_Dynamic_Actions ( DA_Write r l v) (DA_Write r l v).

Inductive Conflict_Traces : Trace -> Trace -> Prop :=
 | C_Trace_DA : forall p1 p2 phi1 phi2,
                  In p1 phi1 ->
                  In p2 phi2 ->
                  Conflict_Dynamic_Actions p1 p2 ->
                  Conflict_Traces phi1 phi2.

Inductive Conflict_Computed_Actions : ComputedAction -> ComputedAction -> Prop :=
| C_WriteConc_ReadConc : forall r l, Conflict_Computed_Actions  (CA_ReadConc r l) ( CA_WriteConc r l)
| C_WriteAbs_ReadConc : forall r l, Conflict_Computed_Actions  (CA_ReadConc r l) ( CA_WriteAbs r)                                                  | C_ReadAbs_WriteConc : forall r l, Conflict_Computed_Actions  (CA_ReadAbs r) ( CA_WriteConc r l)
| C_WriteAbs_ReadAbs : forall r, Conflict_Computed_Actions  (CA_ReadAbs r) ( CA_WriteAbs r)
| C_WriteAbs_WriteAbs : forall r, Conflict_Computed_Actions  (CA_WriteAbs r) ( CA_WriteAbs r)
| C_WriteAbs_WriteConc : forall r l, Conflict_Computed_Actions  (CA_WriteAbs r) ( CA_WriteConc r l)
| C_WriteConc_WriteAbs : forall r l, Conflict_Computed_Actions (CA_WriteConc r l) (CA_WriteAbs r)
| C_WriteConc_WriteConc : forall r l, Conflict_Computed_Actions (CA_WriteConc r l) (CA_WriteConc r l)
| C_WriteConc_ReadAbs : forall r l, Conflict_Computed_Actions (CA_WriteConc r l) (CA_ReadAbs r).

Inductive Conflict_Sets_Computed_Actions : Ensemble (ComputedAction) -> Ensemble (ComputedAction) -> Prop :=
 | C_Set_CA  : forall theta1 theta2,
                 forall d1 d2,
                    set_elem theta1 d1 ->
                    set_elem theta2 d2 -> Conflict_Computed_Actions d1 d2 ->
                 Conflict_Sets_Computed_Actions theta1 theta2.

Inductive Conflictness : Theta -> Theta -> Prop :=
 | C_TopL : forall theta2, Conflictness None theta2
 | C_TopR : forall theta1, Conflictness theta1 None
 | C_Theta  : forall theta1 theta2,
                 Conflict_Sets_Computed_Actions theta1 theta2 -> Conflictness (Some theta1) (Some theta2).

Axiom Conflictness_Sym : forall theta1 theta2, ~ Conflictness theta1 theta2 -> ~ Conflictness theta2 theta1.

Module H := FMapAVL.Make (RegionVars).

Definition Env := Raw.t Val.
Definition Rho := R.t nat.
Definition Heap  := H.t Val.
Definition V_Key := Raw.key.
Definition R_Key := R.key.
Definition H_Key := H.key.

Definition find_E (k: V_Key) (m: Env) : option Val := Raw.find (elt := Val) k m.
Definition update_E (p: Name * Val) (m : Env) := Raw.add (fst p) (snd p) m.
Definition update_rec_E (f : ascii * Val) (x: ascii * Val) m :=
  let m' := Raw.add (fst f) (snd f) m
  in Raw.add (fst x) (snd x) m'.

Definition find_R (k: rgn2_in_exp) (m: Rho) : option Region :=
 match k with
  | Rgn2_Const fv bv n => Some n
  | Rgn2_FVar c bv n => R.find (elt := Region) n m
  | Rgn2_BVar c fv n => None
 end.

Definition update_R (p: Name * Region) (m : Rho) := R.add (fst p) (snd p) m.

Definition find_H (k: H_Key) (m: Heap) : option Val := H.find k m.
Definition update_H (p: H_Key * Val) (m: Heap) := H.add (fst p) (snd p) m.

Definition Functional_Map_Union (heap1 heap2 : Heap) : Heap :=
  let f := fun (k : nat * nat) (v : Val) (m : Heap) => H.add k v m
  in H.fold f heap1 heap2.

Inductive merge : Heap -> Heap -> Heap -> Prop :=
| mergeL : forall heap1 heap2, merge heap1 heap2 (Functional_Map_Union heap1 heap2)
| mergeR : forall heap1 heap2, merge heap1 heap2 (Functional_Map_Union heap2 heap1).

Reserved Notation "phi '⊑' theta" (at level 50, left associativity).
Inductive Phi_Theta_Soundness : Phi -> Theta -> Prop :=
| PTS_Nil :
    forall theta, (Phi_Nil) ⊑ theta
| PTS_Elem : forall da theta,
      DA_in_Theta da theta ->
      (Phi_Elem da) ⊑ theta
| PTS_Seq : forall phi1 phi2 theta,
      phi1 ⊑ theta ->
      phi2 ⊑ theta ->
      Phi_Seq phi1 phi2 ⊑ theta
| PTS_Par : forall phi1 phi2 theta,
      phi1 ⊑ theta ->
      phi2 ⊑ theta ->
      Phi_Par phi1 phi2 ⊑ theta
where "phi '⊑' theta" := (Phi_Theta_Soundness phi theta) : type_scope.

Reserved Notation "phi_heap '===>' phi'_heap'" (at level 50, left associativity).
Inductive Phi_Heap_Step : (Phi * Heap) -> (Phi * Heap) -> Prop :=
| PHS_Alloc  :  forall r l v heap,
                 (Phi_Elem (DA_Alloc r l v), heap) ===> (Phi_Nil, update_H ((r,l), v) heap)
| PHS_Read   :  forall r l v heap,
                 find_H (r,l) heap = Some v ->
                 (Phi_Elem (DA_Read r l v), heap) ===> (Phi_Nil, heap)
| PHS_Write  :  forall r l v heap,
                  H.In (r,l) heap ->
                  (Phi_Elem (DA_Write r l v), heap) ===> (Phi_Nil, update_H ((r, l), v) heap)
| PHS_Seq_1  : forall phi1 phi1' heap heap',
                 (phi1, heap) ===> (phi1', heap') ->
                 forall phi2, (Phi_Seq phi1 phi2, heap) ===> (Phi_Seq phi1' phi2, heap')
| PHS_Seq_2  : forall phi2 phi2' heap heap',
                 (phi2, heap) ===> (phi2', heap') ->
                 (Phi_Seq Phi_Nil phi2, heap) ===> (Phi_Seq Phi_Nil phi2', heap')
| PHS_Seq_3  : forall heap,
                 (Phi_Seq Phi_Nil Phi_Nil, heap) ===> (Phi_Nil, heap)
| PHS_Par_1  : forall phi1 phi1' heap heap',
                 (phi1, heap) ===> (phi1', heap') ->
                 forall phi2, (Phi_Par phi1 phi2, heap) ===> (Phi_Par phi1' phi2, heap')
| PHS_Par_2  : forall phi2 phi2' heap heap',
                 (phi2, heap) ===> (phi2', heap') ->
                 forall phi1, (Phi_Par phi1 phi2, heap) ===> (Phi_Par phi1 phi2', heap')
| PHS_Par_3  : forall heap,
                 (Phi_Par Phi_Nil Phi_Nil, heap) ===> (Phi_Nil, heap)
where "phi_heap '===>' phi'_heap'" := (Phi_Heap_Step phi_heap phi'_heap') : type_scope.

Module HMapP := FMapFacts.Facts H.

Lemma monotonic_heap_updates:
  forall phi heap phi' heap',
     (phi, heap) ===> (phi', heap') ->
     forall r l,
       H.In (r, l) heap ->
       H.In (r, l) heap'.
Proof.
  intros phi heap phi' heap' H.
  dependent induction H; intros.
  - destruct (RegionVars.eq_dec (r0, l0) (r, l)).
    + apply HMapP.add_in_iff. left. simpl. inversion e. intuition.
    + apply HMapP.add_neq_in_iff.
      * intro. apply n. unfold RegionVars.eq. intuition.
      * assumption.
  - assumption.
  - destruct (RegionVars.eq_dec (r0, l0) (r, l)).
     + apply HMapP.add_in_iff. left. simpl. inversion e. intuition.
    + apply HMapP.add_neq_in_iff.
      * intro. apply n. unfold RegionVars.eq. intuition.
      * assumption.
  - apply IHPhi_Heap_Step. assumption.
  - apply IHPhi_Heap_Step. assumption.
  - assumption.
  - apply IHPhi_Heap_Step. assumption.
  - apply IHPhi_Heap_Step. assumption.
  - assumption.
Qed.

Reserved Notation "phi_heap '=a=>*' phi'_heap'_n'" (at level 50, left associativity).
Inductive Phi_Heap_StepsAux : (Phi * Heap) -> (Phi * Heap * nat) -> Prop :=
| PHT_Refl : forall phi heap,
               (phi, heap) =a=>* (phi, heap, 0)
| PHT_Step : forall phi phi' heap heap',
               (phi, heap) ===> (phi', heap') ->
               (phi, heap) =a=>* (phi', heap', 1)
| PHT_Trans : forall phi phi' phi'' heap heap' heap'' n' n'',
               (phi, heap) =a=>* (phi', heap', n') ->
               (phi', heap') =a=>* (phi'', heap'', n'') ->
               (phi, heap) =a=>* (phi'', heap'', (1 + n' + n'')%nat)

where "phi_heap '=a=>*' phi'_heap'_n'" := (Phi_Heap_StepsAux phi_heap phi'_heap'_n') : type_scope.

Reserved Notation "phi_heap '==>*' phi'_heap'" (at level 50, left associativity).
Definition Phi_Heap_Steps phi_heap phi'_heap' :=
  exists n',
    match phi'_heap' with | (phi', heap') => phi_heap =a=>* (phi', heap', n') end.
Notation "phi_heap '==>*' phi'_heap'" := (Phi_Heap_Steps phi_heap phi'_heap') : type_scope.

Inductive Det_Trace : Phi -> Prop :=
| DET_Empty : Det_Trace (Phi_Nil)
| DET_Elem  : forall da, Det_Trace (Phi_Elem da)
| DET_Seq   : forall phi1 phi2, Det_Trace phi1 -> Det_Trace phi2 -> Det_Trace (Phi_Seq phi1 phi2)
| DET_Par   : forall phi1 phi2, Det_Trace phi1 ->
                                Det_Trace phi2 ->
                                not (Conflict_Traces (phi_as_list phi1) (phi_as_list phi2)) /\
                                Disjoint_Traces (phi_as_list phi1) (phi_as_list phi2) ->
                                Det_Trace (Phi_Par phi1 phi2).

Reserved Notation "e '⇓' n" (at level 50, left associativity).
Inductive BigStep   : (Heap * Env * Rho * Expr) -> (Heap * Val * Phi) -> Prop:=
  | BS_Nat_Cnt    : forall n env rho heap,
                        (heap, env, rho, Const n) ⇓ (heap, Num n, Phi_Nil)
  | BS_Boolean    : forall b env rho heap,
                        (heap, env, rho, Bool b) ⇓ (heap, Bit b, Phi_Nil)
  | BS_Val_Var    : forall x v env rho heap,
                        find_E x env = Some v -> (heap, env, rho, Var x) ⇓ (heap, v, Phi_Nil)
  | BS_Mu_Abs     : forall f x ec ee env rho (heap fheap : Heap),
                        (heap, env, rho, Mu f x ec ee) ⇓ (heap, Cls (env, rho, Mu f x ec ee), Phi_Nil)
  | BS_Lambda_Abs : forall x eb env rho heap,
                        (heap, env, rho, Lambda x eb) ⇓ (heap, Cls (env, rho, Lambda x eb), Phi_Nil)
  | BS_Mu_App     : forall f x ef ea ec' ee' v v'
                           (env env': Env) (rho rho' : Rho) (heap fheap aheap bheap : Heap) (facts aacts bacts : Phi),
                        (heap, env, rho, ef) ⇓ (fheap, Cls (env', rho', Mu f x ec' ee'), facts) ->
                        (fheap, env, rho, ea) ⇓ (aheap, v, aacts) ->
                        (aheap, update_rec_E (f, Cls (env', rho', Mu f x ec' ee')) (x, v) env', rho', ec') ⇓ (bheap, v', bacts) ->
                        (heap, env, rho,  Mu_App ef ea) ⇓ (bheap, v', Phi_Seq (Phi_Seq facts aacts) bacts)
  | BS_Rgn_App    : forall x er eb w v v'
                           (env env': Env) (rho rho' : Rho) (heap fheap aheap bheap : Heap) (facts aacts bacts : Phi),
                        (heap, env, rho, er) ⇓ (fheap, Cls (env', rho', Lambda x eb), facts) ->
                        find_R w rho = Some v' ->
                        (fheap, env', update_R (x, v') rho' , eb) ⇓ (bheap, v, bacts) ->
                        (heap, env, rho, Rgn_App er w) ⇓ (bheap, v, Phi_Seq facts bacts)
  | BS_Eff_App    : forall f x ef ea ec' ee' v v' (env env': Env) (rho rho' : Rho) heap (facts aacts bacts : Phi),
                        (heap, env, rho, ef) ⇓ (heap, Cls (env', rho', Mu f x ec' ee'), facts) ->
                        (heap, env, rho, ea) ⇓ (heap, v', aacts) ->
                        (*(heap, update_E (x, v') env', rho', ee') ⇓ (heap, v, bacts) ->*)
                        (heap, update_rec_E (f, Cls (env', rho', Mu f x ec' ee')) (x, v') env', rho', ee') ⇓ (heap, v, bacts) ->
                        (heap, env, rho, Eff_App ef ea) ⇓ (heap, v, Phi_Seq (Phi_Seq facts aacts) bacts)
  | BS_Pair_Par   : forall env rho ea1 ef1 ea2 ef2 v1 v2 theta1 theta2
                           (heap heap_mu1 heap_mu2 heap' : Heap) (acts_mu1 acts_mu2 acts_eff1 acts_eff2 : Phi),
                        (heap, env, rho, Eff_App ef1 ea1) ⇓ (heap, Eff theta1, acts_eff1) ->
                        (heap, env, rho, Eff_App ef2 ea2) ⇓ (heap, Eff theta2, acts_eff2) ->
                        ReadOnlyPhi acts_eff1 ->
                        ReadOnlyPhi acts_eff2 ->
                        Disjointness theta1 theta2 /\ not (Conflictness theta1 theta2) ->
                        (heap, env, rho, Mu_App ef1 ea1) ⇓ (heap_mu1, Num v1, acts_mu1) ->
                        (heap, env, rho, Mu_App ef2 ea2) ⇓ (heap_mu2, Num v2, acts_mu2) ->
                        acts_mu1 ⊑ theta1 ->
                        acts_mu2 ⊑ theta2 ->
                        (Phi_Par acts_mu1 acts_mu2, heap) ==>* (Phi_Nil, heap') ->
                        (heap, env, rho, Pair_Par ef1 ea1 ef2 ea2)
                           ⇓ (heap', Pair (v1, v2), Phi_Seq (Phi_Par acts_eff1 acts_eff2) (Phi_Par acts_mu1 acts_mu2))
  | BS_Cond_True  : forall e et ef env rho v (heap cheap theap : Heap) (cacts tacts : Phi),
                        (heap, env, rho, e) ⇓ (cheap, (Bit true), cacts) ->
                        (cheap, env, rho, et) ⇓ (theap, v, tacts) ->
                        (heap, env, rho, Cond e et ef) ⇓ (theap, v, Phi_Seq cacts tacts)
  | BS_Cond_False : forall e et ef env rho v (heap cheap fheap : Heap) (cacts facts : Phi),
                        (heap, env, rho, e) ⇓ (cheap, (Bit false), cacts) ->
                        (cheap, env, rho, ef) ⇓ (fheap, v, facts) ->
                        (heap, env, rho, Cond e et ef) ⇓ (fheap, v, Phi_Seq cacts facts)
  | BS_New_Ref     : forall e w r l v env rho  (heap heap' : Heap) vacts,
                        (heap, env, rho, e) ⇓ (heap', v, vacts) ->
                        find_R w rho = Some r ->
                        find_H (r, l) heap' = None ->
                        (heap, env, rho, Ref w e) ⇓ (update_H ((r, l), v) heap',
                                                     Loc (Rgn2_Const true false r) l,
                                                     Phi_Seq vacts (Phi_Elem (DA_Alloc r l v)))
  | BS_Get_Ref     : forall ea w r l v env rho (heap heap' : Heap) aacts,
                        (heap, env, rho, ea) ⇓ (heap', Loc w l, aacts) ->
                        find_R w rho = Some r ->
                        find_H (r, l) heap' = Some v ->
                        (heap, env, rho, DeRef w ea) ⇓ (heap', v, Phi_Seq aacts (Phi_Elem (DA_Read r l v)))
  | BS_Set_Ref     : forall ea ev w r l v env rho (heap heap' heap'' : Heap) (aacts vacts : Phi),
                        (heap, env, rho, ea) ⇓ (heap', Loc w l, aacts) ->
                        (heap', env, rho, ev) ⇓ (heap'', v, vacts) ->
                        find_R w rho = Some r ->
                        (heap, env, rho, Assign w ea ev) ⇓ (update_H ((r, l), v) heap'', Unit,
                                                            Phi_Seq (Phi_Seq aacts vacts) (Phi_Elem (DA_Write r l v)))
  | BS_Nat_Plus    : forall a b va vb env rho (heap lheap rheap : Heap) (lacts racts : Phi),
                        (heap, env, rho, a) ⇓ (lheap, Num va, lacts) ->
                        (lheap, env, rho, b) ⇓ (rheap, Num vb, racts) ->
                        (heap, env, rho, Plus a b) ⇓ (rheap, Num (va + vb), Phi_Seq lacts racts)
  | BS_Nat_Minus   : forall a b va vb env rho (heap lheap rheap : Heap) (lacts racts : Phi),
                        (heap, env, rho, a) ⇓ (lheap, Num va, lacts) ->
                        (lheap, env, rho, b) ⇓ (rheap, Num vb, racts) ->
                        (heap, env, rho, Minus a b) ⇓ (rheap, Num (va - vb), Phi_Seq lacts racts)
  | BS_Nat_Times   : forall a b va vb env rho (heap lheap rheap : Heap) (lacts racts : Phi),
                        (heap, env, rho, a) ⇓ (lheap, Num va, lacts) ->
                        (lheap, env, rho, b) ⇓ (rheap, Num vb, racts) ->
                        (heap, env, rho, Times a b) ⇓ (rheap, Num (va * vb), Phi_Seq lacts racts)
  | BS_Bool_Eq     : forall a b va vb env rho (heap lheap rheap : Heap) (lacts racts : Phi),
                        (heap, env, rho, a) ⇓ (lheap, Num va, lacts) ->
                        (lheap, env, rho, b) ⇓ (rheap, Num vb, racts) ->
                        (heap, env, rho, Eq a b) ⇓ (rheap, Bit (beq_nat va vb), Phi_Seq lacts racts)
  | BS_Alloc_Abs   : forall w r env rho heap,
                        find_R w rho = Some r ->
                        (heap, env, rho, AllocAbs w) ⇓ (heap, Eff (Some (singleton_set (CA_AllocAbs r))), Phi_Nil)
  | BS_Read_Abs    : forall w r env rho heap,
                        find_R w rho = Some r ->
                        (heap, env, rho, ReadAbs w) ⇓ (heap, Eff (Some (singleton_set (CA_ReadAbs r))), Phi_Nil)
  | BS_Write_Abs   : forall w r env rho heap,
                        find_R w rho = Some r ->
                        (heap, env, rho, WriteAbs w) ⇓ (heap, Eff (Some (singleton_set (CA_WriteAbs r))), Phi_Nil)
  | BS_Read_Conc   : forall ea r l env rho (heap heap' : Heap) aacts,
                        (heap, env, rho, ea) ⇓ (heap', Loc (Rgn2_Const true false r) l, aacts) ->
                        aacts = Phi_Nil->
                        (heap, env, rho, ReadConc ea) ⇓ (heap', Eff (Some (singleton_set (CA_ReadConc r l))), Phi_Nil)
  | BS_Write_Conc  : forall ea r l env rho (heap heap' : Heap) aacts,
                        (heap, env, rho, ea) ⇓ (heap', Loc (Rgn2_Const true false r) l, aacts) ->
                        aacts = Phi_Nil ->
                        (heap, env, rho, WriteConc ea) ⇓ (heap', Eff (Some (singleton_set (CA_WriteConc r l))), Phi_Nil)
  | BS_Eff_Concat  : forall a b env rho heap (effa effb : Theta) phia phib,
                        (heap, env, rho, a) ⇓ (heap, Eff effa, phia) ->
                        (heap, env, rho, b) ⇓ (heap, Eff effb, phib) ->
                        (heap, env, rho, Concat a b) ⇓ (heap, Eff (Union_Theta effa effb), Phi_Seq phia phib)
  | BS_Eff_Top     : forall env rho heap,
                        (heap, env, rho, Top) ⇓ (heap, Eff None, Phi_Nil)
  | BS_Eff_Empty   : forall  env rho heap,
                       (heap, env, rho, Empty) ⇓ (heap, Eff (Some empty_set), Phi_Nil)
where "e '⇓' n" := (BigStep e n) : type_scope.

Lemma bs_det : forall heap env rho exp heap1 val1 phi1 heap2 val2 phi2,
                 BigStep (heap, env, rho, exp) (heap1, val1, phi1) ->
                 BigStep (heap, env, rho, exp) (heap2, val2, phi2) ->
                 H.Equal heap1 heap2 /\ val1 = val2 /\ phi1 = phi2.
Admitted.

Tactic Notation "dynamic_cases" tactic (first) ident(c) :=
  first;
  [ Case_aux c "cnt n"
  | Case_aux c "bool b"
  | Case_aux c "var x"
  | Case_aux c "mu_abs"
  | Case_aux c "rgn_abs"
  | Case_aux c "mu_app"
  | Case_aux c "rgn_app"
  | Case_aux c "eff_app"
  | Case_aux c "par_pair"
  | Case_aux c "cond_true"
  | Case_aux c "cond_false"
  | Case_aux c "new_ref e"
  | Case_aux c "get_ref e"
  | Case_aux c "set_ref e1 e2"
  | Case_aux c "nat_plus x y"
  | Case_aux c "nat_minus x y"
  | Case_aux c "nat_times x y"
  | Case_aux c "bool_eq x y"
  | Case_aux c "alloc_abs"
  | Case_aux c "read_abs"
  | Case_aux c "write_abs"
  | Case_aux c "read_conc"
  | Case_aux c "write_conc"
  | Case_aux c "eff_concat"
  | Case_aux c "eff_top"
  | Case_aux c "eff_empty"
  (*| Case_aux c "mu_rec"*) ].

Definition tau := type2.

Module ST := FMapAVL.Make (RegionVars).
Definition Sigma : Type := ST.t tau.
Definition Gamma : Type := E.t tau.
Definition Omega : Type := Ensemble Name.

Definition find_T (k: V_Key) (m: Gamma) : option tau := E.find k m.
Definition update_T (p: V_Key * tau) m := E.add (fst p) (snd p) m.
Definition update_rec_T (f: ascii * tau) (x: ascii * tau) m :=
  let m' := E.add (fst f) (snd f) m
  in E.add (fst x) (snd x) m'.

Definition find_ST (k: ST.key) (m: Sigma) : option tau := ST.find k m.
Definition update_ST (p: ST.key * tau) m := ST.add (fst p) (snd p) m.

Notation "'∅'" := (Empty)  (at level 60).
Notation "'⊤'" := (Top) (at level 60).
Notation "a '⊕' b" := (Concat a b) (at level 60).

Inductive TcRgn : (Omega * rgn2_in_exp) -> Prop :=
  | TC_Rgn_Const : forall rgns s,
                      TcRgn (rgns, Rgn2_Const true false s)
  | TC_Rgn_Var   : forall rgns r,
                      set_elem rgns r ->
                      TcRgn (rgns, Rgn2_FVar true false r).

Reserved Notation "ec '◀' ee" (at level 50, left associativity).
Inductive BackTriangle2 : Expr -> Expr -> Prop :=
 | Num_Pure      : forall n eff,
                     (Const n) ◀ eff
 | Bool_Pure     : forall b eff,
                     (Bool b) ◀ eff
 | Var_Pure      : forall x eff,
                     (Var x) ◀ eff
 | Abs_Pure      : forall (f x: ascii) (ec ee: Expr),
                     (Mu f x ec ee) ◀ ∅
 | Abs_Rgn_Pure  : forall x eb,
                     Lambda x eb ◀ (∅)
 | App_F_Free    : forall (f x : ascii) (ec ee ea: Expr),
                     ((Mu f x ec ee) ◀ ∅) ->
                     (ea ◀ ∅) ->
                     (Mu_App (Mu f x ec ee) ea) ◀ ee ->
                     (Mu_App (Var f) ea) ◀ ee
 | App_Inner_Eff : forall (f x : ascii) (ec ee ea: Expr),
                     ((Mu f x ec ee) ◀ ∅) ->
                     (ea ◀ ∅) ->
                     (Mu_App (Mu f x ec ee) ea) ◀ ee
 | App_Capp_Eapp : forall (ef ea efff effa : Expr),
                     (ef ◀ efff) ->
                     (ea ◀ effa) ->
                     (Mu_App ef ea) ◀ (efff ⊕ (effa ⊕ (Eff_App ef ea)))
 | Rgn_App_Eff   : forall eb x w eff,
                     eb ◀ eff ->
                     (Rgn_App (Lambda x eb) w) ◀ eff
 | Cond_Cond     : forall (e et ef efft efff : Expr),
                     (e ◀ ∅ ) ->
                     (et ◀ efft) ->
                     (ef ◀ efff) ->
                     (Cond e et ef) ◀ (Cond e efft efff)
 | Ref_Alloc_Abs : forall (e eff : Expr) (w : rgn2_in_exp),
                     (e ◀ eff) ->
                     (Ref w e) ◀ (eff ⊕ AllocAbs w)
 | Ref_Read_Abs  : forall (e eff : Expr) (w : rgn2_in_exp),
                     (e ◀ eff) ->
                     (DeRef w e) ◀ (eff ⊕ (ReadAbs w))
 | Ref_Read_Conc : forall (e eff : Expr) (w : rgn2_in_exp),
                     (e ◀ eff) ->
                     (DeRef w e) ◀ (eff ⊕ (ReadConc e))
 | Ref_Write_Abs  : forall (e1 e2 eff1 eff2 : Expr) (w : rgn2_in_exp),
                      (e1 ◀ eff1) ->
                      (e2 ◀ eff2) ->
                      (Assign w e1 e2) ◀ (eff1 ⊕ (eff2 ⊕ (WriteAbs w)))
 | Ref_Write_Conc : forall (e1 e2 eff1 eff2 : Expr) (w : rgn2_in_exp),
                      (e1 ◀ eff1) ->
                      (e2 ◀ eff2) ->
                      (Assign w e1 e2) ◀ (eff1 ⊕ (eff2 ⊕ (WriteConc e1)))
 | Top_Approx     : forall e : Expr,
                      e ◀ Top
 | Times_Concat   : forall e1 e2 eff1 eff2,
                     (e1 ◀ eff1) ->
                     (e2 ◀ eff2) ->
                     (Times e1 e2) ◀ (eff1 ⊕ eff2)
 | Plus_Concat   : forall e1 e2 eff1 eff2,
                     (e1 ◀ eff1) ->
                     (e2 ◀ eff2) ->
                     (Plus e1 e2) ◀ (eff1 ⊕ eff2)
 | Eq_Concat      : forall e1 e2 eff1 eff2,
                     (e1 ◀ eff1) ->
                     (e2 ◀ eff2) ->
                     (Eq e1 e2) ◀ (eff1 ⊕ eff2)
  | Cond_Cond_2   : forall (e et ef eff : Expr),
                     (e ◀ ∅ ) ->
                     (et ◀ eff) ->
                     (ef ◀ eff) ->
                     (Cond e et ef) ◀ eff
where "ec '◀' ee" := (BackTriangle2 ec ee) : type_scope.

Reserved Notation "stty ';;' ctxt ';;' rgns '|-' ec '<<' ee" (at level 50, left associativity).
Inductive TcExp : (Sigma * Gamma * Omega * Expr * tau * Epsilon) -> Prop :=
  | TC_Nat_Cnt     : forall stty ctxt rgns n,
                        TcExp (stty, ctxt, rgns, Const n, Ty2_Natural, Empty_Static_Action)
  | TC_Boolean     : forall stty ctxt rgns b,
                        TcExp (stty, ctxt, rgns, Bool b, Ty2_Boolean, Empty_Static_Action)
  | TC_Val_Var     : forall stty ctxt rgns x ty,
                        find_T x ctxt = Some ty ->
                        TcExp (stty, ctxt, rgns, Var x, ty, Empty_Static_Action)
  | TC_Mu_Abs      : forall stty ctxt rgns f x ec ee tyx effc tyc effe,
                        BackTriangle (stty, update_rec_T (f, Ty2_Arrow tyx effc tyc effe Ty2_Effect) (x, tyx) ctxt, rgns, ec, ee) ->
                        (BackTriangle2 ec ee) ->
                        TcExp (stty, update_rec_T (f, Ty2_Arrow tyx effc tyc effe Ty2_Effect) (x, tyx) ctxt, rgns, ec, tyc, effc) ->
                        TcExp (stty, update_rec_T (f, Ty2_Arrow tyx effc tyc effe Ty2_Effect) (x, tyx) ctxt, rgns, ee, Ty2_Effect, effe) ->
                        TcExp (stty, ctxt, rgns, Mu f x ec ee, Ty2_Arrow tyx effc tyc effe Ty2_Effect, Empty_Static_Action)
  | TC_Rgn_Abs     : forall stty ctxt rgns x er effr tyr,
                        not_set_elem rgns x ->
                        lc_type tyr ->
                        lc_type_eps effr ->
                        TcExp (stty, ctxt, set_union rgns (singleton_set x), er, tyr, effr) ->
                        TcExp (stty, ctxt, rgns, Lambda x er, Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr),
                               Empty_Static_Action)
  | TC_Mu_App      : forall stty ctxt rgns ef ea tya effc tyc effe efff effa,
                        TcExp (stty, ctxt, rgns, ef, Ty2_Arrow tya effc tyc effe Ty2_Effect, efff) ->
                        TcExp (stty, ctxt, rgns, ea, tya, effa) ->
                        ReadOnlyStatic efff ->
                        TcExp (stty, ctxt, rgns, Mu_App ef ea, tyc, Union_Static_Action (Union_Static_Action efff effa) effc)
  | TC_Rgn_App      : forall stty ctxt rgns er w tyr effr efff,
                        TcExp (stty, ctxt, rgns, er, Ty2_ForallRgn effr tyr, efff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, Rgn_App er w, open (mk_rgn_type w) tyr,
                               Union_Static_Action efff (open_rgn_eff (mk_rgn_type w) effr))
  | TC_Eff_App     : forall stty ctxt rgns ef ea tya effc tyc effe efff effa,
                        TcExp (stty, ctxt, rgns, ef, Ty2_Arrow tya effc tyc effe Ty2_Effect, efff) ->
                        TcExp (stty, ctxt, rgns, ea, tya, effa) ->
                        TcExp (stty, ctxt, rgns, Eff_App ef ea, Ty2_Effect, Union_Static_Action (Union_Static_Action efff effa) effe)
  | TC_New_Ref     : forall stty ctxt rgns e t veff w s,
                        TcExp (stty, ctxt, rgns, e, t, veff) ->
                        w = Rgn2_Const true false s ->
                        TcExp (stty, ctxt, rgns, Ref w e, Ty2_Ref (mk_rgn_type w) t,
                               Union_Static_Action veff (Singleton_Static_Action (SA_Alloc(mk_rgn_type w))))
  | TC_Get_Ref     : forall stty ctxt rgns e t aeff w s,
                        w = Rgn2_Const true false s ->
                        TcExp (stty, ctxt, rgns, e, Ty2_Ref (mk_rgn_type w) t, aeff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, DeRef w e, t, Union_Static_Action aeff (Singleton_Static_Action (SA_Read  (mk_rgn_type w))))
  | TC_Set_Ref     : forall stty ctxt rgns ea ev t aeff veff w s,
                        w = Rgn2_Const true false s ->
                        TcExp (stty, ctxt, rgns, ea, Ty2_Ref (mk_rgn_type w) t, aeff) ->
                        TcExp (stty, ctxt, rgns, ev, t, veff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, Assign w ea ev, Ty2_Unit,
                               Union_Static_Action (Union_Static_Action aeff veff) (Singleton_Static_Action (SA_Write  (mk_rgn_type w))))
  | TC_Conditional : forall stty ctxt rgns b e1 e2 te eff eff1 eff2,
                        TcExp (stty, ctxt, rgns, b, Ty2_Boolean, eff) ->
                        TcExp (stty, ctxt, rgns, e1, te, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, te, eff2) ->
                        TcExp (stty, ctxt, rgns, Cond b e1 e2, te, Union_Static_Action eff (Union_Static_Action eff1 eff2))
  | TC_Nat_Plus    : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns,  e1, Ty2_Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Ty2_Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Plus e1 e2, Ty2_Natural, Union_Static_Action eff1 eff2)
  | TC_Nat_Minus  : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Ty2_Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Ty2_Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Minus e1 e2, Ty2_Natural, Union_Static_Action eff1 eff2)
  | TC_Nat_Times  : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Ty2_Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Ty2_Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Times e1 e2, Ty2_Natural, Union_Static_Action eff1 eff2)
  | TC_Bool_Eq     : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Ty2_Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Ty2_Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Eq e1 e2, Ty2_Boolean, Union_Static_Action eff1 eff2)
  | TC_Alloc_Abs  : forall stty ctxt rgns r,
                        TcExp (stty, ctxt, rgns, AllocAbs r, Ty2_Effect, Empty_Static_Action)
  | TC_Read_Abs   : forall stty ctxt rgns r,
                        TcExp (stty, ctxt, rgns, ReadAbs r, Ty2_Effect, Empty_Static_Action)
  | TC_Read_Conc  : forall stty ctxt rgns e r t aeff,
                        TcExp (stty, ctxt, rgns, e, Ty2_Ref (Rgn2_Const true true r) t, aeff) ->
                        TcExp (stty, ctxt, rgns, ReadConc e, Ty2_Effect, aeff)
  | TC_Write_Abs  : forall stty ctxt rgns r,
                       TcExp (stty, ctxt, rgns, WriteAbs r, Ty2_Effect, Empty_Static_Action)
  | TC_Write_Conc : forall stty ctxt rgns e r t aeff,
                       TcExp (stty, ctxt, rgns, e,  Ty2_Ref (Rgn2_Const true true r) t, aeff) ->
                       TcExp (stty, ctxt, rgns, WriteConc e, Ty2_Effect, aeff)
  | TC_Eff_Concat : forall stty ctxt rgns a b eff1 eff2,
                       TcExp (stty, ctxt, rgns, a, Ty2_Effect, eff1) ->
                       TcExp (stty, ctxt, rgns, b, Ty2_Effect, eff2) ->
                       TcExp (stty, ctxt, rgns, Concat a b, Ty2_Effect, Union_Static_Action eff1 eff2)
  | TC_Eff_Top    : forall stty ctxt rgns,
                       TcExp (stty, ctxt, rgns, Top, Ty2_Effect, Empty_Static_Action)
  | TC_Eff_Empty  : forall stty ctxt rgns,
                      TcExp (stty, ctxt, rgns, Empty, Ty2_Effect, Empty_Static_Action)

with BackTriangle : Sigma * Gamma * Omega * Expr * Expr -> Prop :=
  | TC_Num_Pure     : forall stty ctxt rgns (n : nat),
                          TcExp (stty, ctxt, rgns, Const n, Ty2_Natural, Empty_Static_Action) ->
                          BackTriangle (stty, ctxt, rgns, (Const n), ∅)
  | TC_Bool_Pure    : forall stty ctxt rgns (b : bool),
                          TcExp (stty, ctxt, rgns, Bool b, Ty2_Boolean, Empty_Static_Action) ->
                          BackTriangle (stty, ctxt, rgns, Bool b, ∅)
  | TC_Var_Pure     : forall stty ctxt rgns ty (x : ascii),
                          TcExp (stty, ctxt, rgns, Var x, ty, Empty_Static_Action) ->
                          BackTriangle (stty, ctxt, rgns, Var x, ∅)
  | TC_Abs_Pure     : forall stty ctxt rgns (f x: ascii) (ec ee: Expr),
                          BackTriangle (stty, ctxt, rgns, Mu f x ec ee, ∅)
  | TC_App_Conc     : forall  stty ctxt rgns (ef ea efff effa : Expr) ty_ef ty_ea  static_ef static_ea,
                          TcExp (stty, ctxt, rgns, ef, ty_ef, static_ef) ->
                          TcExp (stty, ctxt, rgns, ea, ty_ea, static_ea) ->
                          BackTriangle (stty, ctxt, rgns, ef, efff) ->
                          BackTriangle (stty, ctxt, rgns, ea, effa) ->
                          ReadOnlyStatic static_ef ->
                          BackTriangle (stty, ctxt, rgns, Mu_App ef ea, efff ⊕ (effa ⊕ (Eff_App ef ea)))
  | TC_Cond_Cond    : forall stty ctxt rgns (e et ef effe efft efff : Expr) ty_e ty_et ty_ef static_e static_et static_ef,
                          TcExp (stty, ctxt, rgns, e, ty_e, static_e) ->
                          TcExp (stty, ctxt, rgns, et, ty_et, static_et) ->
                          TcExp (stty, ctxt, rgns, ef, ty_ef, static_ef) ->
                          ReadOnlyStatic static_e ->
                          BackTriangle (stty, ctxt, rgns, e, ∅) ->
                          BackTriangle (stty, ctxt, rgns, et, efft) ->
                          BackTriangle (stty, ctxt, rgns, ef, efff) ->
                          BackTriangle (stty, ctxt, rgns, Cond e et ef, Cond e efft efff)
  | TC_Ref_Alloc_Abs : forall stty ctxt rgns (e eff : Expr) (w : rgn2_in_exp) ty_e static_e,
                          TcExp (stty, ctxt, rgns, e, ty_e, static_e) ->
                          BackTriangle (stty, ctxt, rgns, e, eff) ->
                          BackTriangle (stty, ctxt, rgns, Ref w e, eff ⊕ AllocAbs w)
  | TC_Ref_Read_Abs  : forall stty ctxt rgns (e eff : Expr) (w : rgn2_in_exp) ty_e static_e,
                          TcExp (stty, ctxt, rgns, e, ty_e, static_e) ->
                          BackTriangle (stty, ctxt, rgns, e, eff) ->
                          BackTriangle (stty, ctxt, rgns, DeRef w e, eff ⊕ (ReadAbs w))
  | TC_Ref_Read_Conc : forall stty ctxt rgns (e eff : Expr) (r : Region) ty_e static_e,
                          TcExp (stty, ctxt, rgns, e, ty_e, static_e) ->
                          BackTriangle (stty, ctxt, rgns, e, ∅) ->
                          BackTriangle (stty, ctxt, rgns, DeRef (Rgn2_Const true false r) e, ReadConc e)
  | TC_Ref_Write_Abs : forall stty ctxt rgns (e1 e2 eff2 : Expr) (w : rgn2_in_exp)  ty_e1 static_e1  ty_e2 static_e2,
                          TcExp (stty, ctxt, rgns, e1, ty_e1, static_e1) ->
                          TcExp (stty, ctxt, rgns, e2, ty_e2, static_e2) ->
                          BackTriangle (stty, ctxt, rgns, e1, ∅) ->
                          BackTriangle (stty, ctxt, rgns, e2, eff2) ->
                          BackTriangle (stty, ctxt, rgns, Assign w e1 e2, eff2 ⊕ (WriteAbs w))
  | TC_Ref_Write_Conc: forall stty ctxt rgns (e1 e2 eff2 : Expr) (r : Region)  ty_e1 static_e1  ty_e2 static_e2,
                          TcExp (stty, ctxt, rgns, e1, ty_e1, static_e1) ->
                          TcExp (stty, ctxt, rgns, e2, ty_e2, static_e2) ->
                          BackTriangle (stty, ctxt, rgns, e1, ∅) ->
                          BackTriangle (stty, ctxt, rgns, e2, eff2) ->
                          BackTriangle (stty, ctxt, rgns, Assign (Rgn2_Const true false r) e1 e2, eff2 ⊕ (WriteConc e1))
  | TC_Top_Approx    : forall stty ctxt rgns (e : Expr) ty_e static_e,
                          TcExp (stty, ctxt, rgns, e, ty_e, static_e) ->
                          BackTriangle (stty, ctxt, rgns, e, Top)
where "stty ';;' ctxt ';;' rgns '|-' ec '<<' ee" := (BackTriangle (stty, ctxt, rgns, ec, ee)) : type_scope.

Scheme tc_exp__xind := Induction for TcExp Sort Prop
  with bt__xind := Induction for BackTriangle Sort Prop.
Combined Scheme tc_exp__bt__xind from tc_exp__xind, bt__xind.

Inductive TcVal : (Sigma * Val * tau) -> Prop :=
  | TC_Num     : forall stty n,
                   TcVal (stty, Num n, Ty2_Natural)
  | TC_Bit     : forall stty b,
                   TcVal (stty, Bit b, Ty2_Boolean)
  | TC_Loc     : forall stty s l ty,
                   ST.find (s, l) stty = Some ty ->
                   TcVal (stty, Loc (Rgn2_Const true false s) l, Ty2_Ref (Rgn2_Const true true s) ty)
  | TC_Cls     : forall stty env rho e rgns ctxt t,
                   TcRho (rho, rgns) ->
                   TcEnv (stty, rho, env, ctxt) ->
                   TcExp (stty, ctxt, rgns, e, t, Empty_Static_Action) ->
                   TcVal (stty, Cls (env, rho, e), subst_rho rho t)
  | TC_Unit     : forall stty, TcVal (stty, Unit, Ty2_Unit)
  | TC_Eff      : forall stty e, TcVal (stty, Eff e, Ty2_Effect)

with TcEnv : (Sigma * Rho * Env * Gamma) -> Prop :=
  | TC_Env : forall stty rho env ctxt,
               E.Raw.bst env ->
               (forall x v,
                  (find_E x env = Some v ->
                   exists t, find_T x ctxt = Some t)) ->
               (forall x t,
                  (find_T x ctxt = Some t ->
                   exists v, find_E x env = Some v)) ->
               (forall x v t,
                  find_E x env = Some v ->
                  find_T x ctxt = Some t ->
                  TcVal (stty, v, subst_rho rho t)) ->
               TcEnv (stty, rho, env, ctxt)

with TcRho : (Rho * Omega) -> Prop :=
  | TC_Rho : forall rho rgns,
               (forall r,
                  (R.find r rho <> None -> set_elem rgns r)) ->
               (forall r,
                  set_elem rgns r ->
                  R.find r rho <> None) ->
                (forall stty r v t,
                  R.find r rho <> None ->
                  set_elem rgns r ->
                  TcVal (stty, v, subst_rho rho t)) ->
                (forall t x,
                   not_set_elem rgns x -> x # t) ->
                (forall stty v r u t,
                   not_set_elem rgns r ->
                   TcVal (stty, v, subst_rho rho (subst_in_type r u t))) ->
               TcRho (rho, rgns).

Definition find_type_ext_stores_def  :=
   forall stty stty' l (t' : tau),
      ST.find l stty = Some t' ->
      ST.find l stty' = Some t' ->
      ST.find l stty =  ST.find l stty'.

Lemma find_type_ext_stores: find_type_ext_stores_def.
Proof.
  intros stty stty' l t' H1 H2.
  rewrite <- H1 in H2.
  symmetry in H2.
  assumption.
Qed.

Scheme tc_val__xind := Induction for TcVal Sort Prop
                       with tc_env__xind := Induction for TcEnv Sort Prop
                       with tc_rho__xind := Induction for TcRho Sort Prop.
Combined Scheme tc_val__tc_env__xind from tc_val__xind, tc_env__xind, tc_rho__xind.

Lemma ext_stores__exp__bt__aux:
  (forall p, TcExp p ->
             match p with (stty, ctxt, rgns, e, t, eff) =>
               forall stty',
                 (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t') ->
                 TcExp (stty', ctxt, rgns, e, t, eff)
             end)
    /\
  (forall p, BackTriangle p ->
             match p with (stty, ctxt, rgns, ec, ee) =>
               forall stty',
                 (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t') ->
                 BackTriangle (stty', ctxt, rgns, ec, ee)
             end).
Proof.
  apply tc_exp__bt__xind;
 try (econstructor); eauto.
Qed.

Lemma ext_stores__exp:
   forall stty stty',
     (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t') ->
     (forall ctxt rgns e t eff, TcExp (stty, ctxt, rgns, e, t, eff) -> TcExp (stty', ctxt, rgns, e, t, eff)).
Proof.
  intros.
  apply (match ext_stores__exp__bt__aux with conj F _ => F (stty, ctxt, rgns, e, t, eff) end); auto.
Qed.

Lemma ext_stores__bt:
   forall stty stty',
     (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t') ->
     (forall ctxt rgns ec ee, BackTriangle (stty, ctxt, rgns, ec, ee) -> BackTriangle (stty', ctxt, rgns, ec, ee)).
Proof.
  intros.
  apply (match ext_stores__exp__bt__aux with conj _ F => F (stty, ctxt, rgns, ec, ee) end); auto.
Qed.

Definition get_store_typing_val {A B:Type} (p : Sigma * A * B) : Sigma
  := fst (fst p).

Definition get_store_typing_env {A B C:Type} (p : Sigma * A * B * C) : Sigma
  := fst (fst (fst p)).

Definition mk_TcVal_ext_store_ty (p : Sigma * Val * tau) (stty' : Sigma)
  := TcVal (stty', snd (fst p), snd p).

Definition mk_TcEnv_ext_store_ty (p : Sigma * Rho * Env * Gamma) (stty' : Sigma)
  := TcEnv (stty', snd (fst (fst p)), snd (fst p), snd p).

Lemma ext_stores__val_env__aux:
   forall stty stty',
     (forall l t', find_ST l stty = Some t' -> find_ST l stty' = Some t') ->
     (forall p,
        TcVal p -> get_store_typing_val p = stty -> mk_TcVal_ext_store_ty p stty') /\
     (forall p,
        TcEnv p -> get_store_typing_env p = stty -> mk_TcEnv_ext_store_ty p stty') /\
     (forall p,
        TcRho p -> TcRho p) .
Proof.
  intros stty stty' HWeak.
  apply tc_val__tc_env__xind; intro stty''; intros;
  try constructor; try assumption ;
  unfold mk_TcVal_ext_store_ty, mk_TcEnv_ext_store_ty, get_store_typing_val, get_store_typing_env in *; simpl in *;
  try assumption.
  - subst. now apply HWeak.
  - eapply ext_stores__exp in t2.
    + intuition; econstructor; eauto.
    + subst; exact HWeak.
  - intuition.  eapply H; eassumption.
Qed.

Lemma ext_stores__val:
   forall stty stty',
     (forall l t', find_ST l stty = Some t' -> find_ST l stty' = Some t') ->
     (forall v t, TcVal (stty, v, t) -> TcVal (stty', v, t)).
Proof.
  intros stty stty' HWeak v t H. pose HWeak.
  apply ext_stores__val_env__aux in e. destruct e as [HTc  HEnv].
  inversion H; subst; try econstructor; eauto.
  - eapply ext_stores__exp in H5.
    + eapply HEnv in H4. cbv in H4. exact H4. cbv. reflexivity.
    + exact HWeak.
  - eapply ext_stores__exp in H5. eassumption. exact HWeak.
  (*- apply HTc in H4; [unfold mk_TcVal_ext_store_ty in H4; simpl in H4; assumption | reflexivity]. *)
Qed.

Lemma ext_stores__env:
   forall stty stty',
     (forall l t', find_ST l stty = Some t' -> find_ST l stty' = Some t') ->
     (forall rho env ctxt, TcEnv (stty, rho, env, ctxt) -> TcEnv (stty', rho, env, ctxt)).
Proof.
  intros stty stty' HWeak rho env ctxt H. pose HWeak.
  apply ext_stores__val_env__aux in e. destruct e as [HTc  HEnv].
  unfold mk_TcEnv_ext_store_ty in HEnv. apply HEnv in H.
  - now simpl in H.
  - now cbv.
Qed.


Require Import List Omega.

Require Import coinduction.
Require Import copy.
Require Import datatypes.
Require Import dither.
Require Import halting_defs.
Require Import join.
Require Import Ndiv2oo.
Require Import shift.
Require Import shift_maxsource.
Require Import streams_vs_lists.
Require Import witness.

(* Second half of the proof:
   supposing that Witness does not halt leads to absurd
*)

Lemma witness_loops_absurd:
      ~halt witness (gamma witness) -> False.
intro. generalize H.
unfold halt; intro.
elim H0; clear H0.
exists (pair Bs (Cons one (Cons one Bs))).
unfold witness at 1.

(* First decomposition *)

apply join_stop with
      (pair Bs (app_ls (ones (S (gamma witness)))
                       (Cons B (app_ls (ones (S (gamma witness))) Bs))))
      7.

(* Copy machine *)

apply Copy_stops.

(* Second decomposition *)

apply join_stop with (pair Bs (Cons one (Cons one Bs)))
                     (max_source HM 0 + 8).

(* HM machine *)

change 7 with (7+0) at 2.
change 8 with (7+1). rewrite (Nat.add_comm 7 1).
rewrite Nat.add_assoc. rewrite (Nat.add_comm (max_source HM 0 + 1) 7).
apply shift_preserves_stop. apply HM_decides_loop.
assumption.
clear H.

(* Dither machine *)

rewrite max_source_HM_witness.
change 9 with (8+1). rewrite Nat.add_assoc.
rewrite <- Nat.add_assoc. change (1+1) with 2.
change (max_source HM 0 + 8) with (0 + (max_source HM 0 + 8)) at 2.
rewrite (Nat.add_comm 0 (max_source HM 0 + 8)).
apply shift_preserves_stop. apply Dither_stops.

(* join condition: 1st check
*)

clear H; unfold not, Dither. simpl; intros.

assert (i <= (max_source HM 0)+7).
apply shift_maxsource. assumption.
omega.

(* 2nd check
*)

clear H; unfold not, Dither. simpl; intros.

assert (i >= 7 \/ In i (proj_target
       ((max_source HM 0 + 8 + 0, one, max_source HM 0 + 8 + 1, R)
          :: (max_source HM 0 + 8 + 1, B, max_source HM 0 + 8 + 0, L)
             :: (max_source HM 0 + 8 + 1, one, max_source HM 0 + 8 + 2, L)
                :: nil))).
apply app_shift with HM. assumption.
clear H; simpl in H1. omega.
Qed.


Set Implicit Arguments.

Require Import AutoSep.
Require Import ExampleADT.
Import ExampleADT.ExampleADT.
Require Import RepInv.

Require Import Cell SimpleCell Seq ArraySeq FiniteSet ListSet.

Definition rep_inv p adtvalue : HProp :=
  match adtvalue with
    | Cell v => cell v p
    | Arr ws => arr ws p
    | FSet s => lset s p
  end.

Module ExampleRepInv <: RepInv ExampleADT.

  Definition RepInv := W -> ADTValue -> HProp.

  Definition rep_inv := rep_inv.

  Lemma rep_inv_ptr : forall p a, rep_inv p a ===> p =?> 1 * any.
    destruct a; simpl.
    eapply Himp_trans; [ apply cell_fwd | sepLemma ]; apply any_easy.
    eapply Himp_trans; [ apply arr_fwd | sepLemma ]; apply any_easy.
    eapply Himp_trans; [ apply lset_fwd | sepLemma ]; apply any_easy.
  Qed.

End ExampleRepInv.


Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import infrastructure_props.
Require Import Program.Tactics.
Require Import Program.Equality.

(* This file implements and proves libraries for domination analysis. *)

(* A signature for a worklist of Kildall. *)
Module Type PNODE_SET.

  Variable t: Type.
  Variable add: positive -> t -> t.
  Variable pick: t -> option (positive * t).
  Variable initial: PTree.t (list positive) -> t.

  Variable In: positive -> t -> Prop.
  Hypothesis add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Hypothesis pick_none:
    forall s n, pick s = None -> ~In n s.
  Hypothesis pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Hypothesis initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).

End PNODE_SET.

Require Import FSets.
Require Import FSetAVL.
Require Import Ordered.
Module PositiveSet := FSetAVL.Make(OrderedPositive).
Module PositiveSetFacts := FSetFacts.Facts(PositiveSet).

(* A worklist that picks the maximal node. *)
Module PNodeSetMax <: PNODE_SET.
  Definition t := PositiveSet.t.
  Definition add (n: positive) (s: t) : t := PositiveSet.add n s.
  Definition pick (s: t) :=
    match PositiveSet.max_elt s with
    | Some n => Some(n, PositiveSet.remove n s)
    | None => None
    end.
  Definition initial (successors: PTree.t (list positive)) :=
    PTree.fold (fun s pc scs => PositiveSet.add pc s) successors PositiveSet.empty.
  Definition In := PositiveSet.In.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof.
    intros. exact (PositiveSetFacts.add_iff s n n').
  Qed.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PositiveSet.max_elt s); intros.
    congruence.
    apply PositiveSet.max_elt_3. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PositiveSet.max_elt s); intros.
    inversion H0; clear H0; subst.
    split; intros.
    destruct (peq n n'). auto. right. apply PositiveSet.remove_2; assumption.
    elim H0; intro. subst n'. apply PositiveSet.max_elt_1. auto.
    apply PositiveSet.remove_3 with n; assumption.
    congruence.
  Qed.

  Lemma initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n s, succ ? n = Some s -> In n set).
    (* extensionality *)
    intros. rewrite <- H in H1. eauto.
    (* base case *)
    intros. rewrite PTree.gempty in H. congruence.
    (* inductive case *)
    intros. rewrite PTree.gsspec in H2. apply add_spec.
    destruct (peq n k). auto. eauto.
  Qed.

  Lemma pick_in:
    forall s n s', pick s = Some(n, s') -> In n s.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
    uniq_result.
    apply PositiveSet.max_elt_1. auto.
  Qed.

  Lemma pick_notin:
    forall s n s', pick s = Some(n, s') -> ~ In n s'.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
    uniq_result.
    apply PositiveSet.remove_1. auto.
  Qed.

  Lemma pick_max:
    forall s n s', pick s = Some(n, s') ->
      PositiveSet.max_elt s = Some n.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
  Qed.

  Lemma pick_remove:
    forall s n s', pick s = Some(n, s') -> s' = PositiveSet.remove n s.
  Proof.
    intros until s'; unfold pick.
    caseEq (PositiveSet.max_elt s); intros; try congruence.
  Qed.

  Lemma initial_spec':
    forall successors n,
    In n (initial successors) ->
    exists s, successors ? n = Some s.
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n, In n set -> exists s, succ ? n = Some s).
    (* extensionality *)
    intros. rewrite <- H. eauto.
    (* base case *)
    intros. apply PositiveSet.empty_1 in H. tauto.
    (* inductive case *)
    intros. rewrite PTree.gsspec. apply add_spec in H2.
    destruct (peq n k); eauto.
      destruct H2 as [H2 | H2]; subst.
        congruence.
        eauto.
  Qed.

End PNodeSetMax.

(* A worklist that picks the minimal node. *)
Module PNodeSetMin <: PNODE_SET.
  Definition t := PositiveSet.t.
  Definition add (n: positive) (s: t) : t := PositiveSet.add n s.
  Definition pick (s: t) :=
    match PositiveSet.min_elt s with
    | Some n => Some(n, PositiveSet.remove n s)
    | None => None
    end.
  Definition initial (successors: PTree.t (list positive)) :=
    PTree.fold (fun s pc scs => PositiveSet.add pc s) successors PositiveSet.empty.
  Definition In := PositiveSet.In.

  Lemma add_spec:
    forall n n' s, In n' (add n s) <-> n = n' \/ In n' s.
  Proof.
    intros. exact (PositiveSetFacts.add_iff s n n').
  Qed.

  Lemma pick_none:
    forall s n, pick s = None -> ~In n s.
  Proof.
    intros until n; unfold pick. caseEq (PositiveSet.min_elt s); intros.
    congruence.
    apply PositiveSet.min_elt_3. auto.
  Qed.

  Lemma pick_some:
    forall s n s', pick s = Some(n, s') ->
    forall n', In n' s <-> n = n' \/ In n' s'.
  Proof.
    intros until s'; unfold pick. caseEq (PositiveSet.min_elt s); intros.
    inversion H0; clear H0; subst.
    split; intros.
    destruct (peq n n'). auto. right. apply PositiveSet.remove_2; assumption.
    elim H0; intro. subst n'. apply PositiveSet.min_elt_1. auto.
    apply PositiveSet.remove_3 with n; assumption.
    congruence.
  Qed.

  Lemma initial_spec:
    forall successors n s,
    successors ? n = Some s -> In n (initial successors).
  Proof.
    intros successors.
    apply PTree_Properties.fold_rec with
      (P := fun succ set =>
              forall n s, succ ? n = Some s -> In n set).
    (* extensionality *)
    intros. rewrite <- H in H1. eauto.
    (* base case *)
    intros. rewrite PTree.gempty in H. congruence.
    (* inductive case *)
    intros. rewrite PTree.gsspec in H2. apply add_spec.
    destruct (peq n k). auto. eauto.
  Qed.
End PNodeSetMin.

Import AtomSet.
Require Import Sorted.
Require Import ListSet.

(* A signature of merging two sorted lists by preserving orders. *)
Module Type MERGE.

  Variable Pcmp: positive -> positive -> Prop.
  Variable merge : list positive -> list positive -> list positive * bool.
  Hypothesis merge_cmp_cons: forall p ps (Hlt: Forall (Pcmp p) ps),
    merge ps (p :: ps) = (ps, false).
  Hypothesis merge_spec: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed)),
    sublist rl Xsdms /\ sublist rl Ysdms /\
    (changed = false <-> rl = Xsdms).
  Hypothesis merge_commut: forall Xsdms Ysdms rl changed rl' changed'
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hmerge': merge Ysdms Xsdms = (rl', changed')),
    rl = rl'.
  Hypothesis merge_refl: forall Xsdms, merge Xsdms Xsdms = (Xsdms, false).

  Hypothesis merge_inter: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms),
    set_eq (set_inter positive_eq_dec Xsdms Ysdms) (rev rl).

End MERGE.

Ltac uniq_result' :=
match goal with
| H: Eq = (_ ?= _)%positive Eq |- _ =>
    symmetry in H; apply Pcompare_Eq_eq in H; subst
| H: (_ ?= _)%positive Eq = Eq |- _ =>
    apply Pcompare_Eq_eq in H; subst
| H: nil = _ ++ _ |- _ =>
    symmetry in H; apply app_eq_nil in H; destruct H; subst
| H: _ ++ _ = _ |- _ =>
    apply app_eq_nil in H; destruct H; subst
| H: _::_ = nil |- _ => inv H
| H: nil = _::_ |- _ => inv H
| _ => uniq_result
end.

Require Import CpdtTactics.

Ltac fill_holes_in_ctx :=
let fill e H :=
  match goal with
  | H1: _ = e |- _ => rewrite <- H1 in H
  | H1: e = _ |- _ => rewrite H1 in H
  end
in
repeat match goal with
| H: match ?e with
     | Some _ => _
     | None => _
     end |- _ => fill e H
| H: match ?e with
     | inl _ => _
     | inr _ => _
     end |- _ => fill e H
| H: match ?e with
     | (_,_) => _
     end = _ |- _ => fill e H
| H: _ = match ?e with
     | (_,_) => _
     end |- _ => fill e H
end.

Ltac destruct_let :=
match goal with
| _:context [match ?e with
             | (_, _) => _
             end] |- _ => remember e as R; destruct R
| |- context [match ?e with
              | (_, _) => _
              end] => remember e as R; destruct R
end.

(* Merging two lists sorted by less-than. *)
Module MergeLt <: MERGE.

  Definition Pcmp := Plt.

  Program Fixpoint merge_aux (l1 l2: list positive) (acc:list positive * bool)
    {measure (length l1 + length l2)%nat}
    : (list positive * bool) :=
  let '(rl, changed) := acc in
  match l1, l2 with
  | p1::l1', p2::l2' =>
      match (Pcompare p1 p2 Eq) with
      | Eq => merge_aux l1' l2' (p1::rl, changed)
      | Lt => merge_aux l1' l2 (rl, true)
      | Gt => merge_aux l1 l2' (rl, changed)
      end
  | nil, _ => acc
  | _::_, nil => (rl, true)
  end.
  Next Obligation.
    simpl. omega.
  Qed.
  Next Obligation.
    simpl. omega.
  Qed.

  Definition merge_aux_spec_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 rl2 changed2
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    exists rl3, rl2 = rl3 ++ rl1 /\
                sublist (List.rev rl3) Xsdms /\
                sublist (List.rev rl3) Ysdms /\
                (changed2 = false -> List.rev rl3 = Xsdms) /\
                (List.rev rl3 = Xsdms -> changed2 = changed1) /\
                (changed1 = true -> changed2 = true).

  Ltac fold_merge_aux :=
  match goal with
  | |- context [merge_aux_func (existT _ ?arg1 (existT _ ?arg2 ?arg3))] =>
         fold (merge_aux arg1 arg2 arg3)
  end.

  Ltac unfold_merge_aux :=
  match goal with
  | |- appcontext [merge_aux ?arg] =>
     unfold merge_aux; unfold merge_aux_func;
     Program.Wf.WfExtensionality.unfold_sub merge_aux arg; simpl;
     repeat Program.Wf.fold_sub merge_aux_func;
     repeat fold_merge_aux
  end.

  Lemma merge_aux_spec_aux: forall n, merge_aux_spec_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_spec_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge. uniq_result.
      exists nil. simpl. repeat (split; try solve [auto | constructor]).

      compute in Hmerge. uniq_result.
      exists nil. simpl. repeat (split; try solve [auto | constructor]).

      compute in Hmerge. uniq_result.
      exists nil. simpl.
      repeat (split; try solve [auto | constructor | congruence]).

      uniq_result.
      revert Hmerge. unfold_merge_aux.
      remember (Pos.compare_cont Xd Yd Eq) as Cmp.
      intro.
      destruct Cmp; subst.
        apply Hrec with (y:=(length Xsdms + length Ysdms)%nat) in Hmerge;
          try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists (rl3++[Xd]). simpl_env.
        rewrite rev_app_distr. simpl.
        uniq_result'.
        repeat (split; try solve [auto | constructor; auto]).
          symmetry in HeqCmp.
          apply Pcompare_Eq_eq in HeqCmp. subst Yd. constructor. auto.
          intro J. apply J4 in J. f_equal; auto.
          intro J. inv J. auto.

        apply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat) in Hmerge;
           try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists rl3.
        repeat (split; try solve [auto | constructor; auto]).
          intro J. assert (J':=J). apply J4 in J. apply J5 in J. congruence.
          intro J. rewrite J in J2. apply sublist_cons_false in J2. tauto.

        apply Hrec with (y:=(S (length Xsdms) + length Ysdms)%nat) in Hmerge;
           try solve [simpl; omega].
        destruct Hmerge as [rl3 [J1 [J2 [J3 [J4 [J5 J6]]]]]].
        subst.
        exists rl3.
        repeat (split; try solve [auto | constructor; auto]).
  Qed.

  Lemma merge_aux_spec: forall Xsdms Ysdms rl1 changed1 rl2 changed2
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    exists rl3, rl2 = rl3 ++ rl1 /\
                sublist (List.rev rl3) Xsdms /\
                sublist (List.rev rl3) Ysdms /\
                (changed2 = false -> (List.rev rl3) = Xsdms) /\
                (List.rev rl3 = Xsdms -> changed2 = changed1) /\
                (changed1 = true -> changed2 = true).
  Proof.
    intros.
    assert (J:=@merge_aux_spec_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_spec_prop in J.
    auto.
  Qed.

  Definition merge (l1 l2: list positive) : (list positive * bool) :=
    let '(rl, changed) := merge_aux l1 l2 (nil, false) in
    (rev rl, changed).

  Lemma merge_spec: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed)),
    sublist rl Xsdms /\ sublist rl Ysdms /\
    (changed = false <-> rl = Xsdms).
  Proof.
    unfold merge.
    intros.
    destruct_let.
    fill_holes_in_ctx. uniq_result.
    symmetry in HeqR.
    apply merge_aux_spec in HeqR.
    destruct_conjs.
    subst. simpl_env.
    crush.
  Qed.

  Definition merge_aux_commut_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 changed1' rl2 changed2 rl2' changed2'
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2))
    (Hmerge': merge_aux Ysdms Xsdms (rl1, changed1') = (rl2', changed2')),
    rl2 = rl2'.

  Lemma merge_aux_commut_aux: forall n, merge_aux_commut_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_commut_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge, Hmerge'. uniq_result. auto.
      compute in Hmerge, Hmerge'. uniq_result. auto.
      compute in Hmerge, Hmerge'. uniq_result. auto.

      revert Hmerge. unfold_merge_aux. intro.
      revert Hmerge'. unfold_merge_aux. intro.
      remember (Pos.compare_cont Xd Yd Eq) as Cmp.
      destruct Cmp; subst.
        uniq_result'.
        symmetry in HeqCmp. apply Pcompare_Eq_eq in HeqCmp. subst Yd.
        rewrite Pcompare_refl in Hmerge'.
        eapply Hrec with (y:=(length Xsdms + length Ysdms)%nat);
          try solve [eauto | simpl; omega].

        symmetry in HeqCmp. rewrite ZC4 in HeqCmp.
        apply CompOpp_iff in HeqCmp. simpl in HeqCmp.
        rewrite HeqCmp in Hmerge'.

        eapply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat);
          eauto; simpl; omega.

        symmetry in HeqCmp. rewrite ZC4 in HeqCmp.
        apply CompOpp_iff in HeqCmp. simpl in HeqCmp.
        rewrite HeqCmp in Hmerge'.

        eapply Hrec with (y:=(S (length Xsdms) + length Ysdms)%nat);
          eauto; simpl; omega.
  Qed.

  Lemma merge_commut: forall Xsdms Ysdms rl changed rl' changed'
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hmerge': merge Ysdms Xsdms = (rl', changed')),
    rl = rl'.
  Proof.
    unfold merge.
    intros. destruct_let. destruct_let. uniq_result.
    assert (J:=@merge_aux_commut_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_commut_prop in J.
    f_equal. eauto.
  Qed.

  Definition merge_aux_refl_prop (n:nat) := forall Xsdms
    (Hlen: (length Xsdms + length Xsdms = n)%nat) rl changed,
    merge_aux Xsdms Xsdms (rl, changed) = (rev Xsdms++rl, changed).

  Lemma merge_aux_refl_aux: forall n, merge_aux_refl_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_refl_prop; intros.
    destruct Xsdms as [|Xd Xsdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute. auto.

      unfold_merge_aux.
      simpl_env.
      rewrite Pcompare_refl.
      erewrite Hrec with (y:=(length Xsdms + length Xsdms)%nat);
        try solve [eauto | simpl; omega].
  Qed.

  Lemma merge_refl: forall Xsdms, merge Xsdms Xsdms = (Xsdms, false).
  Proof.
    unfold merge. intros. destruct_let.
    assert (J:=@merge_aux_refl_aux (length Xsdms + length Xsdms)).
    unfold merge_aux_refl_prop in J.
    rewrite J in HeqR; auto.
    uniq_result. simpl_env.
    rewrite rev_involutive. auto.
  Qed.

  Lemma merge_cmp_cons: forall p ps (Hlt: Forall (Plt p) ps),
    merge ps (p :: ps) = (ps, false).
  Proof.
    destruct 1; intros.
      compute. auto.

      unfold merge. unfold_merge_aux.
      replace (Pos.compare_cont x p Eq) with Gt.
      erewrite merge_aux_refl_aux; eauto.
      simpl_env.
      rewrite rev_involutive. auto.

      symmetry. apply Pcompare_eq_Gt. apply Pos.lt_gt. auto.
  Qed.

  Definition merge_aux_inter_prop (n:nat) := forall Xsdms Ysdms
    (Hlen: (length Xsdms + length Ysdms = n)%nat)
    rl1 changed1 rl2 changed2
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms)
    (Hmerge: merge_aux Xsdms Ysdms (rl1, changed1) = (rl2, changed2)),
    set_eq (set_union positive_eq_dec rl1
           (set_inter positive_eq_dec Xsdms Ysdms)) rl2.

  Lemma merge_aux_inter_aux: forall n, merge_aux_inter_prop n.
  Proof.
    intro n.
    elim n using (well_founded_induction lt_wf).
    intros x Hrec.
    unfold merge_aux_inter_prop; intros.
    destruct Xsdms as [|Xd Xsdms]; destruct Ysdms as [|Yd Ysdms];
      simpl in Hlen; try solve [contradict Hlen; simpl; omega].
      compute in Hmerge. uniq_result. simpl. auto with atomset.
      compute in Hmerge. uniq_result. simpl. auto with atomset.
      compute in Hmerge. uniq_result. simpl.
        apply set_eq_trans with (y:=set_union positive_eq_dec rl2 nil).
          apply set_eq_union; auto with atomset.
          apply set_union_empty_eq_empty2.

      inv Hsortx. inv Hsorty.
      revert Hmerge. unfold_merge_aux. intro.
      remember (Pos.compare_cont Xd Yd Eq) as Cmp.
      destruct Cmp; subst; symmetry in HeqCmp.
      Case "1".
        uniq_result'.
        destruct_if.
        SCase "1.1".
          clear HeqR.
          eapply Hrec with (y:=(length Xsdms + length Ysdms)%nat) in Hmerge;
            try solve [eauto | simpl; omega].
          (* (a :: Z) \/ (X /\ Y) = Z \/ (a :: (X /\ Y)) *)
          split; intros x Hin.
          SSCase "1.1.1".
            apply Hmerge.
            apply set_union_elim in Hin.
            apply set_union_intro.
            simpl.
            destruct Hin as [Hin | Hin]; auto.
            simpl in Hin.
            destruct Hin as [Hin | Hin]; subst; auto.
            apply set_inter_elim in Hin.
            destruct Hin as [Hin1 Hin2].
            simpl in Hin2.
            destruct Hin2 as [Hin2| Hin2]; auto.
            left. left. apply Pos.compare_eq in HeqCmp. subst Yd; auto.
            right. apply set_inter_intro; auto.

          SSCase "1.1.2".
            apply Hmerge in Hin.
            apply set_union_elim in Hin.
            apply set_union_intro.
            simpl.
            destruct Hin as [Hin | Hin].
            SSSCase "1.1.2.1".
              simpl in Hin.
              destruct Hin as [Hin | Hin]; subst; auto.

            SSSCase "1.1.2.2".
              apply set_inter_elim in Hin.
              destruct Hin as [Hin1 Hin2].
              right. right.
              apply set_inter_intro; simpl; auto.

        SCase "1.2".
          destruct_if. apply Pos.compare_eq in HeqCmp. congruence.

      Case "2".
        destruct_if.
        SCase "2.1".
          (* X < Y < Ysdms => ~ In X (Y::Ysdms) *)
          destruct_if.
          SSCase "2.1.1".
            rewrite Pcompare_refl in HeqCmp. congruence.
          SSCase "2.1.2".
            apply ZC2 in HeqCmp.
            rewrite Forall_lt__notin in H0; eauto using order_lt_order.
              congruence.

        SCase "2.2".
          clear HeqR.
          eapply Hrec with (y:=(length Xsdms + S (length Ysdms))%nat) in Hmerge;
            try solve [eauto | simpl; omega | constructor; auto].

      Case "3".
        eapply Hrec with (y:=(S (length Xsdms) + (length Ysdms))%nat) in Hmerge;
          try solve [eauto | simpl; omega | constructor; auto].
        destruct_if.
        SCase "3.1".
          (* X > Y, In X (Y::Ysdms) => In X Ysdms
             In X Ysdms => (X :: Xsdms) /\ Ysdms = X ++ (Xsdms /\ Ysdms)
             X > Y, Xsdms > X => ~ In Y Xsdms
             ~ In Y Xsdms => Xsdms /\ Ysdms = Xsdms /\ (Y :: Ysdms)
             so,
             rl1 \/ ((X :: Xsdms) /\ Ysdms) =
             rl1 \/ (X :: (Xsdms /\ Ysdms)) =
             rl1 \/ (X :: Xsdms /\ (Y :: Ysdms)) *)
          assert (set_mem positive_eq_dec Xd Ysdms = true) as XinYsdms.
            destruct_if; auto.
            rewrite Pcompare_refl in HeqCmp. congruence.
          clear HeqR.
          eapply set_eq_trans; eauto.
          apply set_union_eq_right.
          simpl_env.
          apply set_eq_trans with
            (y:=[Xd] ++
                set_inter positive_eq_dec Xsdms Ysdms).
          SSCase "1".
            apply set_eq_app; auto with atomset.
            assert (J1:=set_inter_union_distr_r positive_eq_dec [Yd] Ysdms Xsdms).
            eapply set_eq_trans; eauto.
            clear J1.
            assert (~ In Yd (Xsdms)) as Hnotin.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
              apply Forall_lt__notin; eauto using order_lt_order.
            rewrite_env (Yd::nil).
            rewrite set_inter_notin_r; auto.
            apply set_union_empty_eq_empty1.

          SSCase "2".
            assert (J1:=set_inter_prefix positive_eq_dec Xsdms Ysdms [Xd]).
            eapply set_eq_trans; eauto.
            clear J1.
            apply set_inter_drop_incl; auto.
              apply set_mem_correct1 in XinYsdms.
              apply in_incl; auto.

        SCase "3.2".
          (* ~ In X (Y::Ys) => ~ In X Ys
             ~ In X Ys => (X :: Xs) /\ Ys = Xs /\ Ys
             X > Y, Xs > X => ~ In Y Xs
             ~ In Y Xs => Xs /\ Ys = Xs /\ (Y :: Ys)
             so,
             rl1 \/ ((X :: Xs) /\ Ys) =
             rl1 \/ (Xs /\ Ys) =
             rl1 \/ (Xs /\ (Y :: Ys))
          *)
          eapply set_eq_trans; eauto.
          apply set_union_eq_right.
          simpl_env.
          apply set_eq_trans with
            (y:=set_inter positive_eq_dec Xsdms Ysdms).
          SSCase "1".
            rewrite_env (Yd::nil).
            apply set_inter_drop_notin_r.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
              apply Forall_lt__notin; eauto using order_lt_order.
          SSCase "2".
            apply set_eq_sym.
            rewrite_env (Xd::nil).
            apply set_inter_drop_notin_l.
              destruct_if.
              apply set_mem_complete1 with (Aeq_dec:=positive_eq_dec); auto.
  Qed.

  Lemma merge_inter: forall Xsdms Ysdms rl changed
    (Hmerge: merge Xsdms Ysdms = (rl, changed))
    (Hsortx: StronglySorted Plt Xsdms) (Hsorty: StronglySorted Plt Ysdms),
    set_eq (set_inter positive_eq_dec Xsdms Ysdms) (rev rl).
  Proof.
    unfold merge.
    intros. destruct_let. uniq_result.
    assert (J:=@merge_aux_inter_aux (length Xsdms + length Ysdms)).
    unfold merge_aux_inter_prop in J.
    symmetry in HeqR.
    apply_clear J in HeqR; auto.
    rewrite rev_involutive.
    simpl in HeqR.
    eapply set_eq_trans; eauto.
      apply set_eq_sym.
      apply set_union_empty_eq_empty1.
  Qed.

End MergeLt.

(* A signature of lattice used for computing dominators. *)
Module Type LATTICEELT.

  Variable t: Type.
  Variable eq: t -> t -> Prop.
  Hypothesis eq_refl: forall x, eq x x.
  Hypothesis eq_sym: forall x y, eq x y -> eq y x.
  Hypothesis eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
(*
  Variable beq: t -> t -> bool.
  Hypothesis beq_correct: forall x y, beq x y = true -> eq x y.
*)
  Variable bot: t.
  Variable lub: t -> t -> t * bool.
  Variable top: t.
  Variable ge: t -> t -> Prop.
  Hypothesis ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Hypothesis ge_refl: forall x, ge x x.

End LATTICEELT.

(* A signature of lattice maps used for computing dominators. *)
Module LATTICEELT_MAP (L: LATTICEELT).

Definition in_incr (in1 in2: PMap.t L.t) : Prop :=
  forall n, L.ge in2??n in1??n.

Lemma in_incr_refl:
  forall in1, in_incr in1 in1.
Proof.
  unfold in_incr; intros. apply L.ge_refl.
Qed.

Lemma in_incr_trans:
  forall in1 in2 in3, in_incr in1 in2 -> in_incr in2 in3 -> in_incr in1 in3.
Proof.
  unfold in_incr; intros. apply L.ge_trans with in2??n; auto.
Qed.

Definition eq bd (in1 in2: PMap.t L.t) : Prop :=
  forall n (Hin: In n bd), L.eq in2??n in1??n.

End LATTICEELT_MAP.

(* A lattice used for computing dominators, parameterized by a merging
   function. *)
Module Doms (MG:MERGE) <: LATTICEELT.

  Definition t := option (list positive).

  Definition eq (x y: t) := (x = y).
  Definition eq_refl: forall x, eq x x := (@refl_equal t).
  Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t).
  Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t).

  Definition bot : t := None.

  Definition lub (x y:t) : t * bool :=
  match x, y with
  | Some x', Some y' =>
     let '(r, changed) := (MG.merge x' y') in (Some r, changed)
  | _, None => (x, false)
  | None, _ => (y, true)
  end.

  Definition top : t := Some nil.

  Definition ge (x y:t) : Prop :=
  match x, y with
  | _, None => True
  | Some x', Some y' => sublist x' y'
  | _, _ => False
  end.

  Lemma ge_trans: forall x y z (Hxy: ge x y) (Hyz: ge y z), ge x z.
  Proof.
    unfold ge.
    destruct x as [x|]; destruct y as [y|]; destruct z as [z|];
      eauto using sublist_trans.
      tauto.
  Qed.

  Lemma ge_refl: forall x, ge x x.
  Proof.
    unfold ge.
    destruct x as [x|]; auto using sublist_refl.
  Qed.

  Lemma merge_cmp_cons: forall p ps (Hlt: Forall (MG.Pcmp p) ps),
    MG.merge ps (p :: ps) = (ps, false).
  Proof. apply MG.merge_cmp_cons. Qed.

  Definition transfer (n:positive) (input:t) : t :=
  match input with
  | None => None
  | Some ps => Some (n::ps)
  end.

  Lemma ge_lub_left': forall x y, ge (fst (lub x y)) x.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety.
      caseEq x; simpl; auto.
        intros Xsdms Hgetx.
        simpl.
        destruct_let.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        simpl. tauto.

      intros Hgety.
      caseEq x; simpl; auto with sublist.
  Qed.

  Lemma ge_lub_left: forall x y r changed (Hlub: lub x y = (r, changed)),
    ge r x.
  Proof.
    intros.
    replace r with (fst (lub x y)); try solve [rewrite Hlub; auto].
    apply ge_lub_left'.
  Qed.

  Lemma lub_commut: forall x y, fst (lub x y) = fst (lub y x).
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety.
      caseEq x; simpl; auto.
        intros Xsdms Hgetx.
        simpl.
        repeat destruct_let.
        symmetry in HeqR.
        eapply MG.merge_commut in HeqR; eauto.
        simpl. congruence.

      intros Hgety.
      caseEq x; simpl; auto.
  Qed.

  Lemma ge_lub_right': forall x y, ge (fst (lub x y)) y.
  Proof.
    intros.
    rewrite lub_commut.
    apply ge_lub_left'.
  Qed.

  Lemma ge_lub_right: forall x y r changed (Hlub: lub x y = (r, changed)),
    ge r y.
  Proof.
    intros.
    replace r with (fst (lub x y)); try solve [rewrite Hlub; auto].
    apply ge_lub_right'.
  Qed.

  Lemma lub_bot_inv: forall x y (Hlub: fst (lub x y) = bot),
    x = bot /\ y = bot.
  Proof.
    unfold bot.
    intros.
    destruct x; destruct y; inv Hlub; auto.
    destruct_let. simpl in *. congruence.
  Qed.

  Lemma lub_nonbot_spec': forall x y (Hnonbot: x <> bot \/ y <> bot),
    fst (lub x y) <> bot.
  Proof.
    intros.
    destruct x; destruct y; try tauto.
      simpl. unfold bot. destruct_let. simpl. congruence.
  Qed.

  Lemma Leq_nonbot_inv_r: forall x y (Hnonbot: y <> bot) (Heq: eq x y),
    x <> None.
  Proof.
    unfold eq. intros. subst. auto.
  Qed.

  Lemma Leq_nonbot_inv_l: forall x y (Hnonbot: x <> bot) (Heq: eq x y),
    y <> None.
  Proof.
    unfold eq. intros. subst. auto.
  Qed.

  Lemma transfer_nonbot: forall p dms (Hnonbot: dms <> bot),
    transfer p dms <> bot.
  Proof.
    unfold transfer, bot.
    intros.
    destruct dms; congruence.
  Qed.

  Lemma ge_Forall: forall P ox y (Hlt : Forall P y)
    (Hge: ge ox (Some y)),
    match ox with
    | Some x => Forall P x
    | _ => True
    end.
  Proof.
    intros.
    destruct ox as [x|]; tinv Hge.
    simpl in Hge. eauto with sublist.
  Qed.

  Lemma lub_bot_invl: forall x y changed
    (Hlub: lub x y = (bot, changed)),
    x = bot.
  Proof.
    intros. assert (J:=lub_bot_inv x y).
    rewrite Hlub in J. simpl in J. eapply J; eauto.
  Qed.

  Lemma lub_bot_invr: forall x y changed
    (Hlub: lub x y = (bot, changed)),
    y = bot.
  Proof.
    intros. assert (J:=lub_bot_inv x y).
    rewrite Hlub in J. simpl in J. eapply J; eauto.
  Qed.

  Lemma lub_nonbot_spec : forall (x y r : t) changed
    (Hnbot: x <> bot \/ y <> bot)
    (Hlub: lub x y = (r, changed)),
    r <> bot.
  Proof.
    intros.
    apply lub_nonbot_spec' in Hnbot.
    rewrite Hlub in Hnbot.
    simpl in Hnbot. auto.
  Qed.

  Lemma Lub_unchanged_rnonbot__lnonbot: forall x y r
    (Hnonbot : y <> None)
    (HeqR : (r, false) = lub x y),
    x <> None.
  Proof.
    intros.
    intro J. rewrite J in HeqR. simpl in HeqR.
    destruct y; congruence.
  Qed.

  Lemma lub_unchanged_eq_left: forall x y r (Hlub: lub x y = (r, false)),
    x = r.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety. subst.
      caseEq x; simpl.
        intros Xsdms Hgetx. subst.
        simpl in *.
        destruct_let. uniq_result.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        destruct_conjs. f_equal. symmetry. apply H1; auto.

        intros. subst. simpl in Hlub. congruence.

      intros Hgety. subst.
      caseEq x; intros; subst; simpl in *; try congruence.
  Qed.

  Lemma lub_changed_neq_left: forall x y r (Hlub: lub x y = (r, true)),
    x <> r.
  Proof.
    intros.
    caseEq y.
      intros Ysdms Hgety. subst.
      caseEq x; simpl.
        intros Xsdms Hgetx. subst.
        simpl in *.
        destruct_let. uniq_result.
        symmetry in HeqR.
        apply MG.merge_spec in HeqR.
        destruct_conjs. intro J. inv J.
        assert (l=l) as EQ. auto.
        apply H1 in EQ. congruence.

        intros. subst. simpl in Hlub. congruence.
       intros Hgety. subst.
      caseEq x; intros; subst; simpl in *; try congruence.
  Qed.

  Lemma add_mono: forall p x y,
    ge x y -> ge (transfer p x) (transfer p y).
  Proof.
    unfold transfer. intros.
    destruct x as [x|]; destruct y as [y|]; auto.
      simpl in *. auto with sublist.
  Qed.

  Definition gt (x y: t) : Prop :=
  match x, y with
  | Some _, None => True
  | Some x', Some y' => sublist x' y' /\ exists a, In a y' /\ ~ In a x'
  | _, _ => False
  end.

End Doms.

Require Import syntax.
Import LLVMsyntax.

(* Converting an atom-named successor map to a positive-named successor map. *)
Definition atolist_ptolist_fun (a2p:ATree.t positive) :=
  fun acc ato =>
   match ATree.get ato a2p with
   | Some pto => pto::acc
   | _ => acc
   end.

Definition atolist_ptolist (a2p: ATree.t positive) (tolist: list l): list positive :=
  List.fold_left (atolist_ptolist_fun a2p) tolist nil.

Definition asucc_psucc (a2p: ATree.t positive)
                       (pred: PTree.t (list positive))
                       (from: l) (tolist: list l)
                       : PTree.t (list positive) :=
  match ATree.get from a2p with
  | Some pfrom => PTree.set pfrom (atolist_ptolist a2p tolist) pred
  | _ => pred
  end.

Definition asuccs_psuccs (mapping: ATree.t positive) (succs: ATree.t ls)
  : PTree.t (list positive) :=
  ATree.fold (asucc_psucc mapping) succs (PTree.empty (list positive)).


From ch2o_compcert Require Export stores.
From ch2o_compcert Require Export assertions_lemmas.

Section Program.

Context `{EnvSpec K} (Γ: env K) (δ: funenv K).

Definition var_points_to i mv: assert K :=
  match mv with
    None =>
    var i ↦{false, perm_full} - : sintT%BT
  | Some z =>
    var i ↦{false, perm_full} (# intV{sintT} z) : sintT%BT
  end.

Lemma var_points_to_typed i mv:
  var_points_to i mv ⊆{Γ,δ} (⌜ store_value_typed mv ⌝ ★ True)%A.
Proof.
destruct mv; simpl.
- apply assert_singleton_int_typed.
- rewrite assert_Prop_l.
  + apply assert_True_intro.
  + constructor.
Qed.

Fixpoint assert_stack (st: store): assert K :=
  match st with
    [] => emp
  | mv::st =>
    var_points_to 0 mv ★ assert_stack st ↑
  end.

Lemma assert_stack_typed st:
  assert_stack st ⊆{Γ,δ} (⌜ store_typed st ⌝ ★ True)%A.
Proof.
induction st.
- rewrite assert_Prop_l.
  + apply assert_True_intro.
  + constructor.
- simpl.
  eapply transitivity.
  + apply assert_sep_preserving.
    apply var_points_to_typed.
    rewrite IHst.
    reflexivity.
  + rewrite <- (associative (★)%A).
    apply assert_Prop_intro_l.
    intro.
    rewrite assert_lift_sep.
    rewrite stack_indep.
    rewrite stack_indep.
    rewrite (commutative (★)%A).
    rewrite <- (associative (★)%A).
    apply assert_Prop_intro_l.
    intro.
    rewrite assert_Prop_l.
    * apply assert_True_intro.
    * constructor; assumption.
Qed.

Lemma assert_stack_var st i:
  i < length st ->
  assert_stack st ⊆{Γ,δ}
  ((∃p, var i ⇓ inl p ∧ emp) ★ assert_stack st)%A.
Proof.
revert i.
induction st; simpl; intros.
- lia.
- destruct i.
  + rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rename a into mv.
    destruct mv.
    * simpl.
      rewrite assert_singleton_l at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2.
      reflexivity.
    * simpl.
      rewrite assert_singleton_l_ at 1.
      apply assert_exist_elim; intro p.
      rewrite assert_exist_sep.
      apply assert_exist_intro with (x:=p).
      rewrite emp_dup at 1.
      rewrite <- (associative (★)%A).
      apply assert_sep_preserving; [reflexivity|].
      rewrite assert_singleton_l_2_.
      reflexivity.
  + rewrite (commutative (★)%A).
    rewrite (associative (★)%A).
    apply assert_sep_preserving; [|reflexivity].
    rewrite IHst with (i:=i) at 1; [|lia].
    rewrite assert_lift_sep.
    rewrite assert_lift_exists.
    apply assert_sep_preserving; [|reflexivity].
    apply assert_exist_elim; intro p.
    apply assert_exist_intro with (x:=p).
    rewrite assert_lift_and.
    rewrite stack_indep.
    apply assert_and_intro.
    * apply assert_and_elim_l.
      rewrite <- assert_lift_eval at 1.
      reflexivity.
    * apply assert_and_elim_r; reflexivity.
Qed.

Lemma assert_stack_load st i z:
  st !! i = Some (Some z) ->
  assert_stack st ⊆{Γ,δ} (load (var i) ⇓ inr (intV{sintT} z))%A.
Proof.
revert i.
induction st.
- discriminate.
- destruct i.
  + simpl; intros.
    injection H1; clear H1; intros; subst.
    rewrite <- assert_memext_l with (P:=(load (var 0) ⇓ inr (intV{sintT} z))%A) (Q:=(assert_stack st↑)%A).
    * apply assert_sep_preserving; try reflexivity.
      apply assert_singleton_eval.
      reflexivity.
    * auto with typeclass_instances.
  + simpl; intros.
    rewrite <- assert_memext_r with (Q:=var_points_to 0 a) (P:=(load (var (S i)) ⇓ inr (intV{sintT} z))%A); [|auto with typeclass_instances].
    apply assert_sep_preserving; [reflexivity|].
    rewrite IHst with (1:=H1).
    rewrite assert_lift_expr.
    reflexivity.
Qed.

Lemma var_points_to_unlock_indep i mv:
  (var_points_to i mv ⊆{Γ,δ} var_points_to i mv ◊)%A.
Proof.
destruct mv; unfold var_points_to.
* simpl.
  apply assert_singleton_unlock_indep.
  reflexivity.
* apply assert_exist_elim; intro v.
  rewrite assert_unlock_exists.
  apply assert_exist_intro with (x:=v).
  apply assert_singleton_unlock_indep.
  reflexivity.
Qed.

Lemma assert_stack_unlock_indep' st:
  assert_stack st ⊆{Γ,δ} (assert_stack st ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite <- unlock_indep.
  reflexivity.
- rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st)%A). exact IHst.
    apply unlock_indep.
Qed.

Lemma assert_stack_unlock_indep st:
  (assert_stack st↑)%A ⊆{Γ,δ} ((assert_stack st↑) ◊)%A.
Proof.
revert Γ δ.
induction st; simpl; intros.
- rewrite stack_indep.
  rewrite <- unlock_indep.
  reflexivity.
- rewrite assert_lift_sep.
  rewrite <- assert_unlock_sep.
  apply assert_sep_preserving.
  + rename a into mv.
    destruct mv; unfold var_points_to.
    * rewrite assert_lift_singleton.
      simpl.
      apply assert_singleton_unlock_indep.
      reflexivity.
    * rewrite assert_lift_exists.
      apply assert_exist_elim; intro v.
      rewrite assert_unlock_exists.
      apply assert_exist_intro with (x:=v).
      rewrite assert_lift_singleton.
      apply assert_singleton_unlock_indep.
      reflexivity.
  + assert (UnlockIndep (assert_stack st↑)%A). exact IHst.
    apply unlock_indep.
Qed.

End Program.


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

(* Why3 assumption *)
Definition left1 (i:Z): Z := ((2%Z * i)%Z + 1%Z)%Z.

(* Why3 assumption *)
Definition right1 (i:Z): Z := ((2%Z * i)%Z + 2%Z)%Z.

(* Why3 assumption *)
Definition parent (i:Z): Z := (ZOdiv (i - 1%Z)%Z 2%Z).

Axiom Parent_inf : forall (i:Z), (0%Z < i)%Z -> ((parent i) < i)%Z.

Axiom Left_sup : forall (i:Z), (0%Z <= i)%Z -> (i < (left1 i))%Z.

Axiom Right_sup : forall (i:Z), (0%Z <= i)%Z -> (i < (right1 i))%Z.

Axiom Parent_right : forall (i:Z), (0%Z <= i)%Z -> ((parent (right1 i)) = i).

Axiom Parent_left : forall (i:Z), (0%Z <= i)%Z -> ((parent (left1 i)) = i).

Axiom Inf_parent : forall (i:Z) (j:Z), ((0%Z < j)%Z /\
  (j <= (right1 i))%Z) -> ((parent j) <= i)%Z.

Axiom Child_parent : forall (i:Z), (0%Z < i)%Z ->
  ((i = (left1 (parent i))) \/ (i = (right1 (parent i)))).

Axiom Parent_pos : forall (j:Z), (0%Z < j)%Z -> (0%Z <= (parent j))%Z.

(* Why3 assumption *)
Definition parentChild (i:Z) (j:Z): Prop := ((0%Z <= i)%Z /\ (i < j)%Z) ->
  ((j = (left1 i)) \/ (j = (right1 i))).

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

(* Why3 assumption *)
Definition logic_heap := ((@map.Map.map Z _ Z _)* Z)%type.

(* Why3 assumption *)
Definition is_heap_array (a:(@map.Map.map Z _ Z _)) (idx:Z) (sz:Z): Prop :=
  (0%Z <= idx)%Z -> forall (i:Z) (j:Z), (((idx <= i)%Z /\ (i < j)%Z) /\
  (j < sz)%Z) -> ((parentChild i j) -> ((map.Map.get a i) <= (map.Map.get a
  j))%Z).

(* Why3 assumption *)
Definition is_heap (h:((@map.Map.map Z _ Z _)* Z)%type): Prop :=
  match h with
  | (a, sz) => (0%Z <= sz)%Z /\ (is_heap_array a 0%Z sz)
  end.

Axiom Is_heap_when_no_element : forall (a:(@map.Map.map Z _ Z _)) (idx:Z)
  (n:Z), ((0%Z <= n)%Z /\ (n <= idx)%Z) -> (is_heap_array a idx n).

Axiom Is_heap_sub : forall (a:(@map.Map.map Z _ Z _)) (i:Z) (n:Z),
  (is_heap_array a i n) -> forall (j:Z), ((i <= j)%Z /\ (j <= n)%Z) ->
  (is_heap_array a i j).

Axiom Is_heap_sub2 : forall (a:(@map.Map.map Z _ Z _)) (n:Z), (is_heap_array
  a 0%Z n) -> forall (j:Z), ((0%Z <= j)%Z /\ (j <= n)%Z) -> (is_heap_array a
  j n).

Axiom Is_heap_when_node_modified : forall (a:(@map.Map.map Z _ Z _)) (n:Z)
  (e:Z) (idx:Z) (i:Z), ((0%Z <= i)%Z /\ (i < n)%Z) -> ((is_heap_array a idx
  n) -> (((0%Z < i)%Z -> ((map.Map.get a (parent i)) <= e)%Z) ->
  ((((left1 i) < n)%Z -> (e <= (map.Map.get a (left1 i)))%Z) ->
  ((((right1 i) < n)%Z -> (e <= (map.Map.get a (right1 i)))%Z) ->
  (is_heap_array (map.Map.set a i e) idx n))))).

Axiom Is_heap_add_last : forall (a:(@map.Map.map Z _ Z _)) (n:Z) (e:Z),
  (0%Z < n)%Z -> (((is_heap_array a 0%Z n) /\ ((map.Map.get a
  (parent n)) <= e)%Z) -> (is_heap_array (map.Map.set a n e) 0%Z
  (n + 1%Z)%Z)).

Axiom Parent_inf_el : forall (a:(@map.Map.map Z _ Z _)) (n:Z), (is_heap_array
  a 0%Z n) -> forall (j:Z), ((0%Z < j)%Z /\ (j < n)%Z) -> ((map.Map.get a
  (parent j)) <= (map.Map.get a j))%Z.

Axiom Left_sup_el : forall (a:(@map.Map.map Z _ Z _)) (n:Z), (is_heap_array a
  0%Z n) -> forall (j:Z), ((0%Z <= j)%Z /\ (j < n)%Z) ->
  (((left1 j) < n)%Z -> ((map.Map.get a j) <= (map.Map.get a (left1 j)))%Z).

Axiom Right_sup_el : forall (a:(@map.Map.map Z _ Z _)) (n:Z), (is_heap_array
  a 0%Z n) -> forall (j:Z), ((0%Z <= j)%Z /\ (j < n)%Z) ->
  (((right1 j) < n)%Z -> ((map.Map.get a j) <= (map.Map.get a
  (right1 j)))%Z).

(* Why3 goal *)
Theorem Is_heap_relation : forall (a:(@map.Map.map Z _ Z _)) (n:Z),
  (0%Z < n)%Z -> ((is_heap_array a 0%Z n) -> forall (j:Z), (0%Z <= j)%Z ->
  ((j < n)%Z -> ((map.Map.get a 0%Z) <= (map.Map.get a j))%Z)).
(* Why3 intros a n h1 h2 j h3 h4. *)
Proof.
intros a n H H_heap.
intros j H1.
apply Zlt_lower_bound_ind with (z:=Z0)
 (P:= fun j => (j < n -> Map.get a 0 <= Map.get a j)%Z);
  auto with zarith.
intros x Hind H_x_pos H_x_lt_n.
assert (h: (x = 0 \/ 0 < x)%Z) by omega.
  destruct h.
  (*case x = 0*)
  subst; auto with zarith.
  (*case x > 0*)
  apply Zle_trans with (Map.get a (parent x)).
  apply Hind.
  split.
  apply Parent_pos; auto with zarith.
  apply Parent_inf; auto with zarith.
  apply Zlt_trans with x; auto.
  apply Parent_inf; auto with zarith.
  apply Parent_inf_el with (n := n);
    auto with zarith.
Qed.