theory StackConversion
  imports Stack
begin

fun unwind' :: "frame list \<Rightarrow> dexpr \<Rightarrow> dexpr" where
  "unwind' [] e = e"
| "unwind' (FApp1 e\<^sub>2 # s) e = unwind' s (DApp e e\<^sub>2)"
| "unwind' (FApp2 e\<^sub>1 # s) e = unwind' s (DApp e\<^sub>1 e)"
| "unwind' (FReturn # s) e = unwind' s e"

primrec unwind :: "stack_state \<Rightarrow> dexpr" where
  "unwind (SS b s e) = unwind' s e"

theorem typesafed [simp]: "\<Sigma> :\<^sub>s t \<Longrightarrow> [] \<turnstile>\<^sub>d unwind \<Sigma> : t"
  by (induction \<Sigma> t rule: typecheck_stack_state.induct) simp_all

lemma [simp]: "s : t' \<rightarrow> t \<Longrightarrow> e \<leadsto>\<^sub>d e' \<Longrightarrow> unwind' s e \<leadsto>\<^sub>d unwind' s e'"
  by (induction s t' t arbitrary: e e' rule: typecheck_stack.induct) simp_all

theorem correctd: "\<Sigma> \<leadsto>\<^sub>s \<Sigma>' \<Longrightarrow> \<Sigma> :\<^sub>s t \<Longrightarrow> iter (\<leadsto>\<^sub>d) (unwind \<Sigma>) (unwind \<Sigma>')"
proof (induction \<Sigma> \<Sigma>' rule: evals.induct)
  case (evs_app3 t\<^sub>1 e\<^sub>1 s e\<^sub>2)
  then obtain t\<^sub>2 where "(s : t\<^sub>2 \<rightarrow> t) \<and> vald e\<^sub>2" by blast
  moreover hence "DApp (DLam t\<^sub>1 e\<^sub>1) e\<^sub>2 \<leadsto>\<^sub>d substd 0 e\<^sub>2 e\<^sub>1" by simp
  ultimately have "unwind' s (DApp (DLam t\<^sub>1 e\<^sub>1) e\<^sub>2) \<leadsto>\<^sub>d unwind' s (substd 0 e\<^sub>2 e\<^sub>1)" by auto
  thus ?case by simp
qed simp_all

primrec all_returns :: "frame list \<Rightarrow> bool" where
  "all_returns [] = True"
| "all_returns (r # rs) = (r = FReturn \<and> all_returns rs)"

lemma unwind_returns [elim]: "all_returns sr \<Longrightarrow> unwind' sr e = e"
  by (induction sr) (simp_all add: all_returns_def)

lemma [dest]: "FApp1 e # sr : t' \<rightarrow> t \<Longrightarrow> all_returns sr \<Longrightarrow>
    (\<And>t\<^sub>1. t' = Arrow t\<^sub>1 t \<Longrightarrow> [] \<turnstile>\<^sub>d e : t\<^sub>1 \<Longrightarrow> P) \<Longrightarrow> P"
  by (induction sr) fastforce+

lemma [dest]: "FApp2 e # sr : t' \<rightarrow> t \<Longrightarrow> all_returns sr \<Longrightarrow>
    ([] \<turnstile>\<^sub>d e : Arrow t' t \<Longrightarrow> vald e \<Longrightarrow> P) \<Longrightarrow> P"
  by (induction sr) fastforce+

lemma [dest]: "sr @ s : t' \<rightarrow> t \<Longrightarrow> all_returns sr \<Longrightarrow> (s : t' \<rightarrow> t \<Longrightarrow> P) \<Longrightarrow> P"
  by (induction sr) fastforce+

lemma [dest]: "DApp e\<^sub>1 e\<^sub>2 = unwind' s e \<Longrightarrow> (all_returns s \<and> e = DApp e\<^sub>1 e\<^sub>2) \<or>
  (\<exists>s' sr. all_returns sr \<and> ((s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e) \<or>
    (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e)))"
proof (induction s e rule: unwind'.induct)
  case (2 e\<^sub>2' s e)
  thus ?case
  proof (cases "all_returns s \<and> DApp e e\<^sub>2' = DApp e\<^sub>1 e\<^sub>2")
    case False
    with 2 obtain s' sr where S: "all_returns sr \<and> ((s = s' @ FApp1 e\<^sub>2 # sr \<and>
      e\<^sub>1 = unwind' s' (DApp e e\<^sub>2')) \<or> (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' (DApp e e\<^sub>2')))"
        by fastforce
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' (DApp e e\<^sub>2')")
      case False
      with S have "all_returns sr \<and> s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' (DApp e e\<^sub>2')" by simp
      moreover hence "FApp1 e\<^sub>2' # s' @ FApp2 e\<^sub>1 # sr = (FApp1 e\<^sub>2' # s') @ FApp2 e\<^sub>1 # sr \<and>
        unwind' s' (DApp e e\<^sub>2') = unwind' (FApp1 e\<^sub>2' # s') e" by simp
      ultimately show ?thesis by blast
    qed fastforce+
  qed fastforce+
next
  case (3 e\<^sub>1' s e)
  thus ?case
  proof (cases "all_returns s \<and> DApp e\<^sub>1' e = DApp e\<^sub>1 e\<^sub>2")
    case False
    with 3 obtain s' sr where S: "all_returns sr \<and> ((s = s' @ FApp1 e\<^sub>2 # sr \<and>
      e\<^sub>1 = unwind' s' (DApp e\<^sub>1' e)) \<or> (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' (DApp e\<^sub>1' e)))"
        by fastforce
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' (DApp e\<^sub>1' e)")
      case False
      with S have "all_returns sr \<and> s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' (DApp e\<^sub>1' e)" by simp
      moreover hence "FApp2 e\<^sub>1' # s' @ FApp2 e\<^sub>1 # sr = (FApp2 e\<^sub>1' # s') @ FApp2 e\<^sub>1 # sr \<and>
        e\<^sub>2 = unwind' (FApp2 e\<^sub>1' # s') e" by simp
      ultimately show ?thesis by blast
    qed fastforce+
  qed fastforce+
next
  case (4 s e)
  thus ?case
  proof (cases "all_returns s \<and> e = DApp e\<^sub>1 e\<^sub>2")
    case False
    with 4 obtain s' sr where S: "all_returns sr \<and> ((s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e) \<or>
      (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e))" by fastforce
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e")
      case False
      with S have "all_returns sr \<and> s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e" by simp
      moreover hence "FReturn # s' @ FApp2 e\<^sub>1 # sr = (FReturn # s') @ FApp2 e\<^sub>1 # sr \<and>
        e\<^sub>2 = unwind' (FReturn # s') e" by simp
      ultimately show ?thesis by blast
    qed fastforce+
  qed fastforce+
qed simp_all

lemma [simp]: "vald v \<Longrightarrow> v = unwind' s e \<Longrightarrow> all_returns s \<and> e = v"
  by (induction s e rule: unwind'.induct) simp_all

lemma [simp]: "vald v \<Longrightarrow> v = unwind \<Sigma> \<Longrightarrow> \<exists>b s. \<Sigma> = SS b s v \<and> all_returns s"
  by (induction \<Sigma>) simp_all

lemma [simp]: "all_returns sr \<Longrightarrow> unwind' (s @ FApp1 e\<^sub>2 # sr) e = DApp (unwind' s e) e\<^sub>2"
  by (induction s e rule: unwind'.induct) auto

lemma [simp]: "all_returns sr \<Longrightarrow> unwind' (s @ FApp2 e\<^sub>1 # sr) e = DApp e\<^sub>1 (unwind' s e)"
  by (induction s e rule: unwind'.induct) auto

lemma eval_returns [simp]: "all_returns sr \<Longrightarrow> vald v \<Longrightarrow> iter (\<leadsto>\<^sub>s) (SS b (sr @ s) v) (SS True s v)"
proof (induction sr arbitrary: b)
  case (Cons a sr)
  hence "iter (\<leadsto>\<^sub>s) (SS b (FReturn # sr @ s) v) (SS True (FReturn # sr @ s) v)" by simp
  hence "iter (\<leadsto>\<^sub>s) (SS b (FReturn # sr @ s) v) (SS True (sr @ s) v)" by simp
  moreover from Cons have "iter (\<leadsto>\<^sub>s) (SS True (sr @ s) v) (SS True s v)" by simp
  ultimately have "iter (\<leadsto>\<^sub>s) (SS b (FReturn # sr @ s) v) (SS True s v)" by (metis iter_append)
  with Cons show ?case by simp
qed simp_all

lemma [simp]: "unwind' s e \<leadsto>\<^sub>d e' \<Longrightarrow> s : t' \<rightarrow> t \<Longrightarrow> [] \<turnstile>\<^sub>d e : tt \<Longrightarrow> (b \<Longrightarrow> vald e) \<Longrightarrow>
  \<exists>b' s' e''. iter (\<leadsto>\<^sub>s) (SS b s e) (SS b' s' e'') \<and> e' = unwind' s' e''"
proof (induction "unwind' s e" e' arbitrary: b s e t tt rule: evald.induct)
  case (evd_app1 e\<^sub>1 e\<^sub>1' e\<^sub>2)
  thus ?case
  proof (cases "all_returns s \<and> e = DApp e\<^sub>1 e\<^sub>2")
    case True
    with evd_app1 have B: "\<not>b" by (cases b) simp_all
    from evd_app1 True obtain t\<^sub>1 where T1: "([] \<turnstile>\<^sub>d e\<^sub>1 : Arrow t\<^sub>1 tt) \<and> ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1)" by blast
    have "[] : t' \<rightarrow> t'" by simp
    with evd_app1 B T1 obtain b' s' e'' where E: "iter (\<leadsto>\<^sub>s) (SS False [] e\<^sub>1) (SS b' s' e'') \<and>
      e\<^sub>1' = unwind' s' e''" by fastforce
    hence "iter (\<leadsto>\<^sub>s) (SS False ([] @ FApp1 e\<^sub>2 # s) e\<^sub>1) (SS b' (s' @ FApp1 e\<^sub>2 # s) e'')"
      by (metis eval_under)
    hence "iter (\<leadsto>\<^sub>s) (SS False (FApp1 e\<^sub>2 # s) e\<^sub>1) (SS b' (s' @ FApp1 e\<^sub>2 # s) e'')" by simp
    hence "iter (\<leadsto>\<^sub>s) (SS False s (DApp e\<^sub>1 e\<^sub>2)) (SS b' (s' @ FApp1 e\<^sub>2 # s) e'')"
      by (metis evs_app1 iter_step)
    with True B E show ?thesis by fastforce
  next
    case False
    with evd_app1 obtain s' sr where S: "all_returns sr \<and>
      ((s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e) \<or>
        (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e))" by fast
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e")
      case True
      with evd_app1 obtain t'' where "(s' : t' \<rightarrow> t'') \<and> (FApp1 e\<^sub>2 # sr : t'' \<rightarrow> t)" by fastforce
      with evd_app1 True obtain b' ss' e'' where S': "iter (\<leadsto>\<^sub>s) (SS b s' e) (SS b' ss' e'') \<and>
        e\<^sub>1' = unwind' ss' e''" by blast
      hence X: "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp1 e\<^sub>2 # sr) e) (SS b' (ss' @ FApp1 e\<^sub>2 # sr) e'')" by simp
      from S S' have "DApp e\<^sub>1' e\<^sub>2 = unwind' (ss' @ FApp1 e\<^sub>2 # sr) e''" by simp
      with True X show ?thesis by blast
    next
      case False
      with S have "s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e" by simp
      with evd_app1 obtain t\<^sub>1 where "(s' : t' \<rightarrow> t\<^sub>1) \<and> (FApp2 e\<^sub>1 # sr : t\<^sub>1 \<rightarrow> t)" by fastforce
      with S have "([] \<turnstile>\<^sub>d e\<^sub>1 : Arrow t\<^sub>1 t) \<and> vald e\<^sub>1" by fastforce
      with evd_app1 show ?thesis by (metis val_no_evald)
    qed
  qed
next
  case (evd_app2 e\<^sub>1 e\<^sub>2 e\<^sub>2')
  thus ?case
  proof (cases "all_returns s \<and> e = DApp e\<^sub>1 e\<^sub>2")
    case True
    with evd_app2 have B: "\<not>b" by (cases b) simp_all
    from evd_app2 True obtain t\<^sub>1 where T: "([] \<turnstile>\<^sub>d e\<^sub>1 : Arrow t\<^sub>1 tt) \<and> ([] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1)" by blast
    with evd_app2 B obtain b' s' e'' where E: "iter (\<leadsto>\<^sub>s) (SS False [] e\<^sub>2) (SS b' s' e'') \<and>
      e\<^sub>2' = unwind' s' e''" by (metis unwind'.simps(1) tcs_nil)
    hence "iter (\<leadsto>\<^sub>s) (SS False (FApp2 e\<^sub>1 # s) e\<^sub>2) (SS b' (s' @ FApp2 e\<^sub>1 # s) e'')"
      by (metis eval_under append_Nil)
    moreover have "SS False s (DApp e\<^sub>1 e\<^sub>2) \<leadsto>\<^sub>s SS False (FApp1 e\<^sub>2 # s) e\<^sub>1" by simp
    moreover from evd_app2 have "iter (\<leadsto>\<^sub>s) (SS False (FApp1 e\<^sub>2 # s) e\<^sub>1) (SS True (FApp1 e\<^sub>2 # s) e\<^sub>1)"
      by simp
    moreover have "SS True (FApp1 e\<^sub>2 # s) e\<^sub>1 \<leadsto>\<^sub>s SS False (FApp2 e\<^sub>1 # s) e\<^sub>2" by simp
    ultimately have "iter (\<leadsto>\<^sub>s) (SS False s (DApp e\<^sub>1 e\<^sub>2)) (SS b' (s' @ FApp2 e\<^sub>1 # s) e'')"
      by (metis iter_step iter_append)
    with True B E show ?thesis by fastforce
  next
    case False
    with evd_app2 obtain s' sr where S: "all_returns sr \<and>
      ((s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e) \<or>
        (s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e))" by blast
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> e\<^sub>1 = unwind' s' e")
      case True
      with evd_app2 have S': "all_returns s' \<and> e = e\<^sub>1" by simp
      with evd_app2 True S obtain t\<^sub>1 where T: "t' = Arrow t\<^sub>1 t \<and> [] \<turnstile>\<^sub>d e\<^sub>2 : t\<^sub>1" by blast
      have X: "e\<^sub>2 = unwind' [] e\<^sub>2" by simp
      have E: "[] : t' \<rightarrow> t'" by simp
      have "False \<Longrightarrow> vald e\<^sub>2" by simp
      with evd_app2 T X E obtain b'' s'' e'' where E: "iter (\<leadsto>\<^sub>s) (SS False [] e\<^sub>2) (SS b'' s'' e'') \<and>
        e\<^sub>2' = unwind' s'' e''" by blast
      hence "iter (\<leadsto>\<^sub>s) (SS False (FApp2 e\<^sub>1 # sr) e\<^sub>2) (SS b'' (s'' @ FApp2 e\<^sub>1 # sr) e'')"
        using eval_under by fastforce
      moreover from evd_app2 have "SS True (FApp1 e\<^sub>2 # sr) e\<^sub>1 \<leadsto>\<^sub>s SS False (FApp2 e\<^sub>1 # sr) e\<^sub>2" by simp
      moreover from evd_app2 S' have "iter (\<leadsto>\<^sub>s) (SS True (s' @ FApp1 e\<^sub>2 # sr) e\<^sub>1)
        (SS True (FApp1 e\<^sub>2 # sr) e\<^sub>1)" by simp
      moreover from evd_app2 S' have "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp1 e\<^sub>2 # sr) e\<^sub>1)
        (SS True (s' @ FApp1 e\<^sub>2 # sr) e\<^sub>1)" by simp
      ultimately have Y: "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp1 e\<^sub>2 # sr) e\<^sub>1)
        (SS b'' (s'' @ FApp2 e\<^sub>1 # sr) e'')" by (metis iter_step iter_append)
      from S E have "DApp e\<^sub>1 e\<^sub>2' = unwind' (s'' @ FApp2 e\<^sub>1 # sr) e''" by simp
      with True S' Y show ?thesis by auto
    next
      case False
      with S have S': "s = s' @ FApp2 e\<^sub>1 # sr \<and> e\<^sub>2 = unwind' s' e" by simp
      with evd_app2 obtain t\<^sub>1 where "(s' : t' \<rightarrow> t\<^sub>1) \<and> (FApp2 e\<^sub>1 # sr : t\<^sub>1 \<rightarrow> t)" by fastforce
      with evd_app2 S' obtain b'' s'' e'' where E: "iter (\<leadsto>\<^sub>s) (SS b s' e) (SS b'' s'' e'') \<and>
        e\<^sub>2' = unwind' s'' e''" by blast
      hence "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp2 e\<^sub>1 # sr) e) (SS b'' (s'' @ FApp2 e\<^sub>1 # sr) e'')" by simp
      with S S' E show ?thesis by fastforce
    qed
  qed
next
  case (evd_app3 e\<^sub>2 t\<^sub>1 e\<^sub>1)
  thus ?case
  proof (cases "all_returns s \<and> e = DApp (DLam t\<^sub>1 e\<^sub>1) e\<^sub>2")
    case True
    with evd_app3 have B: "\<not>b" by (cases b) simp_all
    have "SS False s (DApp (DLam t\<^sub>1 e\<^sub>1) e\<^sub>2) \<leadsto>\<^sub>s SS False (FApp1 e\<^sub>2 # s) (DLam t\<^sub>1 e\<^sub>1)" by simp
    moreover have "SS False (FApp1 e\<^sub>2 # s) (DLam t\<^sub>1 e\<^sub>1) \<leadsto>\<^sub>s SS True  (FApp1 e\<^sub>2 # s) (DLam t\<^sub>1 e\<^sub>1)"
      by simp
    moreover have "SS True (FApp1 e\<^sub>2 # s) (DLam t\<^sub>1 e\<^sub>1) \<leadsto>\<^sub>s SS False (FApp2 (DLam t\<^sub>1 e\<^sub>1) # s) e\<^sub>2"
      by simp
    moreover from evd_app3 have "iter (\<leadsto>\<^sub>s) (SS False (FApp2 (DLam t\<^sub>1 e\<^sub>1) # s) e\<^sub>2)
      (SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # s) e\<^sub>2)" by simp
    moreover have "SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # s) e\<^sub>2 \<leadsto>\<^sub>s SS False (FReturn # s) (substd 0 e\<^sub>2 e\<^sub>1)"
      by simp
    ultimately have X: "iter (\<leadsto>\<^sub>s) (SS False s (DApp (DLam t\<^sub>1 e\<^sub>1) e\<^sub>2))
      (SS False (FReturn # s) (substd 0 e\<^sub>2 e\<^sub>1))" by (metis iter_step iter_refl iter_append)
    from True have "substd 0 e\<^sub>2 e\<^sub>1 = unwind' (FReturn # s) (substd 0 e\<^sub>2 e\<^sub>1)"
      using unwind_returns by simp
    with True B X show ?thesis by fastforce
  next
    case False
    with evd_app3 obtain s' sr where S: "all_returns sr \<and>
      ((s = s' @ FApp1 e\<^sub>2 # sr \<and> DLam t\<^sub>1 e\<^sub>1 = unwind' s' e) \<or>
        (s = s' @ FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr \<and> e\<^sub>2 = unwind' s' e))" by blast
    thus ?thesis
    proof (cases "s = s' @ FApp1 e\<^sub>2 # sr \<and> DLam t\<^sub>1 e\<^sub>1 = unwind' s' e")
      case True
      moreover have "vald (DLam t\<^sub>1 e\<^sub>1)" by simp
      ultimately have S': "all_returns s' \<and> e = DLam t\<^sub>1 e\<^sub>1" by simp
      have "SS True (FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1) \<leadsto>\<^sub>s SS False (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2" by simp
      moreover from evd_app3 have "iter (\<leadsto>\<^sub>s) (SS False (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)
        (SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)" by simp
      moreover from evd_app3 have "SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2 \<leadsto>\<^sub>s
        SS False (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1)" by simp
      moreover from S' have "iter (\<leadsto>\<^sub>s) (SS True (s' @ FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1))
        (SS True (FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1))" by simp
      moreover have "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1))
        (SS True (s' @ FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1))" by simp
      ultimately have X: "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp1 e\<^sub>2 # sr) (DLam t\<^sub>1 e\<^sub>1))
        (SS False (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1))" by (metis iter_step iter_refl iter_append)
      from S True have "substd 0 e\<^sub>2 e\<^sub>1 = unwind' (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1)"
        using unwind_returns by simp
      with True S' X show ?thesis by fastforce
    next
      case False
      with S evd_app3 have S': "all_returns s' \<and> e = e\<^sub>2" by simp
      from evd_app3 have "SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2 \<leadsto>\<^sub>s
        SS False (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1)" by simp
      hence "iter (\<leadsto>\<^sub>s) (SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)
        (SS False (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1))" by (metis iter_step iter_refl)
      moreover from evd_app3 S' have "iter (\<leadsto>\<^sub>s) (SS True (s' @ FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)
        (SS True (FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)" by simp
      moreover from evd_app3 have "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)
        (SS True (s' @ FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)" by simp
      ultimately have X: "iter (\<leadsto>\<^sub>s) (SS b (s' @ FApp2 (DLam t\<^sub>1 e\<^sub>1) # sr) e\<^sub>2)
        (SS False (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1))" by (metis iter_append)
      from S have "substd 0 e\<^sub>2 e\<^sub>1 = unwind' (FReturn # sr) (substd 0 e\<^sub>2 e\<^sub>1)"
        using unwind_returns by simp
      with S False S' X show ?thesis by metis
    qed
  qed
qed

theorem completed [simp]: "\<Sigma> :\<^sub>s t \<Longrightarrow> unwind \<Sigma> \<leadsto>\<^sub>d e' \<Longrightarrow> \<exists>\<Sigma>'. iter (\<leadsto>\<^sub>s) \<Sigma> \<Sigma>' \<and> e' = unwind \<Sigma>'"
proof (induction \<Sigma> t rule: typecheck_stack_state.induct)
  case (tcs_state s t' t e b)
  then obtain b' s' e'' where "iter (\<leadsto>\<^sub>s) (SS b s e) (SS b' s' e'') \<and> e' = unwind' s' e''" by fastforce
  thus ?case by fastforce
qed

lemma [simp]: "iter (\<leadsto>\<^sub>d) (unwind \<Sigma>) e' \<Longrightarrow> \<Sigma> :\<^sub>s t \<Longrightarrow> \<exists>\<Sigma>'. iter (\<leadsto>\<^sub>s) \<Sigma> \<Sigma>' \<and> e' = unwind \<Sigma>'"
proof (induction "unwind \<Sigma>" e' arbitrary: \<Sigma> rule: iter.induct)
  case (iter_step e' e'')
  moreover then obtain \<Sigma>' where S: "iter (\<leadsto>\<^sub>s) \<Sigma> \<Sigma>' \<and> e' = unwind \<Sigma>'" by fastforce
  moreover with iter_step have "\<Sigma>' :\<^sub>s t" by fastforce
  ultimately obtain \<Sigma>'' where "iter (\<leadsto>\<^sub>s) \<Sigma>' \<Sigma>'' \<and> e'' = unwind \<Sigma>''" by fastforce
  with S have "iter (\<leadsto>\<^sub>s) \<Sigma> \<Sigma>'' \<and> e'' = unwind \<Sigma>''" by (metis iter_append)
  then show ?case by fastforce
qed force+

lemma [simp]: "iter (\<leadsto>\<^sub>d) e v \<Longrightarrow> [] \<turnstile>\<^sub>d e : t \<Longrightarrow> vald v \<Longrightarrow>
  iter (\<leadsto>\<^sub>s) (SS False [FReturn] e) (SS True [] v)"
proof -
  assume "[] \<turnstile>\<^sub>d e : t"
  hence "SS False [FReturn] e :\<^sub>s t" by (metis tcs_nil tcs_cons_ret tcs_state)
  moreover assume "iter (\<leadsto>\<^sub>d) e v"
  ultimately obtain \<Sigma>' where S: "iter (\<leadsto>\<^sub>s) (SS False [FReturn] e) \<Sigma>' \<and> v = unwind \<Sigma>'" by fastforce
  moreover assume V: "vald v"
  ultimately obtain b sr where "\<Sigma>' = SS b (sr @ []) v \<and> all_returns sr" by fastforce
  moreover with V have "iter (\<leadsto>\<^sub>s) \<Sigma>' (SS True [] v)" by (metis eval_returns)
  with S show "iter (\<leadsto>\<^sub>s) (SS False [FReturn] e) (SS True [] v)" by (metis iter_append)
qed

end


theory sse_boolean_algebra
  imports Main
begin

declare[[syntax_ambiguity_warning=false]]
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Shallow embedding of a Boolean algebra of propositions\<close>

text\<open>\noindent{In this section we present a shallow semantical embedding (SSE, cf. @{cite J41} and @{cite J23})
for a family of logics whose semantics is based upon extensions of (complete and atomic) Boolean algebras.
The range of such logics is indeed very wide, including, as we will see, quantified paraconsistent and
paracomplete (e.g. intuitionistic) logics. Aside from illustrating how the SSE approach works in practice
we show how it allows us to effectively harness theorem provers, model finders and `hammers' for reasoning
with quantified non-classical logics. Proof reconstructions have deliberately been avoided.
Most of the proofs (in fact, all one-liners) have been found using Sledgehammer.}\<close>

text\<open>\noindent{Two notions play a fundamental role in this work: propositions and propositional functions.
Propositions, qua sentence denotations, are modeled as objects of type @{text "w\<Rightarrow>bool"} (shortened as @{text "\<sigma>"}).
Propositional functions, as the name indicates, are basically anything with a (parametric) type @{text "'t\<Rightarrow>\<sigma>"}.}\<close>

text\<open>\noindent{We introduce a type @{text "w"} for the domain of points (aka. 'worlds', 'states', etc.).
@{text "\<sigma>"} is a type alias for sets of points (i.e. propositions) encoded as characteristic functions.}\<close>
typedecl w
type_synonym \<sigma> = "w\<Rightarrow>bool"

text\<open>\noindent{In the sequel, we introduce the following naming convention for variables:

(i) Latin letters (A, b, M, P, q, X, y, etc.) denote in general propositions (type @{text "\<sigma>"});
however, we reserve letters D and S to denote sets of propositions (aka. domains/spaces) and
the letters u, v and w to denote worlds/points.

(ii) Greek letters (in particular @{text "\<pi>"}) denote propositional functions (type @{text "'t\<Rightarrow>\<sigma>"});
among the latter we may employ the letters @{text "\<phi>"}, @{text "\<psi>"} and @{text "\<eta>"} to explicitly
name those corresponding to unary connectives/operations (type @{text "\<sigma>\<Rightarrow>\<sigma>"}).}\<close>

subsection \<open>Encoding Boolean operations\<close>

text\<open>\noindent{We start with an ordered algebra,}\<close>
abbreviation sequ::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<approx>" 45) where "A \<^bold>\<approx> B \<equiv> \<forall>w. (A w) \<longleftrightarrow> (B w)"
abbreviation subs::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<preceq>" 45) where "A \<^bold>\<preceq> B \<equiv> \<forall>w. (A w) \<longrightarrow> (B w)"
abbreviation sups::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infixr "\<^bold>\<succeq>" 45) where "B \<^bold>\<succeq> A \<equiv> A \<^bold>\<preceq> B"

text\<open>\noindent{define meet and join by reusing HOL metalogical conjunction and disjunction,}\<close>
definition meet::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<and>" 54) where "A \<^bold>\<and> B \<equiv> \<lambda>w. (A w) \<and> (B w)"
definition join::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<or>" 53) where "A \<^bold>\<or> B \<equiv> \<lambda>w. (A w) \<or> (B w)"

text\<open>\noindent{and introduce further operations to obtain a Boolean 'algebra of propositions'.}\<close>
definition top::"\<sigma>" ("\<^bold>\<top>")    where "\<^bold>\<top> \<equiv> \<lambda>w. True"
definition bottom::"\<sigma>" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
definition impl::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<rightarrow>" 51) where "A \<^bold>\<rightarrow> B \<equiv> \<lambda>w. (A w)\<longrightarrow>(B w)"
definition dimp::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<leftrightarrow>" 51) where "A \<^bold>\<leftrightarrow> B \<equiv> \<lambda>w. (A w)\<longleftrightarrow>(B w)"
definition diff::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<^bold>\<leftharpoonup>" 51) where "A \<^bold>\<leftharpoonup> B \<equiv> \<lambda>w. (A w) \<and> \<not>(B w)"
definition compl::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<midarrow>_" [57]58) where "\<^bold>\<midarrow>A  \<equiv> \<lambda>w. \<not>(A w)"

named_theorems conn (*algebraic connectives*)
declare meet_def[conn] join_def[conn] top_def[conn] bottom_def[conn]
        impl_def[conn] dimp_def[conn] diff_def[conn] compl_def[conn]

text\<open>\noindent{Quite trivially, we can verify that the algebra satisfies some essential lattice properties.}\<close>
lemma "a \<^bold>\<or> a \<^bold>\<approx> a" unfolding conn by simp
lemma "a \<^bold>\<and> a \<^bold>\<approx> a" unfolding conn by simp
lemma "a \<^bold>\<preceq> a \<^bold>\<or> b" unfolding conn by simp
lemma "a \<^bold>\<and> b \<^bold>\<preceq> a" unfolding conn by simp
lemma "(a \<^bold>\<and> b) \<^bold>\<or> b \<^bold>\<approx> b" unfolding conn by auto (*absorption 1*)
lemma "a \<^bold>\<and> (a \<^bold>\<or> b) \<^bold>\<approx> a" unfolding conn by auto (*absorption 2*)
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> c \<Longrightarrow> a \<^bold>\<or> b \<^bold>\<preceq> c" unfolding conn by simp
lemma "c \<^bold>\<preceq> a \<Longrightarrow> c \<^bold>\<preceq> b \<Longrightarrow> c \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
lemma "a \<^bold>\<preceq> b \<equiv> (a \<^bold>\<or> b) \<^bold>\<approx> b" unfolding conn by smt
lemma "b \<^bold>\<preceq> a \<equiv> (a \<^bold>\<and> b) \<^bold>\<approx> b" unfolding conn by smt
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> d \<Longrightarrow> (a \<^bold>\<or> b) \<^bold>\<preceq> (c \<^bold>\<or> d)" unfolding conn by simp
lemma "a \<^bold>\<preceq> c \<Longrightarrow> b \<^bold>\<preceq> d \<Longrightarrow> (a \<^bold>\<and> b) \<^bold>\<preceq> (c \<^bold>\<and> d)" unfolding conn by simp

subsection \<open>Second-order operations and fixed-points\<close>

text\<open>\noindent{We define equality for propositional functions as follows.}\<close>
definition equal_op::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>bool" (infix "\<^bold>\<equiv>" 60) where "\<phi> \<^bold>\<equiv> \<psi> \<equiv> \<forall>X. \<phi> X \<^bold>\<approx> \<psi> X"

text\<open>\noindent{Moreover, we define some useful Boolean (2nd-order) operations on propositional functions,}\<close>
abbreviation unionOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" (infixr "\<^bold>\<squnion>" 61) where "\<phi> \<^bold>\<squnion> \<psi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<or> \<psi> X"
abbreviation interOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" (infixr "\<^bold>\<sqinter>" 62) where "\<phi> \<^bold>\<sqinter> \<psi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<and> \<psi> X"
abbreviation compOp::"('t\<Rightarrow>\<sigma>)\<Rightarrow>('t\<Rightarrow>\<sigma>)" ("(_\<^sup>c)") where "\<phi>\<^sup>c \<equiv> \<lambda>X. \<^bold>\<midarrow>\<phi> X"
text\<open>\noindent{some of them explicitly targeting operations,}\<close>
definition dual::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("(_\<^sup>d)") where "\<phi>\<^sup>d \<equiv> \<lambda>X. \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>X))"
text\<open>\noindent{and also define an useful operation (for technical purposes).}\<close>
definition id::"\<sigma>\<Rightarrow>\<sigma>" ("id") where "id A \<equiv> A"

text\<open>\noindent{We now prove some useful lemmas (some of them may help the provers in their hard work).}\<close>
lemma comp_symm: "\<phi>\<^sup>c = \<psi> \<Longrightarrow> \<phi> = \<psi>\<^sup>c" unfolding conn by blast
lemma comp_invol: "\<phi>\<^sup>c\<^sup>c = \<phi>" unfolding conn by blast
lemma dual_symm: "(\<phi> \<equiv> \<psi>\<^sup>d) \<Longrightarrow> (\<psi> \<equiv> \<phi>\<^sup>d)" unfolding dual_def conn by simp
lemma dual_comp: "\<phi>\<^sup>d\<^sup>c = \<phi>\<^sup>c\<^sup>d" unfolding dual_def by simp

lemma "id\<^sup>d \<^bold>\<equiv> id"  by (simp add: id_def dual_def equal_op_def conn)
lemma "id\<^sup>c \<^bold>\<equiv> compl"  by (simp add: id_def dual_def equal_op_def conn)
lemma "(A \<^bold>\<squnion> B)\<^sup>d \<^bold>\<equiv> (A\<^sup>d) \<^bold>\<sqinter> (B\<^sup>d)" by (simp add: dual_def equal_op_def conn)
lemma "(A \<^bold>\<squnion> B)\<^sup>c \<^bold>\<equiv> (A\<^sup>c) \<^bold>\<sqinter> (B\<^sup>c)" by (simp add: equal_op_def conn)
lemma "(A \<^bold>\<sqinter> B)\<^sup>d \<^bold>\<equiv> (A\<^sup>d) \<^bold>\<squnion> (B\<^sup>d)" by (simp add: dual_def equal_op_def conn)
lemma "(A \<^bold>\<sqinter> B)\<^sup>c \<^bold>\<equiv> (A\<^sup>c) \<^bold>\<squnion> (B\<^sup>c)" by (simp add: equal_op_def conn)

text\<open>\noindent{The notion of a fixed point is a fundamental one. We speak of propositions being fixed points of
operations. For a given operation we define in the usual way a fixed-point predicate for propositions.}\<close>
abbreviation fixedpoint::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>bool)" ("fp") where "fp \<phi> \<equiv> \<lambda>X. \<phi> X \<^bold>\<approx> X"

text\<open>\noindent{Indeed, we can 'operationalize' this predicate by defining a fixed-point operator as follows:}\<close>
abbreviation fixedpoint_op::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("(_\<^sup>f\<^sup>p)") where "\<phi>\<^sup>f\<^sup>p  \<equiv> \<lambda>X. (\<phi> X) \<^bold>\<leftrightarrow> X"

lemma ofp_c: "(\<phi>\<^sup>c)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>c" unfolding conn equal_op_def by auto
lemma ofp_d: "(\<phi>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>d\<^sup>c" unfolding dual_def equal_op_def conn by auto
lemma ofp_dc:"(\<phi>\<^sup>d\<^sup>c)\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>f\<^sup>p)\<^sup>d" unfolding dual_def equal_op_def conn by auto
lemma ofp_decomp: "\<phi>\<^sup>f\<^sup>p \<^bold>\<equiv> (id \<^bold>\<sqinter> \<phi>) \<^bold>\<squnion> ((id \<^bold>\<squnion> \<phi>)\<^sup>c)" unfolding equal_op_def id_def conn by auto
lemma ofp_invol: "(\<phi>\<^sup>f\<^sup>p)\<^sup>f\<^sup>p \<^bold>\<equiv> \<phi>" unfolding conn equal_op_def by auto

text\<open>\noindent{Fixed-point predicate and fixed-point operator are closely related.}\<close>
lemma fp_rel: "((fp \<phi>) X) = (\<phi>\<^sup>f\<^sup>p X \<^bold>\<approx> \<^bold>\<top>)" unfolding conn by auto
lemma fp_d_rel:  "((fp \<phi>\<^sup>d) X) = (\<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>X) \<^bold>\<approx> \<^bold>\<top>)" unfolding dual_def conn by auto
lemma fp_c_rel: "((fp \<phi>\<^sup>c) X) = (\<phi>\<^sup>f\<^sup>p  X  \<^bold>\<approx> \<^bold>\<bottom>)" unfolding conn by auto
lemma fp_dc_rel: "((fp \<phi>\<^sup>d\<^sup>c) X) = (\<phi>\<^sup>f\<^sup>p(\<^bold>\<midarrow>X) \<^bold>\<approx> \<^bold>\<bottom>)" unfolding dual_def conn by auto

subsection \<open>Equality and atomicity\<close>

text\<open>\noindent{We prove some facts about equality (which may help improve prover's performance).}\<close>
lemma eq_ext: "a \<^bold>\<approx> b \<Longrightarrow>  a = b" using ext by blast
lemma eq_ext': "a \<^bold>\<equiv> b \<Longrightarrow>  a = b" using ext unfolding equal_op_def by blast
lemma meet_char: "a \<^bold>\<preceq> b \<longleftrightarrow> a \<^bold>\<and> b \<^bold>\<approx> a" unfolding conn by blast
lemma join_char: "a \<^bold>\<preceq> b \<longleftrightarrow> a \<^bold>\<or> b \<^bold>\<approx> b" unfolding conn  by blast

text\<open>\noindent{We can verify indeed that the algebra is atomic (in three different ways) by relying on the
presence of primitive equality in HOL. A more general class of Boolean algebras could in principle
be obtained in systems without primitive equality or by suitably restricting quantification over
propositions (e.g. defining a topology and restricting quantifiers to open/closed sets).}\<close>
definition "atom a \<equiv> \<not>(a \<^bold>\<approx> \<^bold>\<bottom>) \<and> (\<forall>p. a \<^bold>\<preceq> p \<or> a \<^bold>\<preceq> \<^bold>\<midarrow>p)"
lemma atomic1: "\<forall>w. \<exists>q. q w \<and> (\<forall>p. p w \<longrightarrow> q \<^bold>\<preceq> p)" using the_sym_eq_trivial by (metis (full_types))
lemma atomic2: "\<forall>w. \<exists>q. q w \<and> atom(q)" using the_sym_eq_trivial by (metis (full_types) atom_def compl_def bottom_def)
lemma atomic3: "\<forall>p. \<not>(p \<^bold>\<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p)" proof - (*using atom_def unfolding conn by fastforce*)
  { fix p
    { assume "\<not>(p \<^bold>\<approx> \<^bold>\<bottom>)"
      hence "\<exists>v. p v" unfolding conn by simp
      then obtain w where 1:"p w" by (rule exE)
      let ?q="\<lambda>v. v = w" (*using HOL primitive equality*)
      have 2: "atom ?q" unfolding atom_def unfolding conn by simp
      have "\<forall>v. ?q v \<longrightarrow> p v" using 1 by simp
      hence 3: "?q \<^bold>\<preceq> p" by simp
      from 2 3 have "\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p" by blast
    } hence "\<not>(p \<^bold>\<approx> \<^bold>\<bottom>) \<longrightarrow> (\<exists>q. atom(q) \<and> q \<^bold>\<preceq> p)" by (rule impI)
  } thus ?thesis by (rule allI)
qed

end


theory E2_8
  imports Main
begin

fun intersperse :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "intersperse a [] = []" |
  "intersperse a [x] = [x]" |
  "intersperse a (x # xs) = (x # [a]) @ (intersperse a xs)"

value "intersperse (1::nat) [2, 3, 4]"

lemma "map f (intersperse a xs) = intersperse (f a) (map f xs)"
  apply(induction xs rule: intersperse.induct)
  apply(auto)
  done

end


header "Exact nonstandard semantics"

theory ExCF
  imports HOLCF HOLCFUtils CPSScheme Utils
begin

text {*
We now alter the standard semantics given in the previous section to calculate a control flow graph instead of the return value. At this point, we still ``run'' the program in full, so this is not yet the static analysis that we aim for. Instead, this is the reference for the correctness proof of the static analysis: If an edge is recorded here, we expect it to be found by the static analysis as well.
*}

text {*
In preparation of the correctness proof we change the type of the contour counters. Instead of plain natural numbers as in the previous sections we use lists of labels, remembering at each step which part of the program was just evaluated.

Note that for the exact semantics, this is information is not used in any way and it would have been possible to just use natural numbers again. This is reflected by the preorder instance for the contours which only look at the length of the list, but not the entries.
*}

definition "contour = (UNIV::label list set)"

typedef contour = contour
  unfolding contour_def by auto

definition initial_contour ("\<binit>")
  where "\<binit> = Abs_contour []"

definition nb
  where "nb b c = Abs_contour (c # Rep_contour b)"

instantiation contour :: preorder
begin
definition le_contour_def: "b \<le> b' \<longleftrightarrow> length (Rep_contour b) \<le> length (Rep_contour b')"
definition less_contour_def: "b < b' \<longleftrightarrow> length (Rep_contour b) < length (Rep_contour b')"
instance proof
qed(auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)
end

text {*
Three simple lemmas helping Isabelle to automatically prove statements about contour numbers.
*}

lemma nb_le_less[iff]: "nb b c \<le> b' \<longleftrightarrow> b < b'"
  unfolding nb_def
  by (auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)

lemma nb_less[iff]: "b' < nb b c \<longleftrightarrow> b' \<le> b"
  unfolding nb_def
  by (auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)

declare less_imp_le[where 'a = contour, intro]

text {*
The other types used in our semantics functions have not changed.
*}

type_synonym benv = "label \<rightharpoonup> contour"
type_synonym closure = "lambda \<times> benv"

datatype d = DI int
           | DC closure
           | DP prim
           | Stop

type_synonym venv = "var \<times> contour \<rightharpoonup> d"

text {*
As we do not use the type system to distinguish procedural from non-procedural values, we define a predicate for that.
*}

primrec isProc
  where "isProc (DI _) = False"
      | "isProc (DC _) = True"
      | "isProc (DP _) = True"
      | "isProc Stop   = True"

text {*
To please @{theory HOLCF}, we declare the discrete partial order for our types:
*}

instantiation contour :: discrete_cpo
begin
definition [simp]: "(x::contour) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by default simp
end
instantiation d :: discrete_cpo begin
definition  [simp]: "(x::d) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by default simp
end

instantiation call :: discrete_cpo begin
definition  [simp]: "(x::call) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by default simp
end

text {*
The evaluation function for values has only changed slightly: To avoid worrying about incorrect programs, we return zero when a variable lookup fails. If the labels in the program given are correct, this will not happen. Shivers makes this explicit in Section 4.1.3 by restricting the function domains to the valid programs. This is omitted here.
*}

fun evalV :: "val \<Rightarrow> benv \<Rightarrow> venv \<Rightarrow> d" ("\<A>")
  where "\<A> (C _ i) \<beta> ve = DI i"
  |     "\<A> (P prim) \<beta> ve = DP prim"
  |     "\<A> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> (case ve (var,l) of Some d \<Rightarrow> d | None \<Rightarrow> DI 0)
             | None \<Rightarrow> DI 0)"
  |     "\<A> (L lam) \<beta> ve = DC (lam, \<beta>)"

text {*
To be able to do case analysis on the custom datatypes @{text lambda}, @{text d}, @{text call} and @{text prim} inside a function defined with @{text fixrec}, we need continuity results for them. These are all of the same shape and proven by case analysis on the discriminator.
*}

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_d [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "\<And>y. cont (\<lambda>x. f3 x y)"
    and   "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_d (f1 x) (f2 x) (f3 x) (f4 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text {*
Now, our answer domain is not any more the integers, but rather call caches. These are represented as sets containing tuples of call sites (given by their label) and binding environments to the called value. The argument types are unaltered.

In the functions @{text \<F>} and @{text \<C>}, upon every call, a new element is added to the resulting set. The @{text STOP} continuation now ignores its argument and retuns the empty set instead. This corresponds to Figure 4.2 and 4.3 in Shivers' dissertation.
*}

type_synonym ccache = "((label \<times> benv) \<times> d) set"
type_synonym ans = ccache

type_synonym fstate = "(d \<times> d list \<times> venv \<times> contour)"
type_synonym cstate = "(call \<times> benv \<times> venv \<times> contour)"

fixrec   evalF :: "fstate discr \<rightarrow> ans" ("\<F>")
     and evalC :: "cstate discr \<rightarrow> ans" ("\<C>")
  where "\<F>\<cdot>fstate = (case undiscr fstate of
             (DC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = map_upds ve (map (\<lambda>v.(v,b)) vs) as
                     in \<C>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (DP (Plus c),[DI a1, DI a2, cnt],ve,b) \<Rightarrow>
                (if isProc cnt
                 then let b' = nb b c;
                          \<beta>  = [c \<mapsto> b]
                      in \<F>\<cdot>(Discr (cnt,[DI (a1 + a2)],ve,b'))
                        \<union> {((c, \<beta>),cnt)}
                 else \<bottom>)
            | (DP (prim.If ct cf),[DI v, contt, contf],ve,b) \<Rightarrow>
                (if isProc contt \<and> isProc contf
                 then
                  (if v \<noteq> 0
                   then let b' = nb b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<F>\<cdot>(Discr (contt,[],ve,b'))
                            \<union> {((ct, \<beta>),contt)})
                   else let b' = nb b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<F>\<cdot>(Discr (contf,[],ve,b')))
                            \<union> {((cf, \<beta>),contf)})
                 else \<bottom>)
            | (Stop,[DI i],_,_) \<Rightarrow> {}
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<C>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let f' = \<A> f \<beta> ve;
                     as = map (\<lambda>v. \<A> v \<beta> ve) vs;
                     b' = nb b lab
                  in if isProc f'
                     then \<F>\<cdot>(Discr (f',as,ve,b')) \<union> {((lab, \<beta>),f')}
                     else \<bottom>
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = nb b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                    ve' = ve ++ map_of (map (\<lambda>(v,l). ((v,b'), \<A> (L l) \<beta>' ve)) ls)
                 in \<C>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text {*
In preparation of later proofs, we give the cases of the generated induction rule names and also create a large rule to deconstruct the an value of type @{text fstate} into the various cases that were used in the definition of @{text \<F>}.
*}

lemmas evalF_evalC_induct = evalF_evalC.induct[case_names Admissibility Bottom Next]

lemmas cl_cases = prod.exhaust[OF lambda.exhaust, of _ "\<lambda> a _ . a"]
lemmas ds_cases_plus = list.exhaust[
  OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust, of _ _ "\<lambda>_ x _. x",
  OF _ _ d.exhaust, of _ _ "\<lambda>_ _ _ a _. a",
  OF _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ x _. x",
  OF _ _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ _ _ _ x. x"
  ]
lemmas ds_cases_if = list.exhaust[OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust[OF _ list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"], of _ _ "\<lambda>_ x. x"], of _ _ "\<lambda>_ x _. x"]
lemmas ds_cases_stop = list.exhaust[OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust, of _ _ "\<lambda>_ x _. x"]
lemmas fstate_case = prod_cases4[OF d.exhaust, of _ "\<lambda>x _ _ _ . x",
  OF _ cl_cases prim.exhaust, of _ _ "\<lambda> _ _ _ _ a . a" "\<lambda> _ _ _ _ a. a",
  OF _ case_split ds_cases_plus ds_cases_if ds_cases_stop,
  of _ _ "\<lambda>_ as _ _ _ _ _ _ vs _ . length vs = length as" "\<lambda> _ ds _ _ _ _ . ds" "\<lambda> _ ds _ _ _ _ _. ds" "\<lambda> _ ds _ _. ds",
  case_names "x" "Closure" "x" "x"  "x" "x" "Plus" "x" "x" "x" "x" "x" "x" "x" "x"   "x" "x" "If_True" "If_False" "x" "x" "x" "x" "x" "Stop"  "x" "x" "x" "x" "x"]

text {*
The exact semantics of a program again uses @{text \<F>} with properly initialized arguments. For the first two examples, we see that the function works as expected.
*}

definition evalCPS :: "prog \<Rightarrow> ans" ("\<PR>")
  where "\<PR> l = (let ve = empty;
                          \<beta> = empty;
                          f = \<A> (L l) \<beta> ve
                      in  \<F>\<cdot>(Discr (f,[Stop],ve,\<binit>)))"

lemma correct_ex1: "\<PR> ex1 = {((2,[1 \<mapsto> \<binit>]), Stop)}"
unfolding evalCPS_def
by simp

lemma correct_ex2: "\<PR> ex2 = {((2, [1 \<mapsto> \<binit>]), DP (Plus 3)),
                                   ((3, [3 \<mapsto> nb \<binit> 2]),  Stop)}"
unfolding evalCPS_def
by simp

end


theory LastVotingDefs
imports "../HOModel"
begin

section \<open>Verification of the \emph{LastVoting} Consensus Algorithm\<close>

text \<open>
  The \emph{LastVoting} algorithm can be considered as a representation of
  Lamport's Paxos consensus algorithm~\<^cite>\<open>"lamport:part-time"\<close>
  in the Heard-Of model. It is a coordinated algorithm designed to
  tolerate benign failures. Following~\<^cite>\<open>"charron:heardof"\<close>, we formalize
  its proof of correctness in Isabelle, using the framework of theory \<open>HOModel\<close>.
\<close>

subsection \<open>Model of the Algorithm\<close>

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic CHO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm proceeds in \emph{phases} of $4$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
\<close>

definition phase where "phase (r::nat) \<equiv> r div 4"

definition step where "step (r::nat) \<equiv> r mod 4"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * 4) + step r = r"
  by (auto simp add: phase_def step_def)

text \<open>
  The following record models the local state of a process.
\<close>

record 'val pstate =
  x :: 'val                \<comment> \<open>current value held by process\<close>
  vote :: "'val option"    \<comment> \<open>value the process voted for, if any\<close>
  commt :: bool            \<comment> \<open>did the process commit to the vote?\<close>
  ready :: bool            \<comment> \<open>for coordinators: did the round finish successfully?\<close>
  timestamp :: nat         \<comment> \<open>time stamp of current value\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>
  coord\<Phi> :: Proc           \<comment> \<open>coordinator for current phase\<close>

text \<open>
  Possible messages sent during the execution of the algorithm.
\<close>

datatype 'val msg =
  ValStamp "'val" "nat"
| Vote "'val"
| Ack
| Null  \<comment> \<open>dummy message in case nothing needs to be sent\<close>

text \<open>
  Characteristic predicates on messages.
\<close>

definition isValStamp where "isValStamp m \<equiv> \<exists>v ts. m = ValStamp v ts"

definition isVote where "isVote m \<equiv> \<exists>v. m = Vote v"

definition isAck where "isAck m \<equiv> m = Ack"

text \<open>
  Selector functions to retrieve components of messages. These functions
  have a meaningful result only when the message is of an appropriate kind.
\<close>

fun val where
  "val (ValStamp v ts) = v"
| "val (Vote v) = v"

fun stamp where
  "stamp (ValStamp v ts) = ts"

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, all other
  fields are initialized appropriately.
\<close>

definition LV_initState where
  "LV_initState p st crd \<equiv>
     vote st = None
   \<and> \<not>(commt st)
   \<and> \<not>(ready st)
   \<and> timestamp st = 0
   \<and> decide st = None
   \<and> coord\<Phi> st = crd"

text \<open>
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
\<close>

\<comment> \<open>processes from which values and timestamps were received\<close>
definition valStampsRcvd where
  "valStampsRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   {q . \<exists>v ts. msgs q = Some (ValStamp v ts)}"

definition highestStampRcvd where
  "highestStampRcvd msgs \<equiv>
   Max {ts . \<exists>q v. (msgs::Proc \<rightharpoonup> 'val msg) q = Some (ValStamp v ts)}"

text \<open>
  In step 0, each process sends its current \<open>x\<close> and \<open>timestamp\<close>
  values to its coordinator.

  A process that considers itself to be a coordinator updates its
  \<open>vote\<close> field if it has received messages from a majority of processes.
  It then sets its \<open>commt\<close> field to true.
\<close>

definition send0 where
  "send0 r p q st \<equiv>
   if q = coord\<Phi> st then ValStamp (x st) (timestamp st) else Null"

definition next0 where
  "next0 r p st msgs crd st' \<equiv>
      if p = coord\<Phi> st \<and> card (valStampsRcvd msgs) > N div 2
      then (\<exists>p v. msgs p = Some (ValStamp v (highestStampRcvd msgs))
                \<and> st' = st \<lparr> vote := Some v, commt := True \<rparr> )
      else st' = st"

text \<open>
  In step 1, coordinators that have committed send their vote to all
  processes.

  Processes update their \<open>x\<close> and \<open>timestamp\<close> fields if they
  have received a vote from their coordinator.
\<close>

definition send1 where
  "send1 r p q st \<equiv>
   if p = coord\<Phi> st \<and> commt st then Vote (the (vote st)) else Null"

definition next1 where
  "next1 r p st msgs crd st' \<equiv>
   if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
   then st' = st \<lparr> x := val (the (msgs (coord\<Phi> st))), timestamp := Suc(phase r) \<rparr>
   else st' = st"

text \<open>
  In step 2, processes that have current timestamps send an acknowledgement
  to their coordinator.

  A coordinator sets its \<open>ready\<close> field to true if it receives a majority
  of acknowledgements.
\<close>

definition send2 where
  "send2 r p q st \<equiv>
   if timestamp st = Suc(phase r) \<and> q = coord\<Phi> st then Ack else Null"

\<comment> \<open>processes from which an acknowledgement was received\<close>
definition acksRcvd where
  "acksRcvd (msgs :: Proc \<rightharpoonup> 'val msg) \<equiv>
   { q . msgs q \<noteq> None \<and> isAck (the (msgs q)) }"

definition next2 where
  "next2 r p st msgs crd st' \<equiv>
   if p = coord\<Phi> st \<and> card (acksRcvd msgs) > N div 2
   then st' = st \<lparr> ready := True \<rparr>
   else st' = st"

text \<open>
  In step 3, coordinators that are ready send their vote to all processes.

  Processes that received a vote from their coordinator decide on that value.
  Coordinators reset their \<open>ready\<close> and \<open>commt\<close> fields to false.
  All processes reset the coordinators as indicated by the parameter of
  the operator.
\<close>

definition send3 where
  "send3 r p q st \<equiv>
   if p = coord\<Phi> st \<and> ready st then Vote (the (vote st)) else Null"

definition next3 where
  "next3 r p st msgs crd st' \<equiv>
      (if msgs (coord\<Phi> st) \<noteq> None \<and> isVote (the (msgs (coord\<Phi> st)))
       then decide st' = Some (val (the (msgs (coord\<Phi> st))))
       else decide st' = decide st)
   \<and> (if p = coord\<Phi> st
      then \<not>(ready st') \<and> \<not>(commt st')
      else ready st' = ready st \<and> commt st' = commt st)
   \<and> x st' = x st
   \<and> vote st' = vote st
   \<and> timestamp st' = timestamp st
   \<and> coord\<Phi> st' = crd"

text \<open>
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
\<close>

definition LV_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg" where
  "LV_sendMsg (r::nat) \<equiv>
   if step r = 0 then send0 r
   else if step r = 1 then send1 r
   else if step r = 2 then send2 r
   else send3 r"

definition
  LV_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<rightharpoonup> 'val msg)
                       \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> bool"
  where
  "LV_nextState r \<equiv>
   if step r = 0 then next0 r
   else if step r = 1 then next1 r
   else if step r = 2 then next2 r
   else next3 r"

subsection \<open>Communication Predicate for \emph{LastVoting}\<close>

text \<open>
  We now define the communication predicate that will be assumed for the
  correctness proof of the \emph{LastVoting} algorithm.
  The ``per-round'' part is trivial: integrity and agreement are always ensured.

  For the ``global'' part, Charron-Bost and Schiper propose a predicate
  that requires the existence of infinitely many phases \<open>ph\<close> such that:
  \begin{itemize}
  \item all processes agree on the same coordinator \<open>c\<close>,
  \item \<open>c\<close> hears from a strict majority of processes in steps 0 and 2
    of phase \<open>ph\<close>, and
  \item every process hears from \<open>c\<close> in steps 1 and 3 (this is slightly
    weaker than the predicate that appears in~\<^cite>\<open>"charron:heardof"\<close>, but
    obviously sufficient).
  \end{itemize}

  Instead of requiring infinitely many such phases, we only assume the
  existence of one such phase (Charron-Bost and Schiper note that this is enough.)
\<close>

definition
  LV_commPerRd where
  "LV_commPerRd r (HO::Proc HO) (coord::Proc coord) \<equiv> True"

definition
  LV_commGlobal where
  "LV_commGlobal HOs coords \<equiv>
      \<exists>ph::nat. \<exists>c::Proc.
           (\<forall>p. coords (4*ph) p = c)
         \<and> card (HOs (4*ph) c) > N div 2
         \<and> card (HOs (4*ph+2) c) > N div 2
         \<and> (\<forall>p. c \<in> HOs (4*ph+1) p \<inter> HOs (4*ph+3) p)"

subsection \<open>The \emph{LastVoting} Heard-Of Machine\<close>

text \<open>
  We now define the coordinated HO machine for the \emph{LastVoting} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition LV_CHOMachine where
  "LV_CHOMachine \<equiv>
    \<lparr> CinitState = LV_initState,
      sendMsg = LV_sendMsg,
      CnextState = LV_nextState,
      CHOcommPerRd = LV_commPerRd,
      CHOcommGlobal = LV_commGlobal \<rparr>"

abbreviation
  "LV_M \<equiv> (LV_CHOMachine::(Proc, 'val pstate, 'val msg) CHOMachine)"

end


(******
Map implemented using list
Copyright (C) 2020  Ximeng Li

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.
******)

theory "LMap"

imports Main

begin

type_synonym 'a list_map = "(int \<times> 'a) list"

definition lm_get :: "'a list_map \<Rightarrow> int \<Rightarrow> 'a option" where
  "lm_get lm i = (
    let res = filter (\<lambda>(i', a). i' = i) lm in
    if res = [] then None else Some (snd (last res))
   )"

definition lm_dom :: "'a list_map \<Rightarrow> int set" where
  "lm_dom = set \<circ> (map fst)"

lemma in_lm_dom_left: "x \<in> lm_dom mp1 \<Longrightarrow> x \<in> lm_dom (mp1 @ mp2)"
  by (simp add: lm_dom_def)

lemma in_lm_dom_right: "x \<in> lm_dom mp2 \<Longrightarrow> x \<in> lm_dom (mp1 @ mp2)"
  by (simp add: lm_dom_def)

lemma in_lm_dom_n_right: "\<lbrakk> x \<in> lm_dom (mp1 @ mp2); x \<notin> lm_dom mp2 \<rbrakk> \<Longrightarrow> x \<in> lm_dom mp1 "
  by (simp add: lm_dom_def)

lemma lm_get_right0: "lm_get mp x = Some v \<Longrightarrow> lm_get (a # mp) x = Some v"
  using lm_get_def by (smt filter.simps(2) last_ConsR list.distinct(1) option.distinct(1))

lemma lm_get_right: "lm_get mp2 x = Some v \<Longrightarrow> lm_get (mp1 @ mp2) x = Some v"
  using lm_get_def by (smt Nil_is_append_conv filter_append last_appendR option.simps(3))

lemma lm_get_right_effectless0: "x \<notin> lm_dom mp \<Longrightarrow> lm_get (a # mp) x = lm_get [a] x"
proof(induct mp)
  case Nil
  then show ?case by auto
next
  case (Cons a' mp)
  have "x \<noteq> fst a'" using Cons.prems by (simp add: lm_dom_def)
  hence "lm_get (a # a' # mp) x = lm_get (a # mp) x"
    using lm_get_def by (smt filter.simps(2) prod.case_eq_if)
  then show ?case
    by (metis Cons.hyps Cons.prems insert_iff list.map(2) list.set(2) lm_dom_def o_apply)
qed

lemma lm_get_right_effectless: "x \<notin> lm_dom mp2 \<Longrightarrow> lm_get (mp1 @ mp2) x = lm_get mp1 x"
proof(induct mp2)
  case Nil
  then show ?case by auto
next
  case (Cons a' mp2')
  have "x \<noteq> fst a'" using Cons.prems by (simp add: lm_dom_def)
  hence "lm_get (mp1 @ a' # mp2') x = lm_get (mp1 @ mp2') x"
    using lm_get_def by (smt filter.simps(2) filter_append prod.case_eq_if)
  then show ?case
    by (metis Cons.hyps Cons.prems insert_iff list.map(2) list.set(2) lm_dom_def o_apply)
qed

lemma lm_get_in_dom: "x \<in> lm_dom mp \<Longrightarrow> \<exists>v. lm_get mp x = Some v"
proof(induct mp)
case Nil
then show ?case by (simp add: lm_dom_def)
next
  case (Cons a mp)
  thus ?case
  proof(cases "x \<in> lm_dom mp")
    case True
    hence "\<exists>v. lm_get mp x = Some v" by (simp add: Cons.hyps)
    then show ?thesis using lm_get_right0 by metis
  next
    case False
    hence "x = fst a" using Cons.prems by (simp add: lm_dom_def)
    moreover have "lm_get (a # mp) x = lm_get [a] x"
      using lm_get_right_effectless0 False by blast
    ultimately show ?thesis by (simp add: lm_get_def split_beta)
  qed
qed

lemma lm_get_some_in_dom: "lm_get mp x = Some v \<Longrightarrow> x \<in> lm_dom mp"
proof(induct mp arbitrary: v)
  case Nil
  then show ?case by (simp add: lm_get_def)
next
  case (Cons a mp)
  then show ?case
  proof(cases "\<exists>v. lm_get (mp) x = Some v")
    case True
    then obtain v0 where "lm_get mp x = Some v0" by auto
    hence "x \<in> lm_dom mp" using Cons.hyps by auto
    then show ?thesis by (simp add: lm_dom_def)
  next
    case False
    hence "x \<notin> lm_dom mp" using False lm_get_in_dom by blast
    hence "lm_get [a] x = Some v" using lm_get_right_effectless0 by (metis Cons.prems)
    hence "x = fst a" using lm_get_def
      by (smt filter.simps(1) filter.simps(2) option.distinct(1) prod.case_eq_if)
    then show ?thesis by (simp add: lm_dom_def)
  qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3_assoc2
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 (add3 x1 x2 x3) x4 x5) = (add3 x1 (add3 x2 x3 x4) x5))"
  oops

end


theory LanguageSafe
imports Main "../EmbSimpl/Semantic" "../EmbSimpl/HoarePartialDef" "../lib/sep_algebra/Separata"
             "../EmbSimpl/HoarePartialProps"
begin

definition fun_safe:: "('s::heap_sep_algebra \<Rightarrow> 's) \<Rightarrow> bool"
where
"fun_safe f \<equiv> \<forall>h h1 h2 t. t = f h1 \<and> (h1, h2 \<triangleright> h) \<longrightarrow> (t, h2 \<triangleright>(f h))"

definition set_safe:: "('s::heap_sep_algebra \<times> 's) set \<Rightarrow> bool"
where
"set_safe s \<equiv> \<forall>h h1 h2 t.((h1, h2 \<triangleright> h) \<and> (h1,t)\<in>s) \<longrightarrow>
                            t##h2 \<and> (h,t + h2) \<in> s \<and>
                            (\<forall>h'. (h,h')\<in>s \<longrightarrow> h' = (t+h2))"

definition guard_safe::"('s::heap_sep_algebra) set \<Rightarrow> bool"
where
"guard_safe g \<equiv> \<forall>h h1 h2 .(h1, h2 \<triangleright> h) \<and> ((h1\<in>g) \<longrightarrow> h\<in>g) \<and> (h1\<notin>g \<longrightarrow> h\<notin>g)"

definition cond_safe::"('s::heap_sep_algebra) set \<Rightarrow> ('s::heap_sep_algebra) set \<Rightarrow> bool"
where
"cond_safe b P \<equiv>\<forall>s'\<in>P. \<forall>s. s' \<preceq> s  \<longrightarrow> ((s \<in> b) =  (s'\<in>b))"

definition sep_alg_set_plus:: "('s::heap_sep_algebra) set \<Rightarrow> ('s::heap_sep_algebra) set \<Rightarrow> ('s::heap_sep_algebra) set" (infixr "\<Oplus>" 60) where
"A \<Oplus> B \<equiv> undefined"

primrec prog_safe:: "('s::heap_sep_algebra,'p,'f) com \<Rightarrow> ('s::heap_sep_algebra) set \<Rightarrow> 'f set \<Rightarrow> bool"
where
"prog_safe Skip P F = True" |
"prog_safe (Basic g) P F = fun_safe g" |
"prog_safe (Spec r) P F =  set_safe r" |
"prog_safe (Seq c\<^sub>1 c\<^sub>2) P F = (\<exists>P1 P2. P1 \<Oplus> P2 = P \<and> prog_safe c\<^sub>1 P1 F \<and> prog_safe c\<^sub>2 P2 F)" |
"prog_safe (Cond b c\<^sub>1 c\<^sub>2) P F =  (cond_safe b P \<and> prog_safe c\<^sub>1 P F \<and> prog_safe c\<^sub>2 P F)" |
"prog_safe (While b c) P F = (cond_safe b P \<and> prog_safe c P F)" |
"prog_safe (Call p) P F = True"|
"prog_safe (DynCom c) P F =  (\<forall>s. prog_safe (c s) P F)" |
"prog_safe (Guard f' g c) P F = (cond_safe g P \<and> prog_safe c P F)" |
"prog_safe Throw P F = True" |
"prog_safe (Catch c\<^sub>1 c\<^sub>2) P F = (prog_safe c\<^sub>1 P F \<and> prog_safe c\<^sub>2 P F)"

definition prog_env_safe:: "('s,'p,'f) body \<Rightarrow> ('s::heap_sep_algebra,'p,'f) com \<Rightarrow>
('s::heap_sep_algebra) set \<Rightarrow> 'f set \<Rightarrow> bool"
where "prog_env_safe \<Gamma> c I\<^sub>s F \<equiv>
prog_safe c I\<^sub>s F \<and> (\<forall>p c. \<Gamma> p = Some c \<longrightarrow> prog_safe c I\<^sub>s F)"

(*
lemma exec_program_safe_normal:
  assumes a0: "\<Gamma>\<turnstile>\<langle>c,Normal s1\<rangle> \<Rightarrow> Normal t1" and
          a2: "s1,s2 \<triangleright> s" and
          a3: "prog_env_safe \<Gamma> c I F"
     shows "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> Normal (t1+s2) \<and> (t1##s2)"
using a0 a2 a3
proof (induct arbitrary:s s1 s2 t1)
  case (Skip ss)
    then have t1_s1:"t1 = s1"

      sorry
    then have "\<Gamma>\<turnstile>\<langle>Skip,Normal s\<rangle> \<Rightarrow> Normal s" using exec.Skip by fastforce
    then show ?case
      using Skip t1_s1 unfolding tern_rel_def by fastforce
next
  case (Spec s1' t1' r)
  have "(s,t1+s2)\<in>r \<and> t1##s2" using Spec(1) Spec(3) Spec(2) Spec(4)
    unfolding prog_env_safe_def prog_safe.simps(3) set_safe_def
    tern_rel_def by blast
  thus ?case using exec.Spec by auto
next
  case (SpecStuck) thus ?case by auto
next
  case (FaultProp) thus ?case by auto
next
  case (Guard sa g c ta f)
  then have " \<Gamma>\<turnstile> \<langle>c,Normal s\<rangle> \<Rightarrow> Normal (t1 + s2) \<and> t1 ## s2 \<and> s\<in>g"
    unfolding prog_env_safe_def prog_safe.simps(9) guard_safe_def by blast
  thus ?case using exec.Guard by fastforce
next
  case (GuardFault sa g f ta s) thus ?case by auto
next
  case (Basic f sa) thus ?case
    unfolding prog_env_safe_def prog_safe.simps(2) fun_safe_def
              tern_rel_def
    using exec.Basic xstate.inject(1)
    by metis
next
  case (Seq c1 sc1 s' c2 t) thus ?case
   unfolding tern_rel_def prog_env_safe_def prog_safe.simps(4)  sorry
next
  case (CondTrue) thus ?case sorry
next
  case (CondFalse) thus ?case sorry
next
  case (WhileTrue) thus ?case sorry
next
  case (WhileFalse) thus ?case sorry
next
  case (Call) thus ?case sorry
next
  case (CallUndefined) thus ?case sorry
next
  case (StuckProp) thus ?case sorry
next
  case (DynCom) thus ?case sorry
next
  case (Throw) thus ?case sorry
next
  case (CatchMatch) thus ?case sorry
next
  case (CatchMiss) thus ?case sorry
qed (auto)

lemma exec_program_safe_fault:
  assumes a0: "\<Gamma>\<turnstile>\<langle>c,Normal s1\<rangle> \<Rightarrow> Abrupt t1" and
          a1: "t1 \<uplus>\<^sub>s s2" and
          a2: "prog_env_safe \<Gamma> c"
     shows "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> Abrupt (t1+s2)"
sorry

lemma exec_program_safe_Stuck:
  assumes a0: "\<Gamma>\<turnstile>\<langle>c,Normal s1\<rangle> \<Rightarrow> Stuck" and
          a1: "t1 \<uplus>\<^sub>s s2" and
          a2: "prog_env_safe \<Gamma> c"
     shows "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> Stuck"
sorry

lemma exec_program_safe_Fault:
  assumes a0: "\<Gamma>\<turnstile>\<langle>c,Normal s1\<rangle> \<Rightarrow> Fault f" and
          a1: "t1 \<uplus>\<^sub>s s2" and
          a2: "prog_env_safe \<Gamma> c"
     shows "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> Fault f"
sorry

inductive_cases satis_elim_case [cases set]:
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P Seq c1 c2 Q,A"
*)

lemma star_left_lem:"(P ** R) s \<Longrightarrow> \<exists>sp sr. (sp,sr\<triangleright>s) \<and> P sp \<and> R sr"
by separata

lemma "(sp,sr\<triangleright>s) \<Longrightarrow> \<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> = n \<Rightarrow> Normal s' \<Longrightarrow> prog_env_safe \<Gamma> c I F \<Longrightarrow>
\<Gamma>\<turnstile>\<langle>c,Normal sp\<rangle> = n \<Rightarrow> Normal t' \<and>  (t',sr\<triangleright>s')"
sorry

lemma "(sp,sr\<triangleright>s) \<Longrightarrow> \<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> = n \<Rightarrow> Abrupt s' \<Longrightarrow> prog_env_safe \<Gamma> c I F \<Longrightarrow>
\<Gamma>\<turnstile>\<langle>c,Normal sp\<rangle> = n \<Rightarrow> Abrupt t' \<and>  (t',sr\<triangleright>s')"
sorry

lemma prog_env_safe_seq: "prog_env_safe \<Gamma> (Seq c1 c2) I\<^sub>s F \<Longrightarrow>
  prog_env_safe \<Gamma> c1 I\<^sub>s F \<and> prog_env_safe \<Gamma> c2 I\<^sub>s F"
unfolding prog_env_safe_def
by auto

lemma post_cond_safe: "P \<subseteq> I\<^sub>s \<Longrightarrow> \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
(\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A) \<Longrightarrow>
(\<forall>s t. \<Gamma>\<turnstile>\<langle>c,s \<rangle> =n\<Rightarrow> t \<longrightarrow> s \<in> Normal ` P \<longrightarrow> t \<notin> Fault ` F) \<Longrightarrow>
Q \<subseteq> I\<^sub>s"
sorry

(*declare [[show_types]]*)
text {*
  We introduce separation logic as a layer on top of Simpl. Separation Logic needs assertions to be
  restricted by means of the syntax. The most important rule in Separation Logic, the Frame Rule,
  allows to reason on separated resources, allowing to scale verification. The Frame Rule says
  {P} c {Q} \Longarrow {P*R} c {Q*R} where no variable occurring free in R is modified by c.
  Simpl is a language with a minimal syntax, which makes difficult to deploy separation logic in it.
  However, it is possible to add separation logic on top of Simpl adding conditions to the frame
  rule to ensure this (a).
  We use the separation algebra library to model Simpl's separation logic. Using this it is possible
  to have separation on structures like records,  that are not commonly used to represent the
  state in separation logic. If we use the record structure as an example, to be able to consider
  a record as a separation algebra we need that its fields are also separation algebras. Then,
  two variables $r1, r2$ with type record $r$  will be disjoints if for each field $f$ in the $r$
  $f r1$ and $f r2$ are separated. And we consider that $r1$ with type record $r$ is empty ($\<emptyset>$)
  if for each every $f$ in $r$, $f r1 = \<emptyset>$ . Finally we merge (+) two disjoints variables $r1, r2$
  into a new record $rn$ merging every field $f1 \<cdots> fn$ in $r1, r2$, and
  $rn = (| f1= f1 r1 + f1 r2, \<cdots> fn = fn r1 + fn r2 |). However, Simpl rules to change the state
  can modify a field breaking separation (for example, can make $\<emptyset>$ a non-empty field, or vice-verse).
  (b).

  In our specification, we consider a static state, where it is not possible to create or remove
  new variables. It is possible still create dynamic behaviour adding control structures. This is not
  a limitation indeed, since memory is not an infinite resource and we always start from a finite
  set of memory positions. In order to overcome (a) and (b) we need to consider some assumptions.

  For (a), First, we use two predicates $I_t, I_c$ where $I_t$ constrains the state in such a way that all
  its fields are non-empty, and $I_c$ constrains the state to the states where variables in a program
  are accessed are non-empty. Finally we express (a) saying that R has to be included in $I_t - I_c$
  $I_c$ and $I_t$ are part of the specification and can be calculated through program analysis and
  program annotations.

  For (b), we need to use a predicate prog_env_safe, to control that operations changing the state
  does not include new variables. Also, in the case of branches, that the condition of the branch
  does not references variables out of $I_c$ and that can make change the behaviour of the program
  for a bigger state.

  $I_c$ is a nexus between the syntax restricted predicates in original separation logic and
  and the absence of a restricted syntax in Simpl. But we still need some additional information
  about the program and $I_c$. For example, a composed statement c=c1;c2, $I_c$ is the combination
  of $I_c1$ and $I_c2$, which respectively represent the variables invariant in $c1$ and $c2$.
  And it should express that field $f$ is non-empty in $I_c$ if $f$ is non-empty in $I_c1$ or is
  non-empty in $I_c2$. This will also be necessary for other constructors like conditional branching,
  and while, very likely having to include the guard of these statements.
  However, we don't have a way of expressing that since we don't have a syntax.
  To fill this gap, we require that the state has to be of a "domain" class, which provides functions
  to extract the variable domain of a state (e.g., for a record will be the record's fields), and
  to obtain the value of a variable, (perhaps also to set the value). Since in Isabelle/HOL
  functions are not polymorphic, and fields of a record may have different types,
  the function obtaining/setting a value must have a data type collecting the types of a variable.
  It is possible therefore to define an isomorphism between the state and the values of the values
  of variables belonging to the domain of the state (very likely this isomorphism will help in the
  proof of soundness of the frame rule).
*}

lemma frame_safe_program:
  assumes a0: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" and
    a1: "prog_env_safe \<Gamma> c I\<^sub>s F" and
    a2: "\<forall>s t. s\<in>I\<^sub>s \<and> t\<in>I\<^sub>t \<longrightarrow> s \<preceq> t" and
    a3: "R\<subseteq>I\<^sub>t - I\<^sub>s"
  shows "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (fun_set ((set_fun P) \<and>* (set_fun R))) c (fun_set ((set_fun Q) \<and>* (set_fun R))),(fun_set ((set_fun A) \<and>* (set_fun R)))"
proof-
{fix n
 have "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (fun_set ((set_fun P) \<and>* (set_fun R))) c (fun_set ((set_fun Q) \<and>* (set_fun R))),(fun_set ((set_fun A) \<and>* (set_fun R)))"
proof (rule cnvalidI)
  {fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A"
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> (fun_set ((set_fun P) \<and>* (set_fun R)))"
  assume t_notin_F: "t \<notin> Fault ` F"
  obtain st where s_normal: "(st::('b, 'c) xstate)=Normal s" by auto
  then have exec: "\<Gamma>\<turnstile>\<langle>c,st\<rangle> =n\<Rightarrow> t" using exec by auto
  then have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A" using a0 by (simp add: hoare_complete')
  then have a0:"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" using a0 by auto
  obtain sp sr where s_split: "(sp,sr\<triangleright>s) \<and> sp \<in> (fun_set (set_fun P)) \<and> sr \<in> (fun_set (set_fun R))"
    using P star_left_lem by fastforce
  show "t \<in> Normal ` (fun_set ((set_fun Q) \<and>* (set_fun R))) \<union> Abrupt ` (fun_set ((set_fun A) \<and>* (set_fun R)))"
  using exec s_normal P a0 t_notin_F a1 ctxt s_split a2 a3
  proof (induct arbitrary: s P Q A R sp sr)
    case (Skip t n)
    then have t:"t=s" by auto
    then have "\<Gamma>\<turnstile>\<langle>Skip,Normal s\<rangle> =n\<Rightarrow> Normal s" using execn.Skip by fastforce
    obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1,s2\<triangleright>s)"
      using Skip(2)
      by (metis mem_Collect_eq sep_conj_def tern_rel_def)
    then have s1_p: "s1\<in>P" by auto
    have step:"\<Gamma>\<turnstile>\<langle>Skip,Normal s1\<rangle> =n\<Rightarrow> Normal s1"
      using execn.Skip by fastforce
    have s1_notin_f:"Normal s1 \<notin> Fault ` F" by fastforce
    have "Normal s1 \<in> Normal ` Q \<union> Abrupt ` A" using cnvalidD[OF Skip(3)[rule_format] Skip(6) step s1_p s1_notin_f]
      by auto
    then have "s1\<in>Q" by auto
    then show ?case using P_s1 t
      by (metis UnCI image_eqI mem_Collect_eq sep_conj_def tern_rel_def)
  next
    case (Basic f sa n)
    then have t:"sa=s" by auto
    have safe_basic:"\<forall>h h1 h2 t. t = f h1 \<and> (h1,h2\<triangleright>h) \<longrightarrow> (t,h2\<triangleright>(f h))"
      using Basic.prems(5) unfolding prog_env_safe_def prog_safe.simps(2) fun_safe_def by auto
    then obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1,s2\<triangleright>s)" using Basic(2)
        by (metis (full_types) mem_Collect_eq sep_conj_def tern_rel_def)
    then have s1_p:"s1\<in> P " by auto
    then have step:"\<Gamma>\<turnstile>\<langle>Basic f,Normal s1\<rangle>=n\<Rightarrow> Normal (f s1)"
        using execn.Basic P_s1 by meson
    have s1_notin_f:"Normal (f s1) \<notin> Fault ` F" by fastforce
    have "Normal (f s1) \<in> Normal ` Q \<union> Abrupt ` A" using cnvalidD[OF Basic(3)[rule_format] Basic(6) step s1_p s1_notin_f]
      by auto
    then have "(f s1) \<in> Q" by auto
    also have "(f s1)## s2 \<and> ((f s1)+s2 = f s)" using safe_basic P_s1
      by (simp add: tern_rel_def)
    ultimately show ?case using P_s1 t
      unfolding sep_conj_def by fastforce
  next
    case (Spec sa t r n)
    then have step_spec:"\<Gamma>\<turnstile> \<langle>Spec r,Normal s\<rangle> =n\<Rightarrow> Normal t" using execn.Spec by auto
    then obtain tt where tt:"(tt::('b, 'c) xstate)=Normal t" by auto
    then have "sa=s" using Spec by auto
    have safe_spec: "\<forall>h h1 h2 t.((h1,h2\<triangleright>h) \<and> (h1,t)\<in>r) \<longrightarrow>
                            t##h2 \<and> (h,t + h2) \<in> r \<and>
                            (\<forall>h'. (h,h')\<in>r \<longrightarrow> h' = (t+h2))"
      using Spec.prems(5) unfolding prog_env_safe_def prog_safe.simps(3) set_safe_def by auto
    then obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1,s2\<triangleright>s)" using Spec(3)
        by (metis (full_types) mem_Collect_eq sep_conj_def tern_rel_def)
    then have s1_p:"s1\<in> P" by auto
    have "\<exists>t. (s1,t)\<in>r"
    proof -
    {assume "\<forall>t. (s1,t)\<notin>r"
     then have step:"\<Gamma>\<turnstile> \<langle>Spec r,Normal s1\<rangle> =n\<Rightarrow> Stuck" by (fastforce intro: execn.SpecStuck)
     then have Stuck_notin_F:"Stuck\<notin>Fault ` F" by auto
     have False using cnvalidD[OF Spec(4)[rule_format] Spec(7) step s1_p Stuck_notin_F]
       by auto
    } thus ?thesis by auto qed
    then obtain t1 where s1_t1_r:"(s1,t1)\<in>r" by auto
    then have stepp1:"\<Gamma>\<turnstile>\<langle>Spec r,Normal s1\<rangle> =n\<Rightarrow> Normal t1"
      using execn.Spec by fastforce
    then have Normals1_notin_F:"Normal t1\<notin>Fault ` F" by auto
    then have t1_q:"(t1) \<in> Q" using cnvalidD[OF Spec(4)[rule_format] Spec(7) stepp1 s1_p Normals1_notin_F] by auto
    have s_t1_s2_r:"t1##s2 \<and>(s,t1 + s2)\<in> r" using safe_spec P_s1 s1_t1_r
      unfolding tern_rel_def by fastforce
    also then have "\<Gamma>\<turnstile> \<langle>Spec r,Normal s\<rangle> =n\<Rightarrow> Normal (t1+s2)"  by (fastforce intro: execn.Spec)
    ultimately have "tt =Normal (t1+s2)"
      using tt safe_spec step_spec  P_s1 execn_Normal_elim_cases(7) s1_t1_r
       by (metis execn_Normal_elim_cases(7)  tern_rel_def)
    then show ?case
      using tt P_s1 s_t1_s2_r t1_q unfolding  sep_conj_def by fastforce
  next
    case (Seq c1 s1 n s1' c2 t)
    (* then have step_seq:"\<Gamma>\<turnstile> \<langle>Seq c1 c2,Normal s1\<rangle> = n \<Rightarrow> t" using execn.Seq by auto
    have valid:"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P Seq c1 c2 Q,A" using Seq.prems(3) by auto
    then obtain s' where stepc1:"\<Gamma>\<turnstile>\<langle>c1,Normal s\<rangle> =n\<Rightarrow>  s'" and stepc2:"\<Gamma>\<turnstile>\<langle>c2,s'\<rangle> =n\<Rightarrow>  t"
      using Seq.hyps(1) Seq.hyps(3) Seq.prems(1)
      by metis
    obtain s'na where "s' = Normal s'na \<or> s' = Abrupt s'na"
      using valid unfolding cnvalid_def nvalid_def
    then obtain sna where "s' = Normal sna \<or> s' = Abrupt sna"

    then obtain Q' A' where c1valid:"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c1 Q',A'"
    proof -

    qed
    have "s1' \<in> Normal ` {a. ((\<lambda>v. v \<in> Q') \<and>* (\<lambda>v. v \<in> R)) a} \<union> Abrupt ` {a. ((\<lambda>v. v \<in> A') \<and>* (\<lambda>v. v \<in> R)) a}"
    proof-
      have "s1' \<notin> Fault ` F" using c1valid Seq(10) Seq(1) unfolding cnvalid_def cvalid_def nvalid_def
        apply simp
        sorry
      then show ?thesis using Seq(2)[OF Seq(5) Seq(6) c1valid] sorry
    qed *)
    have safe1: "prog_env_safe \<Gamma> c1 I\<^sub>s F" and safe2: "prog_env_safe \<Gamma> c2 I\<^sub>s F"
      using Seq(9) prog_env_safe_seq apply blast
      using Seq(9) prog_env_safe_seq by blast
    obtain I A' where small_state_exec1: "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c1 I,A'" sorry
    obtain si where inter_big_state: "s1' = Normal si" sorry
    then have inter_big_cond: "si \<in> {a. ((\<lambda>v. v \<in> I) \<and>* (\<lambda>v. v \<in> R)) a}" sorry
    then obtain si' where inter_big_cond_tern: "(si',sr\<triangleright>si) \<and> si' \<in> {\<sigma>. \<sigma> \<in> I} \<and> sr \<in> {\<sigma>. \<sigma> \<in> R}" sorry
    then have small_state_exec2: "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> I c2 Q,A" sorry
    have inter_cond_safe: "I \<subseteq> I\<^sub>s" sorry
    show ?case using Seq(4)[OF inter_big_state inter_big_cond small_state_exec2 Seq(8)
      safe2 Seq(10) inter_big_cond_tern Seq(12) inter_cond_safe Seq(14)] by auto
  next
    case Guard thus ?case sorry
  next
    case GuardFault thus ?case sorry
  next
    case FaultProp thus ?case sorry
  next
    case SpecStuck thus ?case sorry
  next
    case (CondTrue sa b c1 n t c2) thus ?case sorry
  next
    case CondFalse thus ?case sorry
  next
    case WhileTrue thus ?case sorry
  next
    case WhileFalse thus ?case sorry
  next
    case Call thus ?case sorry
  next
    case CallUndefined thus ?case sorry
  next
    case StuckProp thus ?case sorry
  next
    case DynCom thus ?case sorry
  next
    case Throw thus ?case sorry
  next
    case AbruptProp thus ?case sorry
  next
    case CatchMatch thus ?case sorry
  next
    case CatchMiss thus ?case sorry
  qed
 } qed

} thus ?thesis by auto

oops

(*
lemma frame_safe_program:
  assumes a0:
    "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P c Q,A" and
    a1:"prog_env_safe \<Gamma> c F"
  shows "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (P\<and>*\<^sub>sR) c   (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
proof (rule cnvalidI)
  {fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A"
  assume exec: "\<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> (P\<and>*\<^sub>sR)"
  assume t_notin_F: "t \<notin> Fault ` F"
  then have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A" using a0 by (simp add: hoare_complete')
  show "t \<in> Normal ` (Q\<and>*\<^sub>sR) \<union> Abrupt ` (A\<and>*\<^sub>sR)"
  using exec P a0 t_notin_F a1
  proof (induct c arbitrary: s t P Q A R)
    case (Skip)
    then have t:"t=Normal s"
      by (meson execn_Normal_elim_cases(4))
    then obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1 \<uplus>\<^sub>s s2)"
      using Skip(2)
      by (metis mem_Collect_eq sep_conj_def sep_split1_def)
    then have s1_p:"s1\<in> P " by auto
    have step:"\<Gamma>\<turnstile>\<langle>Skip,Normal s1\<rangle> =n\<Rightarrow> Normal s1"
      using execn.Skip by fastforce
    have s1_notin_f:"Normal s1 \<notin> Fault ` F" by fastforce
    have "Normal s1 \<in> Normal ` Q \<union> Abrupt ` A" using cnvalidD[OF Skip(3)[rule_format] ctxt step s1_p s1_notin_f]
      by auto
    then have "s1\<in>Q" by auto
    then show ?case using P_s1 t
      by (metis UnCI image_eqI mem_Collect_eq sep_conj_def sep_split1_def)
  next
    case (Basic f)
    then have t:"t=Normal (f s)"
      by (meson execn_Normal_elim_cases(6))
    have safe_basic:"\<forall>h h1 h2 t. t = f h1 \<and> ((h1 \<uplus>\<^sub>p h2) h) \<longrightarrow> (t \<uplus>\<^sub>p h2) (f h)"
      using Basic.prems(5) unfolding prog_env_safe_def prog_safe.simps(2) fun_safe_def by auto
    then obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1 \<uplus>\<^sub>s s2)" using Basic(2)
        by (metis (full_types) mem_Collect_eq sep_conj_def sep_split1_def)
    then have s1_p:"s1\<in> P " by auto
    then have step:"\<Gamma>\<turnstile>\<langle>Basic f,Normal s1\<rangle>=n\<Rightarrow> Normal (f s1)"
        using execn.Basic P_s1 by meson
    have s1_notin_f:"Normal (f s1) \<notin> Fault ` F" by fastforce
    have "Normal (f s1) \<in> Normal ` Q \<union> Abrupt ` A" using cnvalidD[OF Basic(3)[rule_format] ctxt step s1_p s1_notin_f]
      by auto
    then have "(f s1) \<in> Q" by auto
    also have "(f s1)## s2 \<and> ((f s1)+s2 = f s)" using safe_basic P_s1
         unfolding sep_disj_union_def sep_split1_def sep_split_def by fastforce
     ultimately show ?case
        using P_s1 t unfolding sep_disj_union_def sep_split1_def sep_conj_def by fastforce
  next
    case (Spec r)
    have safe_spec: "\<forall>h h1 h2 t.(((h1 \<uplus>\<^sub>p h2) h) \<and> (h1,t)\<in>r) \<longrightarrow>
                            t##h2 \<and> (h,t + h2) \<in> r \<and>
                            (\<forall>h'. (h,h')\<in>r \<longrightarrow> h' = (t+h2))"
      using Spec.prems(5) unfolding prog_env_safe_def prog_safe.simps(3) set_safe_def by auto
    then obtain s1 s2 where P_s1:"((P)\<^sub>f s1) \<and> ((R)\<^sub>f s2) \<and> (s1 \<uplus>\<^sub>s s2)" using Spec(2)
        by (metis (full_types) mem_Collect_eq sep_conj_def sep_split1_def)
    then have s1_p:"s1\<in> P" by auto
    have "\<exists>t. (s1,t)\<in>r"
    proof -
    {assume "\<forall>t. (s1,t)\<notin>r"
     then have step:"\<Gamma>\<turnstile> \<langle>Spec r,Normal s1\<rangle> =n\<Rightarrow> Stuck" by (fastforce intro: execn.SpecStuck)
     then have Stuck_notin_F:"Stuck\<notin>Fault ` F" by auto
     have False using cnvalidD[OF Spec(3)[rule_format] ctxt step s1_p Stuck_notin_F]
       by auto
    } thus ?thesis by auto qed
    then obtain t1 where s1_t1_r:"(s1,t1)\<in>r" by auto
    then have stepp1:"\<Gamma>\<turnstile>\<langle>Spec r,Normal s1\<rangle> =n\<Rightarrow> Normal t1"
      using execn.Spec by fastforce
    then have Normals1_notin_F:"Normal t1\<notin>Fault ` F" by auto
    have "Normal t1 \<in> Normal ` Q \<union> Abrupt ` A"using cnvalidD[OF Spec(3)[rule_format] ctxt stepp1 s1_p Normals1_notin_F]
      by auto
    then have t1_q:"(t1) \<in> Q" by auto
    have s_t1_s2_r:"t1##s2 \<and>(s,t1 + s2)\<in> r" using safe_spec P_s1 s1_t1_r
      unfolding sep_split1_def sep_split_def sep_disj_union_def by fastforce
    also then have "\<Gamma>\<turnstile> \<langle>Spec r,Normal s\<rangle> =n\<Rightarrow> Normal (t1+s2)"  by (fastforce intro: execn.Spec)
    ultimately have "t =Normal (t1+s2)"
      using  safe_spec  Spec.prems(1) P_s1  execn_Normal_elim_cases(7) s1_t1_r sep_split1_def sep_substate_disj_add substate_exists_split
      by (metis )
    then show ?case
      using P_s1 s_t1_s2_r t1_q unfolding  sep_disj_union_def sep_split1_def sep_conj_def by fastforce
  next
    case (Seq c1 c2)
      thus ?case
  } thus ?thesis by auto
qed *)

(*
lemma frame_safe_program:
  assumes a0:
    "\<forall>s t t'. P s \<and> \<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t \<and> (t=Normal t' \<or> t=Abrupt t') \<longrightarrow> Q t'" and
    a1:"prog_env_safe \<Gamma> c F"
  shows "\<forall>s t t'.  (P\<and>*R) s \<and> \<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t \<and> (t=Normal t' \<or> t=Abrupt t') \<longrightarrow> (Q\<and>*R) t'"
proof -
  {fix s t t'
  assume a01:"(P\<and>*R) s \<and> \<Gamma>\<turnstile>\<langle>c,Normal s\<rangle> \<Rightarrow> t  \<and> (t=Normal t' \<or> t=Abrupt t') "
  then have "((Q\<and>*R) t')"
  using a0 a1
  proof(induct c)
    case Skip
    then have t:"t=Normal s"
      by (meson exec_Normal_elim_cases(4))
    then obtain s1 s2 where P_s1:"P s1 \<and> R s2 \<and> (s1 \<uplus>\<^sub>s s2)" using Skip(1)
      by (metis (full_types) sep_conj_def sep_split1_def)
    then have "\<Gamma>\<turnstile>\<langle>Skip,Normal s1\<rangle> \<Rightarrow> Normal s1"
      using exec.Skip by auto
    then have "(\<exists>t'. (Normal s1=Normal t' \<or> Normal s1=Abrupt t') \<and> Q t')"
      using Skip P_s1  by blast
    then have "Q s1" by fastforce
    then show ?thesis using P_s1 t
      by (metis a01 sep_conjI sep_split1_def xstate.distinct(1) xstate.inject(1))
  next
    case (Basic f)
      then have t:"t=Normal (f s) \<and> t' = (f s)" using exec_Normal_elim_cases(6)
        by (metis (no_types) xstate.inject(1) xstate.simps(5))
      have safe_basic:"\<forall>h h1 h2 t. t = f h1 \<and> ((h1 \<uplus>\<^sub>p h2) h) \<longrightarrow> (t \<uplus>\<^sub>p h2) (f h)"
        using Basic.prems(3)  unfolding prog_env_safe_def prog_safe.simps(2) fun_safe_def by auto
      then obtain s1 s2 where P_s1:"P s1 \<and> R s2 \<and> (s1 \<uplus>\<^sub>s s2)" using Basic(1)
        by (metis (full_types) sep_conj_def sep_split1_def)
      then have "\<Gamma>\<turnstile>\<langle>Basic f,Normal s1\<rangle> \<Rightarrow> Normal (f s1)"
        using exec.Basic by meson
      then have "(\<exists>t'. (Normal (f s1)=Normal t' \<or> Normal (f s1)=Abrupt t') \<and> Q t')"
      using Basic P_s1  by blast
      then have "Q (f s1)" by fastforce
      also have "(f s1)## s2 \<and> ((f s1)+s2 = f s)" using safe_basic P_s1
         unfolding sep_disj_union_def sep_split1_def sep_split_def by fastforce
      ultimately show ?thesis
        using P_s1 t unfolding sep_disj_union_def sep_split1_def sep_conj_def by fastforce
  next
    case (Spec x)
      then have t:"(s,t') \<in> x \<and> t=Normal t'"
        using exec_Normal_elim_cases(7) xstate.distinct(1)
              xstate.distinct(9) xstate.inject(1) xstate.simps(9) by metis
      have safe_basic:"\<forall>h h1 h2 t. (h1,t)\<in>x \<and> ((h1 \<uplus>\<^sub>p h2) h) \<longrightarrow> (h,t \<uplus> h2) \<in> x"
        using Spec.prems(3)  unfolding prog_env_safe_def prog_safe.simps(3) set_safe_def by auto
      obtain s1 s2 where P_s1:"P s1 \<and> R s2 \<and> (s1 \<uplus>\<^sub>s s2)" using Spec(1)
        by (metis (full_types) sep_conj_def sep_split1_def)
      then have "\<Gamma>\<turnstile>\<langle>Spec x,Normal s1\<rangle> \<Rightarrow> Normal (f s1)"
        using exec.Spec by meson
      then have "(\<exists>t'. (Normal (f s1)=Normal t' \<or> Normal (f s1)=Abrupt t') \<and> Q t')"
      using Basic P_s1  by blast
      then have "Q (f s1)" by fastforce
      also have "(f s1)## s2 \<and> ((f s1)+s2 = f s)" using safe_basic P_s1
         unfolding sep_disj_union_def sep_split1_def sep_split_def by fastforce
      ultimately show ?thesis
        using P_s1 t unfolding sep_disj_union_def sep_split1_def sep_conj_def by fastforce
  } thus ?thesis by auto
qed
oops
*)

lemma if_der: assumes
      a1:"\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>((P \<inter> b) \<and>*\<^sub>s R) c\<^sub>1 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)" and
      a1':"\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>(P \<inter> b) c\<^sub>1 Q,A" and
      a2:"\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>((P \<inter> -b) \<and>*\<^sub>s R) c\<^sub>2 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)" and
      a2':"\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>(P \<inter> -b) c\<^sub>2 Q,A" and
      a3: "prog_env_safe \<Gamma> (Cond b c\<^sub>1 c\<^sub>2) F" and
      a4: "(pred_sep_domain b) \<subseteq> (pred_sep_domain P)"
 shows
    "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>(P \<and>*\<^sub>s R) (Cond b c\<^sub>1 c\<^sub>2) (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
 proof -{
    fix n
    have "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>(P \<and>*\<^sub>s R) (Cond b c\<^sub>1 c\<^sub>2) (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
    proof -
    {assume a0:"(\<forall>(P,p,Q,A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P (Call p) Q,A)"
    then have "\<Gamma> \<Turnstile>n:\<^bsub>/F\<^esub> (P \<and>*\<^sub>s R) (Cond b c\<^sub>1 c\<^sub>2) (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
    proof -
       {fix s t
       assume  a00:"\<Gamma>\<turnstile>\<langle>Cond b c\<^sub>1 c\<^sub>2 ,s \<rangle> =n\<Rightarrow> t"
       assume  a11:"s \<in> Normal ` (P \<and>*\<^sub>s R)"
       assume a22:"t \<notin> Fault ` F"
       have a1:"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>((P \<inter> b) \<and>*\<^sub>s R) c\<^sub>1 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
         using a1 by auto
       then have a2:"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>((P \<inter> -b) \<and>*\<^sub>s R) c\<^sub>2 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
         using a2 by auto
       obtain s' where sep:"s=Normal s' \<and> s' \<in> (P \<and>*\<^sub>s R)"
         using a11 by fastforce
       then have "t \<in>  Normal ` (Q\<and>*\<^sub>sR) \<union> Abrupt `(A\<and>*\<^sub>sR)"
       proof (cases "s'\<in>b")
         case True
         then have step:"\<Gamma>\<turnstile>\<langle>c\<^sub>1,Normal s'\<rangle> =n\<Rightarrow> t"
         proof -
           have "\<Gamma>\<turnstile> \<langle>Cond b c\<^sub>1 c\<^sub>2,Normal s'\<rangle> =n\<Rightarrow> t"
            using a00 sep by auto
           then show ?thesis using True
             by (meson execn_Normal_elim_cases(9))
         qed
         then have "s' \<in> (P \<and>*\<^sub>s R) \<inter> b"
           using sep  True by auto
         obtain s1 s2 where sep:"s1 ## s2 \<and> s' = s1 + s2 \<and> s1\<in>P \<and> s2\<in>R "
           by (metis mem_Collect_eq sep sep_conjE)
         then have "s1 \<preceq> s'" using sep_substate_def by fastforce
         then have "s1\<in>b" using True a4 a3
           unfolding prog_env_safe_def prog_safe.simps cond_safe_def
         by auto
         then have pre:"s' \<in> ((P \<inter> b) \<and>*\<^sub>s R)"
           using sep unfolding sep_conj_def by auto
         then have "t \<in> Normal ` (Q\<and>*\<^sub>sR) \<union> Abrupt `  (A\<and>*\<^sub>sR)"
           using cnvalidD[OF a1 a0 step pre a22] by auto
         thus ?thesis by auto
       next
         case False
         then have step:"\<Gamma>\<turnstile>\<langle>c\<^sub>2,Normal s'\<rangle> =n\<Rightarrow> t"
         proof -
           have "\<Gamma>\<turnstile> \<langle>Cond b c\<^sub>1 c\<^sub>2,Normal s'\<rangle> =n\<Rightarrow> t"
            using a00 sep by auto
           then show ?thesis using False
             by (meson execn_Normal_elim_cases(9))
         qed
         obtain s1 s2 where sep:"s1 ## s2 \<and> s' = s1 + s2 \<and> s1\<in>P \<and> s2\<in>R "
           by (metis mem_Collect_eq sep sep_conjE)
         then have "s1 \<preceq> s'" using sep_substate_def by fastforce
         then have "s1\<in>-b" using False a4 a3
           unfolding prog_env_safe_def prog_safe.simps cond_safe_def
         by auto
         then have pre:"s' \<in> ((P \<inter> -b) \<and>*\<^sub>s R)"
           using sep unfolding sep_conj_def by auto
         then have "t \<in> Normal ` (Q\<and>*\<^sub>sR) \<union> Abrupt `  (A\<and>*\<^sub>sR)"
           using cnvalidD[OF a2 a0 step pre a22] by auto
         thus ?thesis by auto
       qed }
     then have ?thesis using nvalid_def by metis
  thus ?thesis by auto
  qed
  } thus ?thesis using cnvalid_def by fast
  qed
} thus ?thesis by auto
qed

lemma frame_safe_rule:
  assumes a0:"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A" and
          a1:"prog_env_safe \<Gamma> c F" and
          a2:"pred_safe \<Gamma> c P"
  shows  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P\<and>*\<^sub>sR) c (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
using a0 a1 a2
proof(induct arbitrary: R)
  case (Skip \<Gamma> F Q) thus ?case using hoarep.Skip by fastforce
next
  case (Basic \<Theta> F f Q A)
    from hoarep.Basic  have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>{s. f s \<in> (Q\<and>*\<^sub>sR)} Basic f (Q\<and>*\<^sub>sR),A"
      by fastforce
    have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>{s. f s \<in> Q} Basic f Q,A" using  hoarep.Basic by fastforce
    have "\<forall>s. f s \<in> (Q\<and>*\<^sub>sR) \<longrightarrow> (\<exists>s1 s2. (f s) = s1 + s2 \<and> s1 ## s2 \<and> s1\<in>Q  \<and> s2\<in>R)"
      using fun_safe_def
      unfolding  sep_conj_def fun_safe_def by fastforce
    unfolding prog_env_safe_def prog_safe.simps(2) fun_safe_def
    show " \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>{a. ((\<lambda>v. v \<in> {s. f s \<in> Q}) \<and>* (\<lambda>v. v \<in> R)) a} Basic f
              {a. ((\<lambda>v. v \<in> Q) \<and>* (\<lambda>v. v \<in> R)) a},
              {a. ((\<lambda>v. v \<in> A) \<and>* (\<lambda>v. v \<in> R)) a}"
sorry
next
  case (Cond \<Theta> F P b c\<^sub>1 Q A c\<^sub>2)
    then have pred_safe:"(pred_sep_domain b) \<subseteq> (pred_sep_domain P) \<and>  (pred_safe \<Gamma> c\<^sub>1 (P \<inter> b)) \<and> pred_safe \<Gamma> c\<^sub>2 (P \<inter> -b)"
    by (fastforce elim: pred_safe_elim_cases(5))
    then have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>((P \<inter> b) \<and>*\<^sub>s R) c\<^sub>1 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)" using Cond
      unfolding prog_env_safe_def by auto
    also have "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>((P \<inter> -b) \<and>*\<^sub>s R) c\<^sub>2 (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)" using Cond pred_safe
      unfolding prog_env_safe_def by auto
    ultimately have "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>(P \<and>*\<^sub>s R) (Cond b c\<^sub>1 c\<^sub>2) (Q\<and>*\<^sub>sR),(A\<and>*\<^sub>sR)"
      using if_der Cond pred_safe by (metis hoare_cnvalid)
    then show ?case using hoare_complete' by force
next

qed

end