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.

Definition empty_set `{T: Type} := Empty_set T.
Definition singleton_set `{T: Type} (e: T) := Singleton T e.
Definition set_union `{T: Type} (s1 s2: Ensemble T) := Union T s1 s2.
Definition set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.In T s e.
Definition not_set_elem `{T: Type} (s: Ensemble T) (e: T) := Ensembles.Complement T s e.
Definition included `{T: Type} (s1 s2: Ensemble T) := Ensembles.Included T s1 s2.
Definition set_minus `{T: Type} (s: Ensemble T) (e: T)  := Ensembles.Subtract T s e.

(* Static Labels *)
Definition Region :=  nat.

(* Program Variables *)
Definition Name := ascii.

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 -> Rgn -> Expr
  | Eff_App   : Expr -> Expr -> Expr
  | Pair_Par  : Expr -> Expr -> Expr -> Expr -> Expr
  | Cond      : Expr -> Expr -> Expr -> Expr
  | Ref       : Rgn -> Expr -> Expr
  | DeRef     : Rgn -> Expr -> Expr
  | Assign    : Rgn -> Expr -> Expr -> Expr
  | Plus      : Expr -> Expr -> Expr
  | Minus     : Expr -> Expr -> Expr
  | Times     : Expr -> Expr -> Expr
  | Eq        : Expr -> Expr -> Expr
  | AllocAbs  : Rgn -> Expr
  | ReadAbs   : Rgn -> Expr
  | WriteAbs  : Rgn -> Expr
  | ReadConc  : Region -> Expr -> Expr
  | WriteConc : Region -> Expr -> Expr
  | Concat    : Expr -> Expr -> Expr
  | Top       : Expr
  | Empty     : Expr
with Rgn := (* w *)
  | Rgn_Const : Region -> Rgn (* s *)
  | Rgn_Var   : Name -> Rgn (* r *).

Notation "'(|' a ',' b '|)" := (Pair_Par a b) (at level 60).

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

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

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 *)
Inductive StaticAction : Set :=
| SA_Alloc : Rgn -> StaticAction
| SA_Read  : Rgn -> StaticAction
| SA_Write : Rgn -> StaticAction.
Definition Epsilon := Ensemble StaticAction.

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.

(* 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 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 acts,
      set_elem acts (CA_AllocAbs s) ->
      DA_in_Theta (DA_Alloc s l) (Some acts)
| DAT_Read_Abs :
    forall s l acts,
      set_elem acts (CA_ReadAbs s) ->
      DA_in_Theta (DA_Read s l) (Some acts)
| DAT_Read_Conc :
    forall s l acts,
      set_elem acts (CA_ReadConc s l) ->
      DA_in_Theta (DA_Read s l) (Some acts)
| DAT_Write_Abs :
    forall s l acts,
      set_elem acts (CA_WriteAbs s) ->
      DA_in_Theta (DA_Write s l) (Some acts)
| DAT_Write_Conc :
    forall s l acts,
      set_elem acts (CA_WriteConc s l) ->
      DA_in_Theta (DA_Write s l) (Some acts).

Inductive Disjoint_Dynamic : DynamicAction -> DynamicAction -> Prop :=
 | DD_Read_Read   : forall r1 l1 r2 l2, Disjoint_Dynamic (DA_Read r1 l1) (DA_Read r2 l2)
 | DD_Write_Write : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Dynamic (DA_Write r1 l1) (DA_Write r2 l2)
 | DD_Read_Write  : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Dynamic (DA_Read r1 l1) (DA_Write r2 l2)
 | DD_Write_Read  : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Dynamic (DA_Write r1 l1) (DA_Read r2 l2).

Inductive Disjoint_Static : StaticAction -> StaticAction -> Prop :=
 | DS_Read_Read   : forall r1 r2, Disjoint_Static (SA_Read r1) (SA_Read r2)
 | DS_Write_Write : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA_Write r1) (SA_Write r2)
 | DS_Read_Write  : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA_Read r1) (SA_Write r2)
 | DS_Write_Read  : forall r1 r2, r1 <> r2 -> Disjoint_Static (SA_Write r1) (SA_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_ReadAbs_ReadConc    : forall r1 r2 l2, Disjoint_Computed_Actions (CA_ReadAbs r1) (CA_ReadConc r2 l2)
 | D_CA_WriteConc_WriteConc : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_WriteConc l1 r1) (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_WriteConc_ReadConc  : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_WriteConc l1 r1) (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_WriteAbs_ReadConc  : forall r1 l1 r2 l2, r1 <> r2 -> l1 <> l2 -> Disjoint_Computed_Actions (CA_WriteConc l1 r1) (CA_ReadConc r2 l2)
 | D_CA_WriteAbs_ReadAbs   : forall r1 r2, r1 <> r2 -> Disjoint_Computed_Actions (CA_WriteAbs r1) (CA_ReadAbs r2).

Axiom Disjoint_Computed_Actions_Refl :
  forall ca1 ca2, Disjoint_Computed_Actions ca1 ca2 -> Disjoint_Computed_Actions ca2 ca1.

Inductive Disjoint_Sets_Computed_Actions : Ensemble (ComputedAction) -> Ensemble (ComputedAction) -> Prop :=
 | D_Set_CA  : forall d1 d2 theta1 theta2,
                    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_Empty : forall theta , Disjointness (Some theta) Theta_Empty
 | D_Theta  : forall theta1 theta2, Disjoint_Sets_Computed_Actions theta1 theta2 -> Disjointness (Some theta1) (Some theta2).

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

Inductive Conflict_Computed_Actions : ComputedAction -> ComputedAction -> Prop :=
 | C_Write : forall r l (d : ComputedAction),
                  d = CA_ReadConc r l \/ d = CA_WriteConc r l ->
                  d = CA_ReadAbs r \/ d = CA_WriteConc r l ->
                  d = CA_ReadConc r l \/ d = CA_WriteAbs r ->
                  d = CA_ReadAbs r \/ d = CA_WriteAbs r -> Conflict_Computed_Actions d (CA_WriteConc r l).

Axiom Conflict_Computed_Actions_Refl :
  forall ca1 ca2, Conflict_Computed_Actions ca1 ca2 -> Conflict_Computed_Actions ca2 ca1.

Inductive Conflict_Sets_Computed_Actions : Ensemble (ComputedAction) -> Ensemble (ComputedAction) -> Prop :=
 | C_Set_CA  : forall d1 d2 theta1 theta2,
                    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_Top    : forall theta, Conflictness theta Theta_Top
 | C_Theta  : forall theta1 theta2,
                 Conflict_Sets_Computed_Actions theta1 theta2  -> Conflictness (Some theta1) (Some theta2).

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.

Axiom Phi_Seq_Nil_L : forall phi, Phi_Seq Phi_Nil phi = phi.
Axiom Phi_Seq_Nil_R : forall phi, Phi_Seq phi Phi_Nil = phi.
Axiom Phi_Par_Nil_R : forall phi, Phi_Par Phi_Nil phi = phi.
Axiom Phi_Par_Nil_L : forall phi, Phi_Par Phi_Nil phi = phi.

Lemma EnsembleUnionSym :
  forall (phi : Phi) (theta theta' : Theta),
    phi ⊑ theta -> phi ⊑ (Union_Theta theta theta') /\ phi ⊑ (Union_Theta theta' theta).
Proof.
  intros phi theta theta' H.
  generalize dependent theta'.
  induction H; intros theta'.
  - split; [apply PTS_Nil | apply PTS_Nil].
  - destruct theta as [acts|]; destruct theta' as [acts'|]; intuition; simpl;
    try (apply PTS_Elem; inversion H; subst; apply DAT_Top).
    + apply PTS_Elem; inversion H; subst;
      [apply DAT_Alloc_Abs |
       apply DAT_Read_Abs | apply DAT_Read_Conc |
       apply DAT_Write_Abs | apply DAT_Write_Conc ];
      apply Union_introl; assumption.
    + apply PTS_Elem; inversion H; subst;
      [apply DAT_Alloc_Abs |
       apply DAT_Read_Abs | apply DAT_Read_Conc |
       apply DAT_Write_Abs | apply DAT_Write_Conc ];
      apply Union_intror; assumption.
  - destruct theta as [acts|]; destruct theta' as [acts'|]; intuition;
    (apply PTS_Seq; [apply IHPhi_Theta_Soundness1 | apply IHPhi_Theta_Soundness2]).
  - split; destruct theta as [acts|]; destruct theta' as [acts'|]; intuition;
    (apply PTS_Par; [apply IHPhi_Theta_Soundness1 | apply IHPhi_Theta_Soundness2]).
Qed.

Lemma EnsembleUnionComp :
  forall (phi1 phi2 : Phi) (theta1 theta2 : Theta),
    phi1 ⊑ theta1 -> phi2 ⊑ theta2 -> Phi_Seq phi1  phi2 ⊑ (Union_Theta theta1 theta2).
Proof.
  intros phi1 phi2 theta1 theta2 H1 H2.
  econstructor.
  - apply EnsembleUnionSym with (theta' := theta2) in H1. intuition.
  - apply EnsembleUnionSym with (theta' := theta1) in H2. intuition.
Qed.

Module E := FMapAVL.Make (AsciiVars).
Module H := FMapAVL.Make (RegionVars).
Module R := FMapAVL.Make (AsciiVars).

Module Raw := E.Raw.

Inductive Val :=
  | Loc  : Rgn -> 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.

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 find_R (k: Rgn) (m: Rho) : option Region :=
  match k with
    | Rgn_Const r => Some r
    | Rgn_Var rho => R.find (elt := Region) rho m
  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 "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,
                      (heap, env, rho, Mu f x ec ee) ⇓ (heap, Cls (env, rho, Mu f x ec ee), Phi_Nil)
  | BS_Lambda_Abs : forall x er env rho heap,
                        (heap, env, rho, Lambda x er) ⇓ (heap, Cls (env, rho, Lambda x er), 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_E (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, 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) ->
                        Disjointness theta1 theta1 /\ 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) ->
                        merge heap_mu1 heap_mu2 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 (Rgn_Const r) l, Phi_Seq vacts (Phi_Elem (DA_Alloc r l)))
  | 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)))
  | 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)))
  | 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 (Rgn_Const r) l, aacts) ->
                        aacts = Phi_Nil->
                        (heap, env, rho, ReadConc r 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 (Rgn_Const r) l, aacts) ->
                        aacts = Phi_Nil ->
                        (heap, env, rho, WriteConc r ea) ⇓ (heap', Eff (Some (singleton_set (CA_WriteConc r l))), Phi_Nil)
  | BS_Eff_Concat  : forall a b env rho heap (effa effb : Theta),
                        (heap, env, rho, a) ⇓ (heap, Eff effa, Phi_Nil) ->
                        (heap, env, rho, b) ⇓ (heap, Eff effb, Phi_Nil) ->
                        (heap, env, rho, Concat a b) ⇓ (heap, Eff (Union_Theta effa effb), Phi_Nil)
  | 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" ].

Inductive type_v1 :=
  | Natural  : type_v1
  | Boolean  : type_v1
  | Arrow    : type_v1 -> (Epsilon * type_v1) -> (Epsilon * type_v1) -> type_v1
  | UnitTy   : type_v1
  | RefTy    : Rgn -> type_v1 -> type_v1
  | Effect   : type_v1
  | RgnPoly  : Name -> (Epsilon * type_v1) -> type_v1
  | RegionTy : type_v1.
Definition tau := type_v1.

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 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 "'∀' var '.' ty '!' eff " := (RgnPoly var (eff, ty))  (at level 60).
Definition eq_name (n n' : Name) := beq_nat (nat_of_ascii n) (nat_of_ascii n').

Inductive rgn2 : bool * bool * bool -> Set :=
  | Rgn2_Const : forall fv bv, Region -> rgn2 (true, fv, bv)
  | Rgn2_FVar : forall c bv, Name -> rgn2 (c, true, bv)
  | Rgn2_BVar : forall c fv, nat -> rgn2 (c, fv, true).
Definition rgn2_in_exp := rgn2 (true, true, false).
Definition rgn2_in_typ := rgn2 (true, true, true).

Inductive StaticAction2 : Set :=
| SA2_Alloc : rgn2_in_typ -> StaticAction2
| SA2_Read  : rgn2_in_typ -> StaticAction2
| SA2_Write : rgn2_in_typ -> StaticAction2.

(*Module Epsilon2Decidable.
Definition t := StaticAction2.
Definition eq (sa: StaticAction2) (sa': StaticAction2) := sa = sa'.
Lemma eq_refl : forall x : t, eq x x. unfold eq. auto. Qed.
Lemma eq_sym : forall x y : t, eq x y -> eq y x. unfold eq. auto. Qed.
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. unfold eq. intros. subst. reflexivity. Qed.
Lemma eq_dec: forall sa sa' : t, { eq sa sa' } + { ~ eq sa sa' }.
Proof.
assert (forall c fv bv (r: rgn2 (c, fv, bv)) (r': rgn2 (c, fv, bv)), { r = r' } + { ~ r = r' }).
{
dependent induction r; dependent induction r'; try (solve [right; intro; unfold eq in H; inversion H]).
+ destruct (Nat.eq_dec r r0). left. auto. right. intro. inversion H. contradiction.
+ destruct (AsciiVars.eq_dec n n0). unfold AsciiVars.eq in e. destruct e. left. auto. right. intro. inversion H. contradiction.
+ destruct (Nat.eq_dec n n0). left. auto. right. intro. inversion H. contradiction.
}
unfold eq.
dependent induction sa; dependent induction sa'; try (solve [right; intro; inversion H0]).
+ destruct (H true true true r r0). left. subst. auto. right. intro. inversion H0. contradiction.
+ destruct (H true true true r r0). left. subst. auto. right. intro. inversion H0. contradiction.
+ destruct (H true true true r r0). left. subst. auto. right. intro. inversion H0. contradiction.
Qed.
End Epsilon2Decidable.

Module Epsilon3 := MSetWeakList.Make (Epsilon2Decidable).*)
Definition Epsilon2 := Ensemble StaticAction2. (* FSetWeakList.Make (Epsilon2Decidable). *)

(* substitute for type *)
Inductive type2 :=
  | Ty2_Natural : type2
  | Ty2_Ref     : rgn2_in_typ -> type2 -> type2
  | Ty2_Arrow   : type2 -> Epsilon2 -> type2 -> Epsilon2 -> type2 -> type2
  | Ty2_ForallRgn : Epsilon2 -> type2 -> type2.

Definition free_rgn_vars_in_rgn2 (rgn: rgn2_in_typ) : Ensemble Name :=
  match rgn with
  | Rgn2_Const _ _ _ => empty_set
  | Rgn2_FVar _ _ n => singleton_set n
  | Rgn2_BVar _ _ _ => empty_set
  end.
Definition free_rgn_vars_in_sa2 (sa: StaticAction2) : Ensemble Name :=
  match sa with
  | SA2_Alloc rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Read rgn => free_rgn_vars_in_rgn2 rgn
  | SA2_Write rgn => free_rgn_vars_in_rgn2 rgn
  end.

Definition free_rgn_vars_in_eps2 (eps: Epsilon2) : Ensemble Name :=
  fun n => exists sa, eps sa -> (free_rgn_vars_in_sa2 sa) n.

(* substitute for fv *)
Fixpoint free_rgn_vars (t: type2) : Ensemble Name :=
  match t with
  | Ty2_Natural    => empty_set
  | Ty2_Ref rgn ty => set_union (free_rgn_vars_in_rgn2 rgn) (free_rgn_vars ty)
  | Ty2_Arrow aty ceff crty eeff erty =>
                      set_union (free_rgn_vars aty)
                                (set_union (set_union (free_rgn_vars_in_eps2 ceff)
                                                      (free_rgn_vars crty))
                                           (set_union (free_rgn_vars_in_eps2 eeff)
                                                      (free_rgn_vars erty)))
  | Ty2_ForallRgn eff rty => set_union (free_rgn_vars_in_eps2 eff)
                                       (free_rgn_vars rty)
  end.

Definition mk_rgn_type (u: rgn2_in_exp) : rgn2_in_typ
 := match u with
      | Rgn2_Const fv bv n => Rgn2_Const true true n
      | Rgn2_FVar c bv n => Rgn2_FVar true true n
      | Rgn2_BVar c fv n => Rgn2_BVar true true n
    end.

Definition open_subst_rgn_exp_in_rgn2 (k : nat) (u: rgn2_in_exp) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ _ => t
    | Rgn2_BVar _ _ n => if (beq_nat n k) then mk_rgn_type u else t
    end.

Definition open_subst_rgn_exp_in_sa2 (k : nat) (u: rgn2_in_exp) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (open_subst_rgn_exp_in_rgn2 k u rgn)
  | SA2_Read rgn  => SA2_Read (open_subst_rgn_exp_in_rgn2 k u rgn)
  | SA2_Write rgn => SA2_Write (open_subst_rgn_exp_in_rgn2 k u rgn)
  end.

Definition open_subst_rgn_exp_in_eps2 (k : nat) (u: rgn2_in_exp) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists (eps' : Epsilon2), eps sa -> eps' (open_subst_rgn_exp_in_sa2 k u sa) .

(* substitute for open_subst *)
Fixpoint open_subst_rgn_exp (k: nat) (u: rgn2_in_exp) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural    => t
  | Ty2_Ref rgn ty => Ty2_Ref (open_subst_rgn_exp_in_rgn2 k u rgn) (open_subst_rgn_exp k u ty)
  | Ty2_Arrow aty ceff crty eeff erty =>
                      Ty2_Arrow (open_subst_rgn_exp k u aty)
                                (open_subst_rgn_exp_in_eps2 k u ceff) (open_subst_rgn_exp k u crty)
                                (open_subst_rgn_exp_in_eps2 k u eeff) (open_subst_rgn_exp k u erty)
  | Ty2_ForallRgn eff rty =>
                      Ty2_ForallRgn (open_subst_rgn_exp_in_eps2 k u eff) (open_subst_rgn_exp k u rty)
  end.

Definition open_subst_rgn (u: rgn2_in_exp)  (t: type2) : type2 := open_subst_rgn_exp 0 u t.
Definition open_rgn (t : type2) (x : Name) : type2
  := let rgn_fvar := Rgn2_FVar true false x in open_subst_rgn_exp 0 (rgn_fvar) t.

Definition close_subst_rgn_exp_in_rgn2 (k : nat) (x: Name) (t: rgn2_in_typ) : rgn2_in_typ
 := match t with
    | Rgn2_Const _ _ _ => t
    | Rgn2_FVar _ _ n  => if AsciiVars.eq_dec n x then (Rgn2_BVar true true k) else t
    | Rgn2_BVar _ _ _  => t
    end.

Definition close_subst_rgn_exp_in_sa2 (k : nat) (x: Name) (sa: StaticAction2) : StaticAction2 :=
  match sa with
  | SA2_Alloc rgn => SA2_Alloc (close_subst_rgn_exp_in_rgn2 k x rgn)
  | SA2_Read rgn  => SA2_Read (close_subst_rgn_exp_in_rgn2 k x rgn)
  | SA2_Write rgn => SA2_Write (close_subst_rgn_exp_in_rgn2 k x rgn)
  end.

Definition close_subst_rgn_exp_in_eps2 (k : nat) (x: Name) (eps: Epsilon2) : Epsilon2 :=
  fun sa => exists (eps' : Epsilon2), eps sa -> eps' (close_subst_rgn_exp_in_sa2 k x sa) .

(* substitute for close_subst *)
Fixpoint close_subst_rgn_exp (k: nat) (x: Name) (t: type2) {struct t} : type2 :=
  match t with
  | Ty2_Natural    => t
  | Ty2_Ref rgn ty => Ty2_Ref (close_subst_rgn_exp_in_rgn2 k x rgn) (close_subst_rgn_exp k x ty)
  | Ty2_Arrow aty ceff crty eeff erty =>
                      Ty2_Arrow (close_subst_rgn_exp k x aty)
                                (close_subst_rgn_exp_in_eps2 k x ceff) (close_subst_rgn_exp k x crty)
                                (close_subst_rgn_exp_in_eps2 k x eeff) (close_subst_rgn_exp k x erty)
  | Ty2_ForallRgn eff rty =>
                      Ty2_ForallRgn (close_subst_rgn_exp_in_eps2 k x eff) (close_subst_rgn_exp k x rty)
  end.

Definition close_rgn (x : Name) (t : type2) := close_subst_rgn_exp 0 x t.

Inductive type: Set :=
  | Fvar    : Name -> type
  | Bvar    : nat -> type
  | Arrow_t : type -> type -> type
  | Forall  : type -> type.

Fixpoint fv (t: type) : Ensemble Name :=
  match t with
  | Fvar x        => singleton_set x
  | Bvar n        => empty_set
  | Arrow_t t1 t2 => set_union (fv t1) (fv t2)
  | Forall t2     => fv t2
  end.

Fixpoint open_subst (k: nat) (u: type) (t: type) {struct t} : type :=
  match t with
  | Fvar n        => t
  | Bvar n        => if (beq_nat n k) then u else t
  | Arrow_t a1 a2 => Arrow_t (open_subst k u a1) (open_subst k u a2)
  | Forall a2     => Forall (open_subst (S k) u a2)
  end.

Definition open (u: type)  (t: type) : type := open_subst 0 u t.
Definition open_var (t : type) (x : Name) : type := open_subst 0 (Fvar x) t.

Fixpoint close_subst (k: nat)  (x: Name)  (t: type) {struct t} : type :=
  match t with
  | Fvar n        => if AsciiVars.eq_dec n x then (Bvar k) else t
  | Bvar n        => t
  | Arrow_t t1 t2 => Arrow_t (close_subst k x t1) (close_subst k x t2)
  | Forall t2     => Forall (close_subst (S k) x t2)
  end.

Definition close_var (x : Name) (t : type) := close_subst 0 x t.

(*Reserved Notation "'[' z ':=' u ']' t" (at level 20).*)
Fixpoint subst (z : Name) (u : type) (t : type) {struct t} : type :=
  match t with
  | Bvar i        => t
  | Fvar x        => if AsciiVars.eq_dec x z then u else t
  | Arrow_t t1 t2 => Arrow_t (subst z u t1) (subst z u t2)
  | Forall t1     => Forall (subst z u t1)
end.
(*where "'[' z ':=' u ']' t" := (subst z u t).*)

Reserved Notation "'[' x ':=' w ']' t" (at level 20).
Fixpoint subst_v1 (t:tau) (x:Name) (w:Rgn) : tau := t
where "'[' x ':=' w ']' t" := (subst_v1 t x w).

Definition subst_rho rho tau :=
  R.fold (fun x r ty => subst_v1 ty x (Rgn_Const r))
         rho tau.

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

Reserved Notation "ec '◀' ee" (at level 50, left associativity).
Inductive BackTriangle : Expr -> Expr -> Prop :=
 | Num_Pure  : forall n : nat,
                (Const n) ◀ ∅
 | Bool_Pure : forall b : bool,
                 (Bool b) ◀ ∅
 | Var_Pure  : forall x : ascii,
                 (Var x) ◀ ∅
 | Abs_Pure  : forall (f x: ascii) (ec ee: Expr),
                 (Mu f x ec ee) ◀ ∅
 | App_Conc  : forall (ef ea efff effa : Expr),
                 (ef ◀ ∅) -> (ea ◀ ∅) -> (Mu_App ef ea) ◀ (Eff_App ef ea)
 | 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 : Rgn),
                     (e ◀ eff) -> (Ref w e) ◀ (eff ⊕ AllocAbs w)
 | Ref_Read_Abs  : forall (e eff : Expr) (w : Rgn),
                     (e ◀ eff) -> (DeRef w e) ◀ (eff ⊕ (ReadAbs w))
 | Ref_Read_Conc : forall (e eff : Expr) (r : Region),
                     (e ◀ ∅) -> (DeRef (Rgn_Const r) e) ◀ (ReadConc r e)
 | Ref_Write_Abs  : forall (e1 e2 eff2 : Expr) (w : Rgn),
                      (e1 ◀ ∅) -> (e2 ◀ eff2) -> (Assign w e1 e2) ◀ (eff2 ⊕ (WriteAbs w))
 | Ref_Write_Conc : forall (e1 e2 eff2 : Expr) (r : Region),
                      (e1 ◀ ∅) -> (e2 ◀ eff2) -> (Assign (Rgn_Const r) e1 e2) ◀ (eff2 ⊕ (WriteConc r e1))
 | Top_Approx: forall e : Expr, e ◀ Top
where "ec '◀' ee" := (BackTriangle ec ee) : type_scope.

Inductive TcRho : (Rho * Omega) -> Prop :=
  | TC_Rho : forall rho rgns,
               (forall r w,
                  (R.find r rho = Some w ->
                   set_elem rgns r)) ->
               (forall r,
                  set_elem rgns r ->
                  (exists w,
                     R.find r rho = Some w)) ->
               TcRho (rho, rgns).

Inductive TcRgn : (Omega * Rgn) -> Prop :=
  | TC_Rgn_Const : forall rgns s,
                      TcRgn (rgns, Rgn_Const s)
  | TC_Rgn_Var   : forall rgns r,
                      set_elem rgns r ->
                      TcRgn (rgns, Rgn_Var r).

Inductive TcExp : (Sigma * Gamma * Omega * Expr * tau * Epsilon) -> Prop :=
  | TC_Nat_Cnt     : forall stty ctxt rgns n,
                        TcExp (stty, ctxt, rgns, Const n, Natural, Empty_Static_Action)
  | TC_Boolean     : forall stty ctxt rgns b,
                        TcExp (stty, ctxt, rgns, Bool b, 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,
                        ec ◀ ee ->
                        TcExp (stty, update_T (x, tyx) ctxt, rgns, ec, tyc, effc) ->
                        TcExp (stty, update_T (x, tyx) ctxt, rgns, ee, Effect, effe) ->
                        TcExp (stty, ctxt, rgns, Mu f x ec ee, Arrow tyx (effc, tyc) (effe, Effect), Empty_Static_Action)
  | TC_Rgn_Abs     : forall stty ctxt rgns x er effr tyr,
                        not_set_elem rgns x ->
                        TcExp (stty, ctxt, set_union rgns (singleton_set x), er, tyr, effr) ->
                        TcExp (stty, ctxt, rgns, Lambda x er, RgnPoly x (effr, tyr), Empty_Static_Action)
  | TC_Mu_App      : forall stty ctxt rgns ef ea tya effc tyc effe efff effa,
                        TcExp (stty, ctxt, rgns, ef, Arrow tya (effc, tyc) (effe, Effect), efff) ->
                        TcExp (stty, ctxt, rgns, ea, tya, effa) ->
                        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 x w  tyr effr efff,
                        TcExp (stty, ctxt, rgns, er, RgnPoly x (effr, tyr), efff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, Rgn_App er w, [x := w]tyr, Union_Static_Action efff effr)
  | TC_Eff_App     : forall stty ctxt rgns ef ea tya effc tyc effe efff effa,
                        TcExp (stty, ctxt, rgns, ef, Arrow tya (effc, tyc) (effe, Effect), efff) ->
                        TcExp (stty, ctxt, rgns, ea, tya, effa) ->
                        TcExp (stty, ctxt, rgns, Eff_App ef ea, 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 = Rgn_Const s ->
                        TcExp (stty, ctxt, rgns, Ref w e, RefTy w t, Union_Static_Action veff (Singleton_Static_Action (SA_Alloc w)))
  | TC_Get_Ref     : forall stty ctxt rgns e t aeff w,
                        TcExp (stty, ctxt, rgns, e, RefTy w t, aeff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, DeRef w e, t, Union_Static_Action aeff (Singleton_Static_Action (SA_Read w)))
  | TC_Set_Ref     : forall stty ctxt rgns ea ev t aeff veff w,
                        TcExp (stty, ctxt, rgns, ea, RefTy w t, aeff) ->
                        TcExp (stty, ctxt, rgns, ev, t, veff) ->
                        TcRgn (rgns, w) ->
                        TcExp (stty, ctxt, rgns, Assign w ea ev, UnitTy,
                               Union_Static_Action (Union_Static_Action aeff veff) (Singleton_Static_Action (SA_Write w)))
  | TC_Conditional : forall stty ctxt rgns b e1 e2 te eff eff1 eff2,
                        TcExp (stty, ctxt, rgns, b, 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, Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Plus e1 e2, Natural, Union_Static_Action eff1 eff2)
  | TC_Nat_Minus  : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Minus e1 e2, Natural, Union_Static_Action eff1 eff2)
  | TC_Nat_Times  : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Times e1 e2, Natural, Union_Static_Action eff1 eff2)
  | TC_Bool_Eq     : forall stty ctxt rgns e1 e2 eff1 eff2,
                        TcExp (stty, ctxt, rgns, e1, Natural, eff1) ->
                        TcExp (stty, ctxt, rgns, e2, Natural, eff2) ->
                        TcExp (stty, ctxt, rgns, Eq e1 e2, Boolean, Union_Static_Action eff1 eff2)
  | TC_Alloc_Abs  : forall stty ctxt rgns r,
                        TcExp (stty, ctxt, rgns, AllocAbs r, Effect, Empty_Static_Action)
  | TC_Read_Abs   : forall stty ctxt rgns r,
                        TcExp (stty, ctxt, rgns, ReadAbs r, Effect, Empty_Static_Action)
  | TC_Read_Conc  : forall stty ctxt rgns e r t aeff,
                        TcExp (stty, ctxt, rgns, e, RefTy (Rgn_Const r) t, aeff) ->
                        TcExp (stty, ctxt, rgns, ReadConc r e, Effect, aeff)
  | TC_Write_Abs  : forall stty ctxt rgns r,
                       TcExp (stty, ctxt, rgns, WriteAbs r, Effect, Empty_Static_Action)
  | TC_Write_Conc : forall stty ctxt rgns e r t aeff,
                       TcExp (stty, ctxt, rgns, e, RefTy (Rgn_Const r) t, aeff) ->
                       TcExp (stty, ctxt, rgns, WriteConc r e, Effect, aeff)
  | TC_Eff_Concat : forall stty ctxt rgns a b eff1 eff2,
                       TcExp (stty, ctxt, rgns, a, Effect, eff1) ->
                       TcExp (stty, ctxt, rgns, b, Effect, eff2) ->
                       TcExp (stty, ctxt, rgns, Concat a b, Effect, Empty_Static_Action)
  | TC_Eff_Top    : forall stty ctxt rgns,
                       TcExp (stty, ctxt, rgns, Top, Effect, Empty_Static_Action)
  | TC_Eff_Empty  : forall stty ctxt rgns,
                       TcExp (stty, ctxt, rgns, Empty, Effect, Empty_Static_Action).

Inductive TcVal : (Sigma * Val * tau) -> Prop :=
  | TC_Num     : forall stty  n,
                   TcVal (stty, Num n, Natural)
  | TC_Bit     : forall stty b,
                   TcVal (stty, Bit b, Boolean)
  | TC_Loc     : forall stty s l ty,
                   ST.find (s, l) stty = Some ty ->
                   TcVal (stty, Loc (Rgn_Const s) l, RefTy (Rgn_Const 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, UnitTy)
  | TC_Eff      : forall stty e, TcVal (stty, Eff e, 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).

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.
Combined Scheme tc_val__tc_env__xind from tc_val__xind, tc_env__xind.

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 stty stty' H ctxt  rho e t eff HTc.
 dependent induction HTc;
 try (econstructor); eauto.
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').
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.
    (*eapply TC_Subst;eauto.
  - intros x v t0 H1 H2. 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.

Lemma EmptyIsNil:
  forall phi, phi ⊑ Theta_Empty -> phi = Phi_Nil.
Proof.
  induction phi; intros.
  reflexivity.
  inversion H; subst; inversion H1; subst; contradiction.
  - assert ( H1 : phi1 = Phi_Nil ) by (apply IHphi1; inversion H; assumption); rewrite H1.
    assert ( H2 : phi2 = Phi_Nil ) by (apply IHphi2; inversion H; assumption); rewrite H2.
    rewrite Phi_Par_Nil_R. reflexivity.
  - assert ( H1 : phi1 = Phi_Nil ) by (apply IHphi1; inversion H; assumption); rewrite H1.
    assert ( H2 : phi2 = Phi_Nil ) by (apply IHphi2; inversion H; assumption); rewrite H2.
    rewrite Phi_Seq_Nil_R. reflexivity.
Qed.

Lemma PhiInThetaTop:
  forall phi, phi ⊑ Theta_Top.
Proof.
  induction phi; intros; econstructor; try assumption; apply DAT_Top.
Qed.

Lemma EmptyTracePreservesHeap_1 :
  forall h r env e same_h v' acts, (h, r, env, e) ⇓ (same_h, v', acts) -> acts = Phi_Nil -> h = same_h.
Proof.
  intros h r env e same_h v' acts H Hnil.  (*destruct H as [H Hnil]. *)
  dependent induction H; auto; inversion Hnil.
  - eapply IHBigStep; [reflexivity | auto].
  - eapply IHBigStep; [reflexivity | auto].
Qed.

Lemma EmptyTracePreservesHeap_2 :
  forall h r env e same_h v acts,
    (h, r, env, e) ⇓ (h, v, acts) -> h = same_h -> (same_h, r, env, e) ⇓ (same_h, v, acts).
Proof.
  intros h r env e same_h v' acts Dyn H. now subst.
Qed.

Lemma EmptyTracePreservesHeap_3 :
  forall h r env e same_h v acts,
    (same_h, r, env, e) ⇓ (same_h, v, acts) -> (h, r, env, e) ⇓ (same_h, v, acts) -> acts = Phi_Nil -> (h, r, env, e) ⇓ (h, v, acts).
Proof.
  intros h r env e same_h v' acts H Dyn1 Hnil.
  apply EmptyTracePreservesHeap_1 in Dyn1. now subst. exact Hnil.
Qed.


(** Here we define the notion of a HIT *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Groupoids.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.BiadjunctionPreservation.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Algebras.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DispDepProd.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Add2Cell.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.FullSub.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.DisplayedBicats.DispTransformation.
Require Import UniMath.Bicategories.DisplayedBicats.DispModification.
Require Import UniMath.Bicategories.DisplayedBicats.DispBuilders.
Require Import UniMath.Bicategories.DisplayedBicats.DispBiadjunction.

Require Import prelude.all.
Require Import signature.hit_signature.
Require Import signature.hit.
Require Import algebra.one_types_polynomials.
Require Import algebra.one_types_endpoints.
Require Import algebra.one_types_homotopies.
Require Import algebra.groupoid_polynomials.
Require Import algebra.groupoid_endpoints.
Require Import algebra.groupoid_homotopies.
Require Import existence.initial_algebra.
Require Import initial_grpd_alg.initial_groupoid_algebra.
Require Import initial_grpd_alg.is_initial.
Require Import hit_biadjunction.hit_algebra_biadj.

Local Open Scope cat.

Definition hit_existence
           (Σ : hit_signature)
  : ∑ (X : hit_algebra_one_types Σ), is_HIT Σ X.
Proof.
  eexists.
  apply initial_algebra_is_HIT.
  exact (left_biadj_preserves_biinitial
           (hit_algebra_biadjunction Σ)
           (initial_groupoid_algebra Σ)
           (initial_groupoid_algebra_is_initial Σ)).
Defined.

(** Note: this evaluates to
```
make_one_type
  (gquot (pr111 (initial_groupoid_algebra Σ)))
  (gtrunc (pr111 (initial_groupoid_algebra Σ)))
```
*)
Definition hit_carrier
           (Σ : hit_signature)
  : one_type
  := pr1 (pr111 (hit_existence Σ)).

Definition hit_path_space
           (Σ : hit_signature)
           (x y : pr111 (initial_groupoid_algebra Σ) : groupoid)
  : gcl _ x = gcl _ y ≃ x --> y.
Proof.
  use make_weq.
  - exact (encode_gquot (pr111 (initial_groupoid_algebra Σ)) (gcl _ x) (gcl _ y)).
  - apply encode_gquot_isweq.
Defined.


Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import Loc.
Require Import Language.

Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.
Require Import Behavior.

Set Implicit Arguments.

Section Simulation.
  Definition SIM := forall (c1_src c1_tgt: Configuration.t), Prop.

  Definition _sim (sim: SIM) (c1_src c1_tgt:Configuration.t): Prop :=
    forall (WF_SRC: Configuration.wf c1_src)
      (WF_TGT: Configuration.wf c1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: Threads.is_terminal (Configuration.threads c1_tgt)),
        exists c2_src,
          <<STEPS_SRC: rtc Configuration.tau_step c1_src c2_src>> /\
          <<TERMINAL_SRC: Threads.is_terminal (Configuration.threads c2_src)>>>> /\
      <<STEP:
        forall e tid c2_tgt
          (STEP_TGT: Configuration.step e tid c1_tgt c2_tgt),
        exists c2_src,
          <<STEP_SRC: Configuration.opt_step e tid c1_src c2_src>> /\
          <<SIM: sim c2_src c2_tgt>>>>
  .

  Lemma _sim_mon: monotone2 _sim.
  Proof.
    ii. exploit IN; eauto. i. des.
    econs; eauto. ii.
    exploit STEP; eauto. i. des. eauto.
  Qed.
  Hint Resolve _sim_mon: paco.

  Definition sim: SIM := paco2 _sim bot2.
End Simulation.
Hint Resolve _sim_mon: paco.

Lemma sim_adequacy
      c_src c_tgt
      (WF_SRC: Configuration.wf c_src)
      (WF_TGT: Configuration.wf c_tgt)
      (SIM: sim c_src c_tgt):
  behaviors Configuration.step c_tgt <1= behaviors Configuration.step c_src.
Proof.
  i. revert c_src WF_SRC WF_TGT SIM.
  induction PR; i.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    hexploit TERMINAL0; eauto. i. des.
    eapply rtc_tau_step_behavior; eauto.
    econs 1. eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 2; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC.
    econs 3; eauto.
  - punfold SIM0. exploit SIM0; eauto. i. des.
    exploit STEP0; eauto. i. des.
    exploit Configuration.step_future; try exact STEP; eauto. i. des.
    exploit Configuration.opt_step_future; try exact STEP_SRC; eauto. i. des.
    inv SIM1; ss. inv STEP_SRC; eauto.
    econs 4; eauto.
Qed.


Require Import Category.Lib.
Require Import Category.Lib.IList.
Require Import Category.Theory.Category.

Definition Obj := nat.

Definition objD' {C : Category} (d : C) (objs : list C) (n : Obj) :=
  List.nth n objs d.

Definition arrD' {C : Category} (d : C) (objs : list C) '(dom, cod) :=
  objD' d objs dom ~> objD' d objs cod.

Class Objects (cat : Category) := {
  def_obj : cat;
  objs : list cat;
  objD := objD' def_obj objs;
}.

Class Arrows (cat : Category) := {
  has_objects : Objects cat;

  arrD := arrD' def_obj objs;
  tys  : list (Obj * Obj);
  arrs : ilist (B:=arrD) tys;
}.
#[export] Existing Instance has_objects.

Inductive Term : Set :=
  | Ident
  | Morph (a : nat)
  | Comp  (f g : Term).

Inductive Expr : Set :=
  | Top
  | Bottom
  | And   (p q : Expr)
  | Or    (p q : Expr)
  | Impl  (p q : Expr)
  | Equiv (x y : Obj) (f g : Term).


From sflib Require Import sflib.
From Paco Require Import paco.
Require Export Coq.Strings.String.
Require Import Coq.Classes.RelationClasses.

From Fairness Require Export
  ITreeLib
  FairBeh
  Mod
  pind
  LPCM
  ModSim.

From Coq Require Import Relations.Relation_Operators.
From Coq Require Import Relations.Operators_Properties.
From Fairness Require Import WFLib Axioms.

Set Implicit Arguments.

Section SHARED_REL_WF.

  Context `{world : URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable ident_src: ID.
  Variable _ident_tgt: ID.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let shared_rel := shared state_src state_tgt ident_src _ident_tgt wf_src wf_tgt -> world -> Prop.

  Definition shared_rel_wf (I : shared_rel) : Prop :=
    forall ths im_src0 im_tgt0 st_src st_tgt r_shared
      (INV: I (ths, im_src0, im_tgt0, st_src, st_tgt) r_shared),
    forall im_tgt1
      (TGT: fair_update im_tgt0 im_tgt1 (prism_fmap inlp (tids_fmap_all ths))),
      (<<INV: I (ths, im_src0, im_tgt1, st_src, st_tgt) r_shared>>).

  Definition wf_clos_trans : WF := {| wf := clos_trans_well_founded (wf wf_tgt) |}.

  Variable I : shared_rel.

  Definition lifted : shared_rel :=
    fun '(ths, im_src, im_tgt, st_src, st_tgt) r_shared =>
      exists im_tgt'0, << INV_LE : (forall i, le wf_clos_trans (im_tgt i) (im_tgt'0 i)) >>
                    /\ << INV : I (ths, im_src, im_tgt'0, st_src, st_tgt) r_shared >>.

  Definition lifted_drop_imap :
    forall ths im_src im_tgt st_src st_tgt r_shared
      (INV : lifted (ths, im_src, im_tgt, st_src, st_tgt) r_shared),
    forall im_tgt'
      (LE : forall i, le wf_tgt (im_tgt' i) (im_tgt i)),
      << INV : lifted (ths, im_src, im_tgt', st_src, st_tgt) r_shared >>.
  Proof.
    i. ss. des. exists im_tgt'0. split; ss.
    ii. specialize (INV_LE i). specialize (LE i). destruct LE.
    - rewrite H. ss.
    - right. destruct INV_LE.
      + rewrite <- H0. econs. ss.
      + eapply clos_trans_n1_trans.
        * econs. eauto.
        * eauto.
  Qed.

  Lemma shared_rel_wf_lifted : shared_rel_wf lifted.
  Proof.
    ii. eapply lifted_drop_imap; eauto.
    i. specialize (TGT i). unfold le, tids_fmap_all in *. unfold prism_fmap in *; ss. unfold is_inl in *; ss.
    destruct i as [i|i]; ss; des_ifs; eauto.
  Qed.

End SHARED_REL_WF.

Section TRANS_CLOS.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Variable _ident_tgt: ID.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Hypothesis (inh : inhabited wf_tgt.(T)).

  Let wf_tgt' := wf_clos_trans wf_tgt.

  Let shared_rel: Type := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt -> M -> Prop.
  Let shared_rel': Type := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt' -> M -> Prop.
  Variable I: shared_rel.
  Let I' : shared_rel' := lifted I.

  Lemma fair_break {Id im_tgt im_tgt' im_tgt'' fm}
    (LE : (forall i, le wf_tgt' (im_tgt' i) (im_tgt i)))
    (FAIR : @fair_update Id wf_tgt' im_tgt' im_tgt'' fm)
    : exists im_tgt'0, <<FAIR : @fair_update Id wf_tgt im_tgt im_tgt'0 fm >> /\
                  << LE : forall i, le wf_tgt' (im_tgt'' i) (im_tgt'0 i) >>.
  Proof.
    pose (fun i x => lt wf_tgt x (im_tgt i) /\ le wf_tgt' (im_tgt'' i) x) as P.
    exists (fun i => match fm i with
             | Flag.fail => epsilon inh (P i)
             | Flag.emp => im_tgt i
             | Flag.success => im_tgt'' i
             end).
    assert (forall i, fm i = Flag.fail -> exists x, P i x).
    { i. specialize (LE i). specialize (FAIR i). rewrite H in FAIR.
      destruct LE as [EQ | LT].
      - rewrite EQ in *. eapply clos_trans_step in FAIR; ss.
      - eapply clos_trans_step in LT. destruct LT as [x [LT LE]].
        exists x. subst P; ss. split; eauto. right. des.
        + rewrite LE in *. eauto.
        + eapply clos_trans_n1_trans; eauto.
    }
    split.
    - ii. specialize (H i). des_ifs. hexploit H; ss.
      i. eapply epsilon_spec in H0. destruct H0; eauto.
    - ii. specialize (H i). specialize (LE i). specialize (FAIR i). des_ifs.
      + hexploit H; ss. i. eapply epsilon_spec in H0. destruct H0; eauto.
      + rewrite FAIR. eauto.
      + left. reflexivity.
  Qed.

  Variable R0 R1 : Type.
  Variable RR : R0 -> R1 -> Prop.

  Lemma local_sim_clos_trans src tgt (SIM : local_sim I RR src tgt)
    : local_sim I' RR src tgt.
  Proof.
    ii. ss. des. move SIM at bottom.
    set (im_tgt'1 := fun i =>
                       match i with
                       | inl i => if tid_dec i tid then im_tgt1 (inl i) else im_tgt'0 (inl i)
                       | inr i => im_tgt'0 (inr i)
                       end).
    assert (TID_TGT' : @fair_update _ wf_tgt im_tgt'0 im_tgt'1 (prism_fmap inlp (fun i => if tid_dec i tid then Flag.success else Flag.emp))).
    { ii. subst im_tgt'1. specialize (TID_TGT i). specialize (INV_LE i). unfold prism_fmap in *; ss. unfold is_inl in *; ss. destruct i as [i|i]; ss; des_ifs. }
    specialize (SIM ths0 im_src0 im_tgt'0 st_src0 st_tgt0 r_shared0 r_ctx0 INV0 tid ths1 THS VALID im_tgt'1 TID_TGT').
    des. exists r_shared1, r_own. splits; ss.
    { exists im_tgt'1. splits; ss.
      subst im_tgt'1. i. specialize (TID_TGT i). specialize (INV_LE i).
      unfold prism_fmap in *; ss. unfold is_inl in *; ss. destruct i as [i|i]; ss.
      - des_ifs.
        + reflexivity.
        + rewrite TID_TGT. ss.
      - rewrite TID_TGT. ss.
    }
    i. des. pose proof (fair_break INV1 TGT). des. move SIM1 at bottom.
    specialize (SIM1 ths im_src1 im_tgt'2 st_src2 st_tgt2 r_shared2 r_ctx2 INV2 VALID1 im_tgt'3 FAIR fs ft).
    rename SIM1 into LSIM. clear - inh LSIM LE. revert_until I'. ginit. gcofix CIH. i. gstep.
    remember (local_RR I RR tid) as RR'.
    remember (ths, im_src1, im_tgt'3, st_src2, st_tgt2) as sha.
    revert ths im_src1 im_tgt3 im_tgt'3 st_src2 st_tgt2 LE Heqsha RR HeqRR'.
    unfold lsim in LSIM. punfold LSIM.
    pattern R0, R1, RR', fs, ft, r_ctx2, src, tgt, sha.
    revert R0 R1 RR' fs ft r_ctx2 src tgt sha LSIM.
    eapply pind9_acc. intros rr DEC IH R0 R1 RR' fs ft r_ctx src tgt sha. i. clear DEC. subst.
    eapply pind9_unfold in PR; eauto with paco. eapply pind9_fold. inv PR.
    - econs. ss. des. exists ths3, r_own, r_shared. splits; ss. exists im_tgt'3. split; ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. des. exists x. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs.
    - econs. des. exists im_src0. splits; ss. split; ss. eapply IH; ss. destruct LSIM0. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. specialize (LSIM x). split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. pose proof (fair_break LE FAIR). des.
      specialize (LSIM im_tgt'0 FAIR0). split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. specialize (LSIM ret). gfinal. left. eapply CIH; ss. pclearbot. eapply LSIM.
    - econs. i. specialize (LSIM ret). gfinal. left. eapply CIH; ss. pclearbot. eapply LSIM.
    - eapply lsim_yieldL. split; ss. eapply IH; ss. destruct LSIM. ss.
    - eapply lsim_yieldR; eauto. { exists im_tgt'3. split; eauto. } i. ss. des.
      pose proof (fair_break INV_LE TGT). des. move LSIM at bottom.
      specialize (LSIM ths1 im_src0 im_tgt'0 st_src1 st_tgt1 r_shared1 r_ctx1 INV1 VALID0 im_tgt'1 FAIR).
      split; ss. eapply IH; ss. destruct LSIM. eapply H0.
    - eapply lsim_sync; eauto. { exists im_tgt'3. split; eauto. } i. ss. des.
      pose proof (fair_break INV_LE TGT). des. move LSIM at bottom.
      specialize (LSIM ths1 im_src0 im_tgt'0 st_src1 st_tgt1 r_shared1 r_ctx1 INV1 VALID0 im_tgt'1 FAIR).
      pclearbot. gfinal. left. eapply CIH; ss.
    - econs. gfinal. left. pclearbot. eapply CIH; ss.
  Qed.

End TRANS_CLOS.

Section WFT_MONO.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Variable _ident_tgt: ID.

  Variable wf_src  : WF.
  Variable wft_T : Type.
  Variable wft_lt : wft_T -> wft_T -> Prop.
  Variable wft_lt' : wft_T -> wft_T -> Prop.
  Hypothesis wft_wf : well_founded wft_lt.
  Hypothesis wft_wf' : well_founded wft_lt'.
  Hypothesis wft_LE : forall x y, wft_lt' x y -> wft_lt x y.
  Let wf_tgt  := {| wf := wft_wf |}.
  Let wf_tgt' := {| wf := wft_wf' |}.

  Let shared_rel: Type := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt -> M -> Prop.
  Let shared_rel': Type := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt' -> M -> Prop.
  Variable I: shared_rel.
  Let I' : shared_rel' := I.

  Variable R0 R1 : Type.
  Variable RR : R0 -> R1 -> Prop.

  Lemma fair_mono Id m_tgt1 m_tgt2 fm
    (FAIR : @fair_update Id wf_tgt' m_tgt1 m_tgt2 fm)
    : @fair_update Id wf_tgt m_tgt1 m_tgt2 fm.
  Proof. ii. specialize (FAIR i). des_ifs. eapply wft_LE. ss. Qed.

  Lemma local_sim_wft_mono src tgt (SIM : local_sim I RR src tgt)
    : local_sim I' RR src tgt.
  Proof.
    ii. ss. move SIM at bottom.
    assert (TID_TGT' : @fair_update _ wf_tgt im_tgt0 im_tgt1 (prism_fmap inlp (fun i : thread_id => if tid_dec i tid then Flag.success else Flag.emp))).
    { ii. specialize (TID_TGT i). unfold prism_fmap in *; ss. unfold is_inl in *; ss. destruct i as [i|i]; ss. des_ifs. }
    specialize (SIM ths0 im_src0 im_tgt0 st_src0 st_tgt0 r_shared0 r_ctx0 INV tid ths1 THS VALID im_tgt1 TID_TGT').
    des. exists r_shared1, r_own. splits; ss. i. move SIM1 at bottom.
    specialize (SIM1 ths im_src1 im_tgt2 st_src2 st_tgt2 r_shared2 r_ctx2 INV1 VALID1 im_tgt3 (fair_mono TGT) fs ft).
    rename SIM1 into LSIM. clear - LSIM wft_LE. revert_until I'. ginit. gcofix CIH. i. gstep.
    remember (local_RR I RR tid) as RR'.
    match goal with [ LSIM : lsim _ _ _ _ _ _ _ _ ?SHA |- _ ] => remember SHA as sha end.
    revert ths im_src1 im_tgt3 st_src2 st_tgt2 Heqsha RR HeqRR'.
    unfold lsim in LSIM. punfold LSIM.
    pattern R0, R1, RR', fs, ft, r_ctx2, src, tgt, sha.
    revert R0 R1 RR' fs ft r_ctx2 src tgt sha LSIM.
    eapply pind9_acc. intros rr DEC IH R0 R1 RR' fs ft r_ctx src tgt sha. i. clear DEC. subst.
    eapply pind9_unfold in PR; eauto with paco. eapply pind9_fold. inv PR.
    - econs. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. des. exists x. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs.
    - econs. des. exists im_src0. splits; ss. split; ss. eapply IH; ss. destruct LSIM0. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. specialize (LSIM x). split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. specialize (LSIM im_tgt1 (fair_mono FAIR)). split; ss. eapply IH; ss. destruct LSIM. ss.
    - econs. i. specialize (LSIM ret). gfinal. left. eapply CIH; ss. pclearbot. eapply LSIM.
    - econs. i. specialize (LSIM ret). gfinal. left. eapply CIH; ss. pclearbot. eapply LSIM.
    - eapply lsim_yieldL. split; ss. eapply IH; ss. destruct LSIM. ss.
    - eapply lsim_yieldR; eauto. i. move LSIM at bottom.
      specialize (LSIM ths1 im_src0 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1 INV0 VALID0 im_tgt2 (fair_mono TGT)).
      split; ss. eapply IH; ss. destruct LSIM. ss.
    - eapply lsim_sync; eauto. i. move LSIM at bottom.
      specialize (LSIM ths1 im_src0 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1 INV0 VALID0 im_tgt2 (fair_mono TGT)).
      pclearbot. gfinal. left. eapply CIH; ss.
    - econs. gfinal. left. pclearbot. eapply CIH; ss.
  Qed.

End WFT_MONO.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B D E : Universe, ((wd_ O A /\ (wd_ B A /\ (wd_ A D /\ (wd_ D E /\ (wd_ D B /\ (wd_ A E /\ (wd_ O B /\ (wd_ D O /\ (wd_ E O /\ (col_ D E B /\ (col_ A D E /\ col_ O A D))))))))))) -> col_ O A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Bsh.
Require Import Blech.Groupoid.
Require Import Blech.Functor.
Require Blech.Reflect.

Import CategoryNotations.
Import GroupoidNotations.
Import BishopNotations.

Open Scope category_scope.
Open Scope bishop_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Free (S: Bishop): Groupoid := {|
  C := {|
    Obj := S ;
    Mor := equiv ;
    Mor_Setoid _ _ := {| equiv _ _ := True |} ;
  |} ;
|}.

Next Obligation.
Proof.
  exists.
  all: exists.
Defined.

Next Obligation.
Proof.
  rewrite H0, H.
  reflexivity.
Defined.

Next Obligation.
Proof.
  symmetry.
  assumption.
Defined.

#[program]
Definition Free_map {A B: Bishop} (f: Bsh A B): Functor (Free A) (Free B) := {|
  op := proj1_sig f ;
  map _ _ f := _ ;
|}.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.

Require Import InvTactics.
Require Import ListUtility.

(** Definitions of HTTP response. **)

Inductive HttpResponsePart : Type :=
| Res_HeaderPart : string -> HttpResponsePart
| Res_BodyPart : string -> HttpResponsePart.

Definition HttpResponse : Type := list HttpResponsePart.

(** Definitions of what a well formed HTTP response is. *)

Inductive response_body : HttpResponse -> Prop :=
| rb_cons_nil : forall s,
    response_body (Res_BodyPart s :: nil)
| rb_cons_body : forall s res,
    response_body res ->
    response_body (Res_BodyPart s :: res).

Inductive response_header : HttpResponse -> Prop :=
| rf_cons_body : forall s res,
    response_body res ->
    response_header (Res_HeaderPart s :: res)
| rf_cons_header : forall s res,
    response_header res ->
    response_header (Res_HeaderPart s :: res).

Hint Constructors response_body.
Hint Constructors response_header.

(* A well formed response must be some header lines followed by some body lines.
     That means, header lines can not be between body lines,
     or the other way around.
 *)
Definition well_formed_response (res: HttpResponse) : Prop := response_header res.

(** The same definitions as above, but defined in functions. **)

Definition is_response_body (res: HttpResponsePart) : bool :=
  match res with
  | Res_BodyPart _ => true
  | _ => false
  end.

Definition has_only_response_body (res: HttpResponse) : bool :=
  forallb is_response_body res.

Fixpoint is_well_formed_response_rec (res: HttpResponse) : bool :=
  match res with
  | Res_HeaderPart _ :: rs => is_well_formed_response_rec rs
  | Res_BodyPart _ :: rs => has_only_response_body rs
  | _ => false
  end.

Definition is_well_formed_response (res: HttpResponse) : bool :=
  match res with
  | Res_HeaderPart _ :: rs => is_well_formed_response_rec rs
  | _ => false
  end.

(** Some theorems about well formed HTTP response. **)

Lemma response_body_no_header_line:
  forall res1 res2 s,
    ~ response_body (res1 ++ Res_HeaderPart s :: res2).
Proof.
  intros. induction res1; simpl; intro.
  - inversion H.
  - destruct a.
    + inversion H.
    + inversion H.
      * eapply nil_neq_app_cons. apply H2.
      * contradiction.
Qed.

Lemma body_before_header_response_not_well_formed:
  forall res1 res2 s1 s2,
    ~ well_formed_response (res1 ++
                                 Res_BodyPart s1 :: Res_HeaderPart s2 :: res2).
Proof.
  intros. induction res1; simpl; intro.
  - inversion H.
  - inversion H; subst.
    + assert (response_body ((res1 ++ Res_BodyPart s1 :: nil) ++ (Res_HeaderPart s2 :: res2))).
      { rewrite <- app_assoc. simpl. assumption. }
      eapply response_body_no_header_line. apply H0.
    + unfold well_formed_response in IHres1. contradiction.
Qed.

Lemma well_formed_response_not_empty : forall res,
    well_formed_response res ->
    res <> nil.
Proof.
  intros. intro. inversion H; subst; inversion H2.
Qed.

(** Proof that our inductive definitions and function definitions are equivalent.
 **)

Lemma response_body_has_only_response_body : forall res,
    response_body res -> has_only_response_body res = true.
Proof.
  intros res H. induction H; auto.
Qed.

Lemma has_only_response_body_add_body_is_response_body : forall s res,
    has_only_response_body res = true -> response_body (Res_BodyPart s :: res).
Proof.
  intros s res H. generalize dependent s.
  induction res; auto.
  - intros s. apply rb_cons_body. destruct a.
    + simpl in H. inversion H.
    + apply IHres. rewrite <- H. auto.
Qed.

Lemma response_body_implies_is_well_formed_response_rec : forall res,
    response_body res -> is_well_formed_response_rec res = true.
Proof.
  intros res H. induction H; auto.
  - simpl. apply response_body_has_only_response_body; assumption.
Qed.

Lemma response_header_implies_is_well_formed_response_rec : forall res,
    response_header res -> is_well_formed_response_rec res = true.
Proof.
  intros res H. induction H; simpl.
  - apply response_body_implies_is_well_formed_response_rec; assumption.
  - assumption.
Qed.

Theorem well_formed_response_is_well_formed_response : forall res,
    well_formed_response res <-> is_well_formed_response res = true.
Proof.
  intro res. induction res as [| r rs].
  - simpl; split; intros; try solve by inversion.
  - destruct r; split; intro H; try solve by inversion.
    + inversion H; subst; simpl.
      * apply response_body_implies_is_well_formed_response_rec.
        assumption.
      * apply response_header_implies_is_well_formed_response_rec.
        assumption.
    + destruct rs as [| r' rs'].
      * simpl in H. inversion H.
      * destruct r'.
        { apply rf_cons_header. apply IHrs.
          simpl in *. assumption. }
        { apply rf_cons_body.
          apply has_only_response_body_add_body_is_response_body.
          simpl in H. assumption. }
Qed.


(*
 * Strong Normalization for Nested Relational Calculus.
 * Copyright Ezra Cooper, 2008-2020.
 *)

Load "eztactics.v".

Require Import Arith.
Require Import List.

Add Rec LoadPath "Listkit" as Listkit.

Require Import Listkit.Foreach.
Require Import Listkit.NthError.

Require Import Term.

Definition shift_var k n :=
  fun x => if le_gt_dec k x then (x + n) else x.

(** Shifting De Bruijn indexes *)
Fixpoint shift k n tm {struct tm} :=
  match tm with
| TmConst => TmConst
| TmVar x => TmVar (shift_var k n x)
| TmPair L M => TmPair (shift k n L) (shift k n M)
| TmProj b M => TmProj b (shift k n M)
| TmAbs N' => TmAbs (shift (S k) n N')
| TmApp L M => TmApp (shift k n L) (shift k n M)
| TmNull => TmNull
| TmSingle x => TmSingle (shift k n x)
| TmUnion L R => TmUnion (shift k n L) (shift k n R)
| TmBind M N => TmBind (shift k n M) (shift (S k) n N)
| TmIf b M N => TmIf (shift k n b) (shift k n M) (shift k n N)
| TmTable ty => TmTable ty
  end.

Definition unshift_var k n :=
  fun x => if le_gt_dec (n + k) x then (x - n) else x.

Fixpoint unshift k n tm {struct tm} :=
  match tm with
| TmConst => TmConst
| TmVar x => TmVar (unshift_var k n x)
| TmPair L M => TmPair (unshift k n L) (unshift k n M)
| TmProj b m => TmProj b (unshift k n m)
| TmAbs N => TmAbs (unshift (S k) n N)
| TmApp L M =>TmApp (unshift k n L) (unshift k n M)
| TmNull => TmNull
| TmSingle x => TmSingle (unshift k n x)
| TmUnion l r => TmUnion (unshift k n l) (unshift k n r)
| TmBind M N => TmBind (unshift k n M) (unshift (S k) n N)
| TmIf b M N => TmIf (unshift k n b) (unshift k n M) (unshift k n N)
| TmTable ty => TmTable ty
end.

#[local] Hint Transparent unshift_var shift_var : Shift.

Lemma unshift_var_shift_var :
  forall x k n,
    unshift_var k n (shift_var k n x) = x.
Proof.
 intros x k n.
 unfold unshift_var, shift_var.
 break; break; lia.
Qed.

Lemma unshift_shift :
  forall N k n,
    unshift k n (shift k n N) = N.
Proof.
 induction N; intros k n; simpl; f_equal; auto.
 apply unshift_var_shift_var.
Qed.

(** (Un)Shifting at De Bruijn index k when k is above the greatest free
    index is a no-op. *)
Lemma shift_nonfree_noop :
  forall n M k env T,
    length env <= k ->
    Typing env M T -> shift k n M = M.
Proof.
 induction M; simpl; intros k env T k_big M_tp; intuition;
   inversion M_tp as [| ? ? T_is_env_x | | | | | | | | | |];
     try (f_equal; eauto).
 (* Case TmVar *)
   unfold shift_var.
   break; trivial.
   pose (nth_error_to_length _ _ _ _ T_is_env_x).
   lia.
 (* Case TmAbs *)
  apply IHM with (s :: env) t; simpl; auto; lia.
 (* Case TmBind *)
 apply IHM2 with (s :: env) (TyList t); simpl; auto; lia.
Qed.

Lemma unshift_nonfree_noop :
  forall n M k env T,
    length env <= k ->
    Typing env M T -> unshift k n M = M.
Proof.
 induction M; simpl; intros k env T k_big M_tp; intuition;
   inversion M_tp as [| ? ? T_is_env_x | | | | | | | | | |];
     try (f_equal; eauto).
   unfold unshift_var.
   break; trivial.
   (* TODO: Need to parameterize efinish on hint databases? *)
   exfalso.
   apply nth_error_to_length in T_is_env_x.
   lia.
   eapply IHM with (s :: env) t; auto; simpl; lia.
 eapply IHM2 with (s :: env) (TyList t); auto; simpl; lia.
Qed.

(** (Un)Shifting a closed term is a no-op. *)
Lemma shift_closed_noop :
  forall n M k T,
    Typing nil M T -> shift k n M = M.
Proof.
 intros; eapply shift_nonfree_noop; eauto.
 simpl; apply le_O_n.
Qed.

Lemma unshift_closed_noop :
  forall n M k T,
    Typing nil M T -> unshift k n M = M.
Proof.
 intros; eapply unshift_nonfree_noop; eauto.
 simpl; apply le_O_n.
Qed.

#[export] Hint Resolve shift_closed_noop : Shift.

Lemma shift_var_nth_error:
  forall A (x:A) n env2 env1 env',
       value x = nth_error (env1 ++ env2) n
    -> value x = nth_error (env1 ++ env' ++ env2)
                           (shift_var (length env1) (length env') n).
Proof.
 unfold shift_var.
 intros ? x n env2 env1 env' H.
 destruct (le_gt_dec (length env1) n).
  assert (n < length (env1 ++ env2)) by eauto with NthError.
  rewrite app_length in H0.
  rewrite nth_error_app_eq; repeat (rewrite app_length); try finish.
  rewrite nth_error_app_eq; repeat (rewrite app_length); try finish.
  replace (n + length env' - length env1 - length env')
     with (n - length env1) by lia.
  solve [auto with NthError].
 rewrite nth_error_ext_length; auto.
 rewrite nth_error_ext_length in H by auto.
 auto.
Qed.

(** Shift preserves typing. *)
Lemma shift_preserves_typing:
  forall M k n env1 env2 env env' T,
    env1 ++ env2 = env ->
    k = length env1 ->
    n = length env' ->
    Typing env M T -> Typing (env1 ++ env' ++ env2) (shift k n M) T.
Proof.
 induction M; intros k n env1 env2 env env' T env_split k_def n_def M_tp;
   inversion M_tp as [| ? ? T_is_env_x| | | | | | | | | |]; simpl.
 (* TmConst *)
            solve [auto].
 (* TmVar *)
           subst x0 ty env n k.
           apply TVar.
           apply shift_var_nth_error; auto.
 (* TmPair *)
          apply TPair; eauto.
 (* TmProj *)
         eapply TProj1; eauto.
        eapply TProj2; eauto.
 (* TmAbs *)
       subst n0 T env k.
       apply TAbs.
       replace (s :: env1 ++ env' ++ env2)
          with ((s::env1) ++ env' ++ env2) by auto.
       eauto using IHM.
 (* TmApp *)
       eauto.
      auto.
    apply TSingle; eauto.
   apply TUnion; eauto.
 (* TmBind *)
  eapply TBind.
   eapply IHM1; seauto.
  subst env.
  replace (s :: env1 ++ env' ++ env2)
    with ((s::env1) ++ env' ++ env2) by auto.
  eapply IHM2 with (s::env1 ++ env2); auto.
  simpl.
  sauto.

 (* TmTable *)
 auto.
Qed.

(** Shifting a term by just one preserves typing. *)
Lemma shift1_preserves_typing :
  forall M env S T,
    Typing env M T -> Typing (S::env) (shift 0 1 M) T.
Proof.
 intros.
 replace (S::env) with (nil ++ (S::nil) ++ env) by trivial.
 apply shift_preserves_typing with env; auto.
Qed.

#[export] Hint Resolve shift1_preserves_typing : Shift.

(** For a closed list of terms (as indicated when env_typing applies
to the list), shifting by any amount is a noop. *)
Lemma env_typing_shift_noop :
  forall Vs env,
    env_typing Vs env ->
    forall n k, map (shift n k) Vs = Vs.
Proof.
 induction Vs; simpl; intros env H; auto.
 intros n k.
 inversion H as [len tps].
 destruct env; [refute; simpl in *; lia| ].
 unfold foreach2_ty in tps.
 simpl in tps.
 inversion tps.
 f_equal.
 - eauto using shift_closed_noop.
 - rewrite IHVs with env n k; auto.
Qed.

#[export] Hint Resolve env_typing_shift_noop : Shift.

(** Applying [unshift k _] to a variable _smaller_ than [k] as no effect. *)
Lemma unshift_var_lo :
  forall x k n,
    x < k -> unshift_var k n x = x.
Proof.
 simpl.
 intros x k n H.
 unfold unshift_var.
 destruct (le_gt_dec (n + k) x);
   [solve[lia]|solve[auto]].
Qed.

(** Composing one [shift] with another, at the same [k], can be
    reduced to a single [shift]. *)
Lemma shift_shift:
  forall n n' M k,
    shift k n (shift k n' M) = shift k (n + n') M.
Proof.
 induction M; intros k; simpl; try (solve [f_equal; eauto]).
(* Case TmVar *)
 f_equal.
 unfold shift_var.
 destruct (le_gt_dec k x).
  destruct (le_gt_dec k (x + n')); lia.
 destruct (le_gt_dec k x); lia.
Qed.

(** Composing one [shift] with another, where the later [k] falls in the
    gap created by the earlier [shift], can be reduced to a single [shift]. *)
Lemma shift_shift':
  forall n n' M k k',
    k' <= k -> k <= k' + n' ->
    shift k n (shift k' n' M) = shift k' (n + n') M.
Proof.
 induction M; intros k k' H0 H1; simpl; try (solve [f_equal; eauto]).
(* Case TmVar *)
 f_equal.
 unfold shift_var.
 break; break; lia.
 (* Csae TmAbs *)
 f_equal.
 apply IHM; lia.
 (* Csae TmBind *)
 f_equal.
 apply IHM1; lia.
 apply IHM2; lia.
Qed.

(** Composing [unshift] with [shift], given certain conditions (TODO)
    on the indices, produces the effect of a single [shift] *)
Lemma fancy_unshift_shift:
  forall n M k n' j,
    k + n <= j + n' ->
    j <= k ->
    unshift k n (shift j n' M) = shift j (n' - n) M.
Proof.
 induction M; intros k n' j n'_big j_small; simpl; f_equal; try eauto.
 (* Case TmVar *)
  unfold unshift_var, shift_var.
  destruct (le_gt_dec j x).
   break; lia.
  break; lia.
 (* Case TmAbs *)
  apply IHM; lia.
 (* Case TmBind *)
 apply IHM2; lia.
Qed.

Lemma shift_var_shift_var_commute:
  forall x k k' n,
    k' <= k ->
    shift_var (S k) n (shift_var k' 1 x) =
    shift_var k' 1 (shift_var k n x).
Proof.
 intros x k k' n H.
 unfold shift_var at 2 4.
 break; break.
    unfold shift, shift_var.
    break; break; lia.
   unfold shift, shift_var.
   break; break; lia.
  unfold shift, shift_var.
  break; break; lia.
 unfold shift, shift_var.
 break; break; lia.
Qed.

(** "Shifting by one" commutes with "shifting by [k]" for appropriate
   conditions and adjustment of [k]. *)
Lemma shift_shift_commute:
  forall M k k' n,
    k' <= k ->
    shift (S k) n (shift k' 1 M) =
    shift k' 1 (shift k n M).
Proof.
 induction M; intros k k' n H; try (solve [simpl; f_equal; eauto]).
 (* TmVar *)
  unfold shift at 2 4.
  unfold shift.
  f_equal.
  apply shift_var_shift_var_commute; auto.
 (* TmAbs *)
 simpl; f_equal.
 assert (S k' <= S k) by lia.
 eauto.
 simpl; f_equal.
  apply IHM1; auto.
 apply IHM2; auto.
 lia.
Qed.

Require Import Listkit.logickit.

Lemma shift_var_S_pred:
  forall x k n,
    x <> 0 ->
    pred (shift_var (S k) n x) = shift_var k n (pred x).
Proof.
 unfold shift_var.
 intros.
 pose (pred := fun x => x - 1).
 replace ((if le_gt_dec (S k) x then x + n else x) - 1)
    with (pred (if le_gt_dec (S k) x then x + n else x)) by auto.
 replace (pred (if le_gt_dec (S k) x then x + n else x))
    with (if le_gt_dec (S k) x then pred (x + n) else pred x).
  unfold pred.
  break; break; lia.
 symmetry; apply if_cc.
Qed.

Require Import Coq.Lists.ListSet.

(* TODO: grumble, why this? *)
Definition set_remove := Listkit.Sets.set_remove.

Require Import Monomorphism.
Require Import Listkit.Map.
Require Import Listkit.Sets.

Import Setoid.

Lemma not_in_union_elim: forall x A B, ~ (x ∈ A ∪ B) -> ~ (x ∈ A) /\ ~ (x ∈ B).
Proof.
  intros. split; contrapose H; apply set_union_intro; auto.
Qed.

Lemma remove_0_pred_preserves_nonzero_membership:
  forall x xs,
  (S x ∈ xs) ->
  (x ∈ set_map Nat.eq_dec Init.Nat.pred (Term.set_remove nat Nat.eq_dec 0 xs)).
Proof.
  intros.
  rewrite map_monomorphism with (f := S).
  2: { firstorder. }
  rewrite set_map_map by solve [auto with Listkit].
  apply set_map_idy_ext; [ | solve [auto with Listkit]].
  intros.
  apply set_remove_elim in H0.
  lia.
Qed.

(* TODO: The asymetry between this and shift_var_unshift_var_commute is upsetting. *)
Lemma shift_var_unshift_var_commute1:
  forall k k' x,
    x <> k' ->
    k' <= k ->
    shift_var k 1 (unshift_var k' 1 x) =
    unshift_var k' 1 (shift_var (S k) 1 x).
Proof.
  unfold not in *.
  intuition.
  unfold shift_var, unshift_var.
  break; break; break; break; lia.
Qed.

Lemma shift_unshift_commute :
  forall M k k',
    ~ set_In k' (freevars M) ->
    k' <= k ->
    shift k 1 (unshift k' 1 M) =
    unshift k' 1 (shift (S k) 1 M).
Proof.
 induction M; intros k k' k'_not_free k'_le_k; simpl in k'_not_free |- *.

 (* Case TmConst *)
          sauto.

 (* Case TmVar *)
         f_equal.
         apply shift_var_unshift_var_commute1; auto.

 (* Case TmPair *)
        rewrite IHM1, IHM2; auto with Listkit.

 (* Case TmProj *)
       f_equal; seauto.

 (* Case TmAbs *)
      rewrite IHM; [auto | | lia].
      contrapose k'_not_free; rename k'_not_free into S_k'_free_in_M.
      apply remove_0_pred_preserves_nonzero_membership; easy.

 (* Case TmApp *)
     rewrite IHM1, IHM2; auto with Listkit.

 (* Case TmNull *)
    sauto.

 (* Case TmSingle *)
   rewrite IHM; solve [auto].

 (* Case TmUnion *)
  rewrite IHM1, IHM2; auto with Listkit.

 (* Case TmBind *)
 rewrite IHM1; auto with Listkit.
 rewrite IHM2; auto with Listkit; try lia.
 contrapose k'_not_free. (* TODO: contrapose should take a name for the new hypothesis. *)
 rename k'_not_free into S_k'_in_fvs_M2.
 apply set_union_intro2.
 apply remove_0_pred_preserves_nonzero_membership; easy.

 (* Case TmIf *)
 (* NB: Listkit doesn't know what to do with a three-way union, so we have to hold its hand. *)
 apply not_in_union_elim in k'_not_free.
 destruct k'_not_free.
 rewrite IHM1, IHM2, IHM3; auto with Listkit.

 (* Case TmTable *)
 sauto.
Qed.

Lemma shift_up_remove_0_pred:
  forall k n xs,
    eq_sets nat
      (set_map Nat.eq_dec pred
        (set_remove nat Nat.eq_dec 0
          (set_map Nat.eq_dec (shift_var (S k) n) xs)))
      (set_map Nat.eq_dec (shift_var k n)
        (set_map Nat.eq_dec pred
          (set_remove nat Nat.eq_dec 0 xs))).
Proof.
  intros.
  replace 0 with (shift_var (S k) n 0) at 1 by solve [auto with Listkit].
  rewrite <- map_remove.
   rewrite set_map_map.
   rewrite set_map_map.
   rewrite set_map_extensionality with (g := (fun x => shift_var k n (pred x))).
    solve [auto with Listkit].
   intros.
   apply shift_var_S_pred.
   apply set_remove_elim in H; tauto.
  intros x y.
  unfold shift_var.
  break; break; lia.
Qed.

Lemma freevars_shift :
  forall M k n,
    eq_sets _
      (freevars (shift k n M))
      (set_map eq_nat_dec (shift_var k n) (freevars M)).
Proof.
 induction M; simpl; intros k n.
 (* Case TmConst *)
          solve [auto with Listkit].

 (* Case TmVar *)
          solve [auto with Listkit].

 (* Case TmPair *)
        rewrite IHM1, IHM2.
        rewrite map_union.
        solve [auto with Listkit].

 (* Case TmProj *)
       solve [eauto with Listkit].

 (* Case TmAbs *)
      rewrite IHM.
      apply shift_up_remove_0_pred.

 (* Case TmApp *)
     rewrite IHM1, IHM2.
     rewrite map_union.
     solve [auto with Listkit].

 (* Case TmNull *)
    solve [trivial with Listkit].

 (* Case TmSingle *)
   solve [auto with Listkit].

 (* Case TmUnion *)
  rewrite IHM1, IHM2.
  rewrite map_union.
  solve [trivial with Listkit].

 (* Case TmBind *)
 rewrite IHM1, IHM2.
 rewrite map_union.
 auto using shift_up_remove_0_pred with Listkit.

 (* Case TmIf *)
 rewrite IHM1, IHM2, IHM3.
 rewrite map_union.
 rewrite map_union.
 solve [trivial with Listkit].

 (* Case TmTable *)
 solve [auto with Listkit].
Qed.

Lemma pred_shift :
  forall x,
      pred (shift_var 0 1 x) = x.
Proof.
 intros.
 unfold shift_var.
 simpl.
 lia.
Qed.

Lemma pred_freevars_shift :
  forall M,
    eq_sets _
      (set_map eq_nat_dec pred (freevars (shift 0 1 M)))
      (freevars M).
Proof.
 intros.
 rewrite freevars_shift.
 rewrite set_map_map.
 apply set_map_idy_ext.
 intros.
 apply pred_shift.
Qed.

Require Import Listkit.All.

Lemma shift_var_range:
  forall x k,
    (fun x => x < k \/ k + 1 <= x) (shift_var k 1 x).
Proof.
 unfold shift_var.
 intros; break; lia.
Qed.

(* TODO: Use outside_range? *)
Lemma shift_freevars_range:
  forall M k,
    all _ (fun x => x < k \/ k + 1 <= x) (freevars (shift k 1 M)).
Proof.
 intros. rewrite freevars_shift.
 unfold all.
 intros.
 apply set_map_elim in H as [a [H1 H2]].
 subst x.
 auto using shift_var_range.
Qed.

Lemma remove_0_shift_0_1:
  forall x,
    eq_sets nat (set_remove nat eq_nat_dec 0 (freevars (shift 0 1 x)))
            (freevars (shift 0 1 x)).
Proof.
 unfold eq_sets, incl_sets.
 split; intros.
  apply set_remove_elim in H.
  tauto.
 apply set_remove_intro.
 intuition.
 apply shift_freevars_range in H.
 lia.
Qed.

Lemma unshift_var_unshift_var_commute:
  forall x k k' n,
    k' <= k ->
    unshift_var k  n (unshift_var    k' 1 x) =
    unshift_var k' 1 (unshift_var (S k) n x).
Proof.
 intros x k k' n H.
 unfold unshift_var at 2 4.
 break; break; unfold unshift_var; break; break; lia.
Qed.

Lemma unshift_unshift_commute:
  forall M k k' n,
    k' <= k ->
    unshift k n (unshift k' 1 M) =
    unshift k' 1 (unshift (S k) n M).
Proof.
 induction M; simpl; intros; try (f_equal; auto).
 - rewrite unshift_var_unshift_var_commute; sauto.
 - apply IHM.
   lia.
 - apply IHM2.
   lia.
Qed.

Lemma shift_var_unshift_var_commute:
  forall x k k' n,
    k' <= k ->
    unshift_var (S k) n (shift_var  k' 1 x) =
    shift_var      k' 1 (unshift_var k n x).
Proof.
 intros x k k' n H.
 unfold unshift_var, shift_var.
 break; break; break; break; lia.
Qed.

Lemma unshift_shift_commute:
  forall M k k' n,
    k' <= k ->
    unshift (S k) n (shift k' 1 M) =
    shift k' 1 (unshift k n M).
Proof.
 induction M; simpl; intros; try (f_equal; auto).
 - rewrite shift_var_unshift_var_commute; sauto.
 - apply IHM.
   lia.
 - apply IHM2.
   lia.
Qed.

Lemma shift_closed_noop_map:
  forall n k vs ts,
    env_typing vs ts
    -> map (shift n k) vs = vs.
Proof.
 induction vs as [|a vs]; simpl; intros.
  auto.
 destruct ts; simpl in *; try (destruct H; discriminate).
 apply env_typing_elim in H.
 destruct H.
 f_equal.
 - erewrite shift_closed_noop; eauto.
 - eauto.
Qed.


(*|
#########################################
Using local notation inside a Coq theorem
#########################################

:Link: https://stackoverflow.com/q/30270240
|*)

(*|
Question
********

Suppose I want to prove a theorem about an object that is verbose to
spell out, say ``ABCDEFGHIJKLMNOPQRSTUVWXYZ``, such that the
unabbreviated theorem is

.. code-block:: coq

    Theorem verbose :
      prop_1 ABCDEFGHIJKLMNOPQRSTUVWXYZ
      -> prop_2 ABCDEFGHIJKLMNOPQRSTUVWXYZ
      -> prop_3 ABCDEFGHIJKLMNOPQRSTUVWXYZ
      -> prop_4 ABCDEFGHIJKLMNOPQRSTUVWXYZ
      -> prop_5 ABCDEFGHIJKLMNOPQRSTUVWXYZ.

Is there a way to use local notation inside a theorem, so I can
compress it to something like the following?

.. code-block:: coq

    Theorem succinct :
      prop_1 X -> prop_2 X -> prop_3 X -> prop_4 X -> prop_5 X
    where "X" := ABCDEFGHIJKLMNOPQRSTUVWXYZ.

I'd use regular notations if I'm using the verbose term repeatedly,
but for one-off cases it'd be nice if there were something like
``where`` for theorems, so I can reuse good names.
|*)

(*|
Answer (Andrew Swann)
*********************

You can use ``Section``\ s and ``Let`` for local definitions.

.. code-block:: coq

    Section thm.

    Let X := ABCDEFGHIJKLMNOPQRSTUVWXYZ.

    Theorem succinct : prop_1 X -> prop_2 X.

    ....

    End thm.
|*)

(*|
Answer (larsr)
**************

You can use ``Definition myobj := ABCDEFGHIJKLMNOPQRSTUVWXYZ.`` to
define a name for the object. Later, you can use ``unfold myobj.`` to
expand the name to its value.

To introduce it into a local proof environment, use ``remember``.
|*)

Require Import ZArith. (* .none *)
Open Scope Z_scope. (* .none *)
Theorem foo :
  forall x y z : Z, x + y - z = x + (y - z).
Proof.
  intros.
  remember (x + y) as bar.

(*| Now the environment is |*)

  Show. (* .unfold .messages *)

(*|
----

**Q:** Maybe the question didn't make it clear, but what I'm looking
for is a notation local to a theorem, so that simple variable names
like ``X`` can be reused without overloading. Your suggestion would
indeed be the best way if the object was used repeatedly across
multiple theorems.

**A:** Inside a proof you can do ``remember (foo + bar + ABDE) as Q.``
|*)


(** * Appendix B: Strong Normalisation à la Girard *)

From Chapter9 Require Export preservation sn_raamsdonk.

(** ** Strong Normalisation *)
Notation sn := (sn (@step _)).
Module SN.

(** *** SN Closure under Weakening *)
Lemma weak k (M: tm k) k' (xi : fin k -> fin k'):
  sn M -> sn (M ⟨xi⟩).
Proof.
  intros H. revert k' xi. induction H as [s H IH]; intros.
  apply SNI. intros s' A.
  destruct (step_naturality A) as (x''&B1&B2); subst.
  now apply IH.
Qed.

End SN.

(** ** The Reducibility Candidates/Logical Predicate*)
Definition cand n := tm n -> Prop.

Fixpoint L {k} (Gamma: ctx k) (T: ty) : cand k :=
  match T with
  |Base => fun M => Gamma |- M : T /\ sn M
  |Fun T1 T2 => fun M => Gamma |- M : Fun T1 T2 /\
                     (forall k' (N: tm k') (Delta: ctx k') xi, ltc Gamma Delta xi -> L Delta T1 N -> L Delta T2 (app (M⟨xi⟩) N))
  end.

Module L.

Lemma ren k k' (Gamma: ctx k) (Delta: ctx k') xi M T (Gamma_Delta : ltc Gamma Delta xi):
  L Gamma T M -> L Delta T (M ⟨xi⟩).
Proof.
  revert k k' Gamma Delta xi M Gamma_Delta.
  induction T; intros; split; eauto; asimpl.
  - apply typing_ren with (Gamma := Gamma); eauto. simpl in H. apply H.
  - apply SN.weak, H.
  - apply typing_ren with (Gamma := Gamma); eauto. apply H.
  - intros. asimpl. eapply H; eauto.
    + intros i. unfold funcomp. rewrite H0. eauto.
Qed.

Lemma L_typing {k} (Gamma: ctx k) (T: ty) M :
  L Gamma T M -> Gamma |- M : T.
Proof. intros H. destruct T; simpl in *; intuition. Qed.

Lemma preservation {k} (Gamma : ctx k) M M' T :
  step M M' -> L Gamma T M -> L Gamma T M'.
Proof.
  revert k Gamma M M'. induction T as [|T IHT S IHS]; intros k Gamma M M' M_M' [H1 H2].
  - split.
    + eauto using preservation.
    + inv H2. now apply H.
  - split; [|].
    + eauto using preservation.
    + intros k' N Delta xi H H0. apply IHS with (M := app (M⟨xi⟩) N).
      * econstructor. substify. now apply step_inst.
      * apply H2; eauto.
Qed.

Lemma preservation_mstep {k} (Gamma : ctx k) M M' T :
  star step M M' -> L Gamma T M -> L Gamma T M'.
Proof. induction 1; eauto using preservation. Qed.

Definition neutral {k} (M: tm k) :=
  match M with
  |lam _ _ => False
  |_ => True
  end.

(** Girard's theorem. *)
Lemma Girard k (Gamma: ctx k) (M : tm k) T :
  (L Gamma T M -> sn M) /\ (Gamma |- M : T -> neutral M -> (forall N, step M N -> L Gamma T N) -> L Gamma T M).
Proof.
  revert k M Gamma. induction T as [|T IHT S IHS]; intros k M Gamma; simpl in *.
  - intuition. constructor. intros N H'. firstorder.
  - split.
    + intros [H1 H2].
      assert ( L (T .: Gamma) S (app (M ⟨↑⟩) (@var_tm (1 + k) None))) as A.
      { apply H2; eauto. intros i; eauto. apply IHT; eauto. constructor. constructor.  intros N H. inv H. }
      revert A. substify. intros A.
      now apply IHS, sn_appL, sn_subst_tm in A.
    + intros H0 H1 H2. split; eauto.
      intros.
      assert (SN_N : sn N) by firstorder.
      induction SN_N as [N sn_N IHN].
      apply IHS; intros; eauto.
      * eapply ty_app.
        -- eapply typing_ren; try eassumption.
        -- auto using L_typing.
      * reflexivity.
      * inv H4.
        -- destruct M; cbn in *; try congruence. contradiction.
        -- destruct (step_naturality H4) as [M'' [H' ->]]. now apply H2.
        -- apply IHN; eauto. eapply preservation; eassumption.
Qed.

Lemma sn k (Gamma: ctx k) (M : tm k) T:
  L Gamma T M -> sn M.
Proof.
  intros H. eapply Girard. eassumption.
Qed.

Lemma var k (Gamma: ctx k) x :
  L Gamma (Gamma x) (ids x).
Proof. apply Girard; intros; eauto. constructor. constructor.  inv H. Qed.

End L.

(** ** Closure under beta expansion and the fundamental theorem *)

Lemma beta_closure k Gamma (N: tm k) T (N_ty : Gamma |- N : T) :
  sn N -> forall S M, (T .: Gamma) |- M : S ->  L Gamma S (M[N..]) -> L Gamma S (app (lam T M) N).
Proof.
  induction 1 as [N H IH_N]. intros S M M_ty H'.
  assert (sn_M := sn_subst_tm _ _ (L.sn _ _ _ _ H')). induction sn_M as [M sn_M IH_M].
  apply L.Girard; eauto.
  - repeat econstructor; eauto.
  - constructor.
  - intros M' H1. inv H1; eauto.
    + inv H1. apply IH_M; eauto using preservation, step_inst, L.preservation, step_naturality.
    + apply IH_N; eauto using preservation, L.preservation_mstep, mstep_beta.
Qed.

Theorem fundamental_theorem k (Gamma: ctx k) M T :
  Gamma |- M : T -> forall k' (Gamma': ctx k') sigma,  (forall x,  L Gamma' (Gamma x) (sigma x)) -> L Gamma' T (M[sigma]).
Proof.
  induction 1 as [| k Gamma T S M H IH | k Gamma T S M N A IHA B IHB]; intros k' Gamma' sigma adm; asimpl.
  - apply adm.
  - cbn. intros.
    assert ( M_ty :  (T .: Gamma') |- (M[ids var_zero .: sigma >> ⟨↑⟩]) : S).
    { assert ( A: forall x, Gamma' |- sigma x : Gamma x) by auto using L.L_typing.
      apply typing_inst with (Gamma := T .: Gamma); eauto.
      intros [i|]; [|constructor]. asimpl. apply typing_ren with (Gamma := Gamma'); eauto. intros x; eauto.  }
    split.
    + now apply ty_abs.
    + intros k'0 N Delta xi A B.
      apply beta_closure; eauto using L.L_typing, L.sn.
      * apply typing_ren with (Gamma := T .: Gamma'); [intros [i|]; simpl; congruence | assumption] .
      * asimpl. apply IH.
        intros [i|]; eauto. cbn. unfold funcomp.
        (* adrian: had to insert the following line *)
        change (fun x : fin k' => @var_tm k'0 (xi x)) with (funcomp var_tm xi).
        renamify. apply L.ren with (Gamma := Gamma'); eauto.
  - destruct (IHA _ _ _ adm) as [IHA1 IHA2]. specialize (IHB _ _ _ adm).
    assert (HH : ltc Gamma' Gamma' id) by now intros.
    specialize (IHA2 _ _ _ id HH IHB). now asimpl in IHA2.
Qed.

Corollary strong_normalisation k (Gamma: ctx k) M T :
  Gamma |- M : T -> sn M.
Proof.
  intros A. apply L.sn with (Gamma := Gamma) (T := T).
  enough (H: L Gamma T  (M[ids])) by now (revert H; asimpl).
  apply fundamental_theorem with (Gamma := Gamma); auto using L.var.
Qed.