Theory SestoftConf

theory SestoftConf
imports Launchbury.Terms Launchbury.Substitution
begin

datatype stack_elem = Alts exp exp | Arg var | Upd var | Dummy var

instantiation stack_elem :: pt
begin
definition  "π ∙ x = (case x of (Alts e1 e2) ⇒ Alts (π ∙ e1) (π ∙ e2) | (Arg v) ⇒ Arg (π ∙ v) | (Upd v) ⇒ Upd (π ∙ v) | (Dummy v) ⇒ Dummy (π ∙ v))"
instance
  by standard (auto simp add: permute_stack_elem_def split:stack_elem.split)
end

lemma Alts_eqvt[eqvt]: "π ∙ (Alts e1 e2) = Alts (π ∙ e1) (π ∙ e2)"
  and Arg_eqvt[eqvt]: "π ∙ (Arg v) = Arg (π ∙ v)"
  and Upd_eqvt[eqvt]: "π ∙ (Upd v) = Upd (π ∙ v)"
  and Dummy_eqvt[eqvt]: "π ∙ (Dummy v) = Dummy (π ∙ v)"
  by (auto simp add: permute_stack_elem_def split:stack_elem.split)

lemma supp_Alts[simp]: "supp (Alts e1 e2) = supp e1 ∪ supp e2" unfolding supp_def by (auto simp add: Collect_imp_eq Collect_neg_eq)
lemma supp_Arg[simp]: "supp (Arg v) = supp v"  unfolding supp_def by auto
lemma supp_Upd[simp]: "supp (Upd v) = supp v"  unfolding supp_def by auto
lemma supp_Dummy[simp]: "supp (Dummy v) = supp v"  unfolding supp_def by auto
lemma fresh_Alts[simp]: "a ♯ Alts e1 e2 = (a ♯ e1 ∧ a ♯ e2)" unfolding fresh_def by auto
lemma fresh_star_Alts[simp]: "a ♯* Alts e1 e2 = (a ♯* e1 ∧ a ♯* e2)" unfolding fresh_star_def by auto
lemma fresh_Arg[simp]: "a ♯ Arg v = a ♯ v" unfolding fresh_def by auto
lemma fresh_Upd[simp]: "a ♯ Upd v = a ♯ v" unfolding fresh_def by auto
lemma fresh_Dummy[simp]: "a ♯ Dummy v = a ♯ v" unfolding fresh_def by auto
lemma fv_Alts[simp]: "fv (Alts e1 e2) = fv e1 ∪ fv e2"  unfolding fv_def by auto
lemma fv_Arg[simp]: "fv (Arg v) = fv v"  unfolding fv_def by auto
lemma fv_Upd[simp]: "fv (Upd v) = fv v"  unfolding fv_def by auto
lemma fv_Dummy[simp]: "fv (Dummy v) = fv v"  unfolding fv_def by auto

instance stack_elem :: fs
  by standard (case_tac x, auto simp add: finite_supp)

type_synonym stack = "stack_elem list"

fun ap :: "stack ⇒ var set" where
  "ap [] = {}"
| "ap (Alts e1 e2 # S) = ap S"
| "ap (Arg x # S) = insert x (ap S)"
| "ap (Upd x # S) = ap S"
| "ap (Dummy x # S) = ap S"
fun upds :: "stack ⇒ var set" where
  "upds [] = {}"
| "upds (Alts e1 e2 # S) = upds S"
| "upds (Upd x # S) = insert x (upds S)"
| "upds (Arg x # S) = upds S"
| "upds (Dummy x # S) = upds S"
fun dummies :: "stack ⇒ var set" where
  "dummies [] = {}"
| "dummies (Alts e1 e2 # S) = dummies S"
| "dummies (Upd x # S) = dummies S"
| "dummies (Arg x # S) = dummies S"
| "dummies (Dummy x # S) = insert x (dummies S)"
fun flattn :: "stack ⇒ var list" where
  "flattn [] = []"
| "flattn (Alts e1 e2 # S) = fv_list e1 @ fv_list e2 @ flattn S"
| "flattn (Upd x # S) = x # flattn S"
| "flattn (Arg x # S) = x # flattn S"
| "flattn (Dummy x # S) = x # flattn S"
fun upds_list :: "stack ⇒ var list" where
  "upds_list [] = []"
| "upds_list (Alts e1 e2 # S) = upds_list S"
| "upds_list (Upd x # S) = x # upds_list S"
| "upds_list (Arg x # S) = upds_list S"
| "upds_list (Dummy x # S) = upds_list S"

lemma set_upds_list[simp]:
  "set (upds_list S) = upds S"
  by (induction S rule: upds_list.induct) auto

lemma ups_fv_subset: "upds S ⊆ fv S"
  by (induction S rule: upds.induct) auto
lemma fresh_distinct_ups: "atom ` V ♯* S ⟹ V ∩ upds S = {}"
   by (auto dest!: fresh_distinct_fv subsetD[OF ups_fv_subset])
lemma ap_fv_subset: "ap S ⊆ fv S"
  by (induction S rule: upds.induct) auto
lemma dummies_fv_subset: "dummies S ⊆ fv S"
  by (induction S rule: dummies.induct) auto

lemma fresh_flattn[simp]: "atom (a::var) ♯ flattn S ⟷ atom a ♯ S"
  by (induction S rule:flattn.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_flattn[simp]: "atom ` (as:: var set) ♯* flattn S ⟷ atom ` as ♯* S"
  by (auto simp add: fresh_star_def)
lemma fresh_upds_list[simp]: "atom a ♯ S ⟹ atom (a::var) ♯ upds_list S"
  by (induction S rule:upds_list.induct) (auto simp add: fresh_Nil fresh_Cons fresh_append fresh_fv[OF finite_fv])
lemma fresh_star_upds_list[simp]: "atom ` (as:: var set) ♯* S ⟹ atom ` (as:: var set) ♯* upds_list S"
  by (auto simp add: fresh_star_def)

lemma upds_append[simp]: "upds (S@S') = upds S ∪ upds S'"
  by (induction S rule: upds.induct) auto
lemma upds_map_Dummy[simp]: "upds (map Dummy l) = {}"
  by (induction l) auto

lemma upds_list_append[simp]: "upds_list (S@S') = upds_list S @ upds_list S'"
  by (induction S rule: upds.induct) auto
lemma upds_list_map_Dummy[simp]: "upds_list (map Dummy l) = []"
  by (induction l) auto

lemma dummies_append[simp]: "dummies (S@S') = dummies S ∪ dummies S'"
  by (induction S rule: dummies.induct) auto
lemma dummies_map_Dummy[simp]: "dummies (map Dummy l) = set l"
  by (induction l) auto

lemma map_Dummy_inj[simp]: "map Dummy l = map Dummy l' ⟷ l = l'"
  apply (induction l arbitrary: l')
  apply (case_tac [!] l')
  apply auto
  done

type_synonym conf = "(heap × exp × stack)"

inductive boring_step where
  "isVal e ⟹ boring_step (Γ, e, Upd x # S)"


fun restr_stack :: "var set ⇒ stack ⇒ stack"
  where "restr_stack V [] = []"
      | "restr_stack V (Alts e1 e2 # S) = Alts e1 e2 # restr_stack V S"
      | "restr_stack V (Arg x # S) = Arg x # restr_stack V S"
      | "restr_stack V (Upd x # S) = (if x ∈ V then Upd x # restr_stack V S else restr_stack V S)"
      | "restr_stack V (Dummy x # S) = Dummy x # restr_stack V S"

lemma restr_stack_cong:
  "(⋀ x. x ∈ upds S ⟹ x ∈ V ⟷ x ∈ V') ⟹ restr_stack V S = restr_stack V' S"
  by (induction V S rule: restr_stack.induct) auto

lemma upds_restr_stack[simp]: "upds (restr_stack V S) = upds S ∩ V"
  by (induction V S rule: restr_stack.induct) auto

lemma fresh_star_restict_stack[intro]:
  "a ♯* S ⟹ a ♯* restr_stack V S"
  by (induction V S rule: restr_stack.induct) (auto simp add: fresh_star_Cons)

lemma restr_stack_restr_stack[simp]:
  "restr_stack V (restr_stack V' S) = restr_stack (V ∩ V') S"
  by (induction V S rule: restr_stack.induct) auto

lemma Upd_eq_restr_stackD:
  assumes "Upd x # S = restr_stack V S'"
  shows "x ∈ V"
  using arg_cong[where f = upds, OF assms]
  by auto
lemma Upd_eq_restr_stackD2:
  assumes "restr_stack V S' = Upd x # S"
  shows "x ∈ V"
  using arg_cong[where f = upds, OF assms]
  by auto


lemma restr_stack_noop[simp]:
  "restr_stack V S = S ⟷ upds S ⊆ V"
  by (induction V S rule: restr_stack.induct)
     (auto dest: Upd_eq_restr_stackD2)
  

subsubsection ‹Invariants of the semantics›

inductive invariant :: "('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ bool) ⇒ bool"
  where "(⋀ x y. rel x y ⟹ I x ⟹ I y) ⟹ invariant rel I"

lemmas invariant.intros[case_names step]

lemma invariantE:
  "invariant rel I ⟹ rel x y ⟹ I x ⟹ I y" by (auto elim: invariant.cases)

lemma invariant_starE:
  "rtranclp rel x y ⟹ invariant rel I ⟹  I x ⟹ I y"
  by (induction rule: rtranclp.induct) (auto elim: invariantE)

lemma invariant_True:
  "invariant rel (λ _. True)"
by (auto intro: invariant.intros)

lemma invariant_conj:
  "invariant rel I1 ⟹ invariant rel I2 ⟹ invariant rel (λ x. I1 x ∧ I2 x)"
by (auto simp add: invariant.simps)


lemma rtranclp_invariant_induct[consumes 3, case_names base step]:
  assumes "r⇧*⇧* a b"
  assumes "invariant r I"
  assumes "I a"
  assumes "P a"
  assumes "(⋀y z. r⇧*⇧* a y ⟹ r y z ⟹ I y ⟹ I z ⟹ P y ⟹ P z)"
  shows "P b"
proof-
  from assms(1,3)
  have "P b" and "I b"
  proof(induction)
    case base
    from ‹P a› show "P a".
    from ‹I a› show "I a".
  next
    case (step y z)
    with ‹I a› have "P y" and "I y" by auto

    from assms(2) ‹r y z› ‹I y›
    show "I z" by (rule invariantE)

    from ‹r⇧*⇧* a y› ‹r y z› ‹I y› ‹I z› ‹P y›
    show "P z" by (rule assms(5))
  qed
  thus "P b" by-
qed


fun closed :: "conf ⇒ bool"
  where "closed (Γ, e, S) ⟷ fv (Γ, e, S) ⊆ domA Γ ∪ upds S"

fun heap_upds_ok where "heap_upds_ok (Γ,S) ⟷ domA Γ ∩ upds S = {} ∧ distinct (upds_list S)"

abbreviation heap_upds_ok_conf :: "conf ⇒ bool"
  where "heap_upds_ok_conf c ≡ heap_upds_ok (fst c, snd (snd c))"

lemma heap_upds_okE: "heap_upds_ok (Γ, S) ⟹ x ∈ domA Γ ⟹ x ∉ upds S"
  by auto

lemma heap_upds_ok_Nil[simp]: "heap_upds_ok (Γ, [])" by auto
lemma heap_upds_ok_app1: "heap_upds_ok (Γ, S) ⟹ heap_upds_ok (Γ,Arg x # S)" by auto
lemma heap_upds_ok_app2: "heap_upds_ok (Γ, Arg x # S) ⟹ heap_upds_ok (Γ, S)" by auto
lemma heap_upds_ok_alts1: "heap_upds_ok (Γ, S) ⟹ heap_upds_ok (Γ,Alts e1 e2 # S)" by auto
lemma heap_upds_ok_alts2: "heap_upds_ok (Γ, Alts e1 e2 # S) ⟹ heap_upds_ok (Γ, S)" by auto

lemma heap_upds_ok_append:
  assumes "domA Δ ∩ upds S = {}"
  assumes "heap_upds_ok (Γ,S)"
  shows "heap_upds_ok (Δ@Γ, S)"
  using assms
  unfolding heap_upds_ok.simps
  by auto

lemma heap_upds_ok_let:
  assumes "atom ` domA Δ ♯* S"
  assumes "heap_upds_ok (Γ, S)"
  shows "heap_upds_ok (Δ @ Γ, S)"
using assms(2) fresh_distinct_fv[OF assms(1)]
by (auto intro: heap_upds_ok_append dest: subsetD[OF ups_fv_subset])

lemma heap_upds_ok_to_stack:
  "x ∈ domA Γ ⟹ heap_upds_ok (Γ, S) ⟹ heap_upds_ok (delete x Γ, Upd x #S)"
  by (auto)

lemma heap_upds_ok_to_stack':
  "map_of Γ x = Some e ⟹ heap_upds_ok (Γ, S) ⟹ heap_upds_ok (delete x Γ, Upd x #S)"
  by (metis Domain.DomainI domA_def fst_eq_Domain heap_upds_ok_to_stack map_of_SomeD)

lemma heap_upds_ok_delete:
  "heap_upds_ok (Γ, S) ⟹ heap_upds_ok (delete x Γ, S)"
  by auto

lemma heap_upds_ok_restrictA:
  "heap_upds_ok (Γ, S) ⟹ heap_upds_ok (restrictA V Γ, S)"
  by auto

lemma heap_upds_ok_restr_stack:
  "heap_upds_ok (Γ, S) ⟹ heap_upds_ok (Γ, restr_stack V S)"
  apply auto
  by (induction V S rule: restr_stack.induct) auto

lemma heap_upds_ok_to_heap:
  "heap_upds_ok (Γ, Upd x # S) ⟹ heap_upds_ok ((x,e) # Γ, S)"
  by auto

lemma heap_upds_ok_reorder:
  "x ∈ domA Γ ⟹ heap_upds_ok (Γ, S) ⟹ heap_upds_ok ((x,e) # delete x Γ, S)"
  by (intro heap_upds_ok_to_heap heap_upds_ok_to_stack)

lemma heap_upds_ok_upd:
"heap_upds_ok (Γ, Upd x # S) ⟹ x ∉ domA Γ ∧ x ∉ upds S"
  by auto


lemmas heap_upds_ok_intros[intro] =
  heap_upds_ok_to_heap heap_upds_ok_to_stack heap_upds_ok_to_stack' heap_upds_ok_reorder
  heap_upds_ok_app1 heap_upds_ok_app2 heap_upds_ok_alts1 heap_upds_ok_alts2 heap_upds_ok_delete
  heap_upds_ok_restrictA heap_upds_ok_restr_stack
  heap_upds_ok_let
lemmas heap_upds_ok.simps[simp del]


end