header {* The programming language and its semantics *}

theory Language_Semantics imports Interface begin

subsection {* Syntax and operational semantics *}

datatype ('test,'atom) com =
  Atm 'atom |
  Seq "('test,'atom) com" "('test,'atom) com"
    ("_ ;; _"  [60, 61] 60) |
  If 'test "('test,'atom) com" "('test,'atom) com"
    ("(if _/ then _/ else _)"  [0, 0, 61] 61) |
  While 'test "('test,'atom) com"
    ("(while _/ do _)"  [0, 61] 61) |
  Par "('test,'atom) com" "('test,'atom) com"
    ("_ | _"  [60, 61] 60)

locale PL =
fixes
  tval :: "'test \<Rightarrow> 'state \<Rightarrow> bool" and
  aval :: "'atom \<Rightarrow> 'state \<Rightarrow> 'state"

(* *****************************************)
context PL
begin

text{* Conventions and notations:
-- suffixes: ``C" for ``Continuation", ``T" for ``termination"
-- prefix: ``M" for multistep
-- tst, tst' are tests
-- atm, atm' are atoms (atomic commands)
-- s, s', t, t' are states
-- c, c', d, d' are commands
-- cf, cf' are configurations, i.e., pairs command-state  *}

inductive transT ::
"(('test,'atom)com * 'state) \<Rightarrow> 'state \<Rightarrow> bool"
(infix "\<rightarrow>t" 55)
where
  Atm[simp]:
"(Atm atm, s) \<rightarrow>t aval atm s"
| WhileFalse[simp]:
"~ tval tst s \<Longrightarrow> (While tst c, s) \<rightarrow>t s"

lemmas trans_Atm = Atm
lemmas trans_WhileFalse = WhileFalse

(* The RT-closure of \<rightarrow>c is inlined since later versions of \<rightarrow>c may refer to it. *)
inductive transC ::
"(('test,'atom)com * 'state) \<Rightarrow> (('test,'atom)com * 'state) \<Rightarrow> bool"
(infix "\<rightarrow>c" 55)
and MtransC ::
"(('test,'atom)com * 'state) \<Rightarrow> (('test,'atom)com * 'state) \<Rightarrow> bool"
(infix "\<rightarrow>*c" 55)
where
  SeqC[simp]:
"(c1, s) \<rightarrow>c (c1', s') \<Longrightarrow> (c1 ;; c2, s) \<rightarrow>c (c1' ;; c2, s')"
| SeqT[simp]:
"(c1, s) \<rightarrow>t s' \<Longrightarrow> (c1 ;; c2, s) \<rightarrow>c (c2, s')"
| IfTrue[simp]:
"tval tst s \<Longrightarrow> (If tst c1 c2, s) \<rightarrow>c (c1, s)"
| IfFalse[simp]:
"~ tval tst s \<Longrightarrow> (If tst c1 c2,s) \<rightarrow>c (c2, s)"
| WhileTrue[simp]:
"tval tst s \<Longrightarrow> (While tst c, s) \<rightarrow>c (c ;; (While tst c), s)"
(*  *)
| ParCL[simp]:
"(c1, s) \<rightarrow>c (c1', s') \<Longrightarrow> (Par c1 c2, s) \<rightarrow>c (Par c1' c2, s')"
| ParCR[simp]:
"(c2, s) \<rightarrow>c (c2', s') \<Longrightarrow> (Par c1 c2, s) \<rightarrow>c (Par c1 c2', s')"
| ParTL[simp]:
"(c1, s) \<rightarrow>t s' \<Longrightarrow> (Par c1 c2, s) \<rightarrow>c (c2, s')"
| ParTR[simp]:
"(c2, s) \<rightarrow>t s' \<Longrightarrow> (Par c1 c2, s) \<rightarrow>c (c1, s')"
| Refl:
"(c,s) \<rightarrow>*c (c,s)"
| Step:
"\<lbrakk>(c,s) \<rightarrow>*c (c',s'); (c',s') \<rightarrow>c (c'',s'')\<rbrakk> \<Longrightarrow> (c,s) \<rightarrow>*c (c'',s'')"

lemmas trans_SeqC = SeqC lemmas trans_SeqT = SeqT
lemmas trans_IfTrue = IfTrue lemmas trans_IfFalse = IfFalse
lemmas trans_WhileTrue = WhileTrue
lemmas trans_ParCL = ParCL  lemmas trans_ParCR = ParCR
lemmas trans_ParTL = ParTL  lemmas trans_ParTR = ParTR
lemmas trans_Refl = Refl  lemmas trans_Step = Step

lemma MtransC_Refl[simp]: "cf \<rightarrow>*c cf"
using trans_Refl by(cases cf, simp)

lemmas transC_induct = transC_MtransC.inducts(1)
  [split_format(complete),
   where ?P2.0 = "\<lambda> c s c' s'. True"]
lemmas MtransC_induct_temp = transC_MtransC.inducts(2)[split_format(complete)]

inductive MtransT ::
"(('test,'atom)com * 'state) \<Rightarrow> 'state \<Rightarrow> bool"
(infix "\<rightarrow>*t" 55)
where
  StepT:
"\<lbrakk>cf \<rightarrow>*c cf'; cf' \<rightarrow>t s''\<rbrakk> \<Longrightarrow> cf \<rightarrow>*t s''"

lemma MtransC_rtranclp_transC:
"MtransC = transC ^**"
proof-
  {fix c s c' s'
   have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> transC ^** (c,s) (c',s')"
   apply(rule MtransC_induct_temp[of _ _ c s c' s' "\<lambda>c s c' s'. True"]) by auto
  }
  moreover
  {fix c s c' s'
   have "transC ^** (c,s) (c',s') \<Longrightarrow> (c,s) \<rightarrow>*c (c',s')"
   apply(erule rtranclp.induct) using trans_Step by auto
  }
  ultimately show ?thesis
  apply - apply(rule ext, rule ext) by auto
qed

lemma transC_MtransC[simp]:
assumes "cf \<rightarrow>c cf'"
shows "cf \<rightarrow>*c cf'"
using assms unfolding MtransC_rtranclp_transC by blast

lemma MtransC_Trans:
assumes "cf \<rightarrow>*c cf'" and "cf' \<rightarrow>*c cf''"
shows "cf \<rightarrow>*c cf''"
using assms rtranclp_trans[of transC cf cf' cf'']
unfolding MtransC_rtranclp_transC by blast

lemma MtransC_StepC:
assumes *: "cf \<rightarrow>*c cf'" and **: "cf' \<rightarrow>c cf''"
shows "cf \<rightarrow>*c cf''"
proof-
  have "cf' \<rightarrow>*c cf''" using ** by simp
  thus ?thesis using * MtransC_Trans by blast
qed

lemma MtransC_induct[consumes 1, case_names Refl Trans]:
assumes "cf \<rightarrow>*c cf'"
and "\<And>cf. phi cf cf"
and
"\<And> cf cf' cf''.
   \<lbrakk>cf \<rightarrow>*c cf'; phi cf cf'; cf' \<rightarrow>c cf''\<rbrakk>
   \<Longrightarrow> phi cf cf''"
shows "phi cf cf'"
using assms unfolding MtransC_rtranclp_transC
using rtranclp.induct[of transC cf cf'] by blast

lemma MtransC_induct2[consumes 1, case_names Refl Trans, induct pred: MtransC]:
assumes "(c,s) \<rightarrow>*c (c',s')"
and "\<And>c s. phi c s c s"
and
"\<And> c s c' s' c'' s''.
   \<lbrakk>(c,s) \<rightarrow>*c (c',s'); phi c s c' s'; (c',s') \<rightarrow>c (c'',s'')\<rbrakk>
   \<Longrightarrow> phi c s c'' s''"
shows "phi c s c' s'"
using assms
MtransC_induct[of "(c,s)" "(c',s')" "\<lambda>(c,s) (c',s'). phi c s c' s'"] by blast

lemma transT_MtransT[simp]:
assumes "cf \<rightarrow>t s'"
shows "cf \<rightarrow>*t s'"
by (metis PL.MtransC_Refl PL.MtransT.intros assms)

lemma MtransC_MtransT:
assumes "cf \<rightarrow>*c cf'" and "cf' \<rightarrow>*t cf''"
shows "cf \<rightarrow>*t cf''"
by (metis MtransT.cases PL.MtransC_Trans PL.MtransT.intros assms)

lemma transC_MtransT[simp]:
assumes "cf \<rightarrow>c cf'" and "cf' \<rightarrow>*t s''"
shows "cf \<rightarrow>*t s''"
by (metis PL.MtransC_MtransT assms(1) assms(2) transC_MtransC)

text{* Inversion rules, nchotomies and such: *}

lemma Atm_transC_simp[simp]:
"~ (Atm atm, s) \<rightarrow>c cf"
apply clarify apply(erule transC.cases) by auto

lemma Atm_transC_invert[elim!]:
assumes "(Atm atm, s) \<rightarrow>c cf"
shows phi
using assms by simp

lemma Atm_transT_invert[elim!]:
assumes "(Atm atm, s) \<rightarrow>t s'"
and "s' = aval atm s \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transT.cases) by auto

lemma Seq_transC_invert[elim!]:
assumes "(c1 ;; c2, s) \<rightarrow>c (c', s')"
and "\<And> c1'. \<lbrakk>(c1, s) \<rightarrow>c (c1',s'); c' = c1' ;; c2\<rbrakk> \<Longrightarrow> phi"
and "\<lbrakk>(c1, s) \<rightarrow>t s'; c' = c2\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transC.cases) by auto

lemma Seq_transT_invert[simp]:
"~ (c1 ;; c2, s) \<rightarrow>t s'"
apply clarify apply(erule transT.cases) by auto

lemma If_transC_invert[elim!]:
assumes "(If tst c1 c2, s) \<rightarrow>c (c', s')"
and "\<lbrakk>tval tst s; c' = c1; s' = s\<rbrakk> \<Longrightarrow> phi"
and "\<lbrakk>~ tval tst s; c' = c2; s' = s\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transC.cases) by auto

lemma If_transT_simp[simp]:
"~ (If b c1 c2, s) \<rightarrow>t s'"
apply clarify apply(erule transT.cases) by auto

lemma If_transT_invert[elim!]:
assumes "(If b c1 c2, s) \<rightarrow>t s'"
shows phi
using assms by simp

lemma While_transC_invert[elim]:
assumes "(While tst c1, s) \<rightarrow>c (c', s')"
and "\<lbrakk>tval tst s; c' = c1 ;; (While tst c1); s' = s\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transC.cases) by auto

lemma While_transT_invert[elim!]:
assumes "(While tst c1, s) \<rightarrow>t s'"
and "\<lbrakk>~ tval tst s; s' = s\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transT.cases) by blast+

lemma Par_transC_invert[elim!]:
assumes "(Par c1 c2, s) \<rightarrow>c (c', s')"
and "\<And> c1'. \<lbrakk>(c1, s) \<rightarrow>c (c1',s'); c' = Par c1' c2\<rbrakk> \<Longrightarrow> phi"
and "\<lbrakk>(c1, s) \<rightarrow>t s'; c' = c2\<rbrakk> \<Longrightarrow> phi"
and "\<And> c2'. \<lbrakk>(c2, s) \<rightarrow>c (c2',s'); c' = Par c1 c2'\<rbrakk> \<Longrightarrow> phi"
and "\<lbrakk>(c2, s) \<rightarrow>t s'; c' = c1\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule transC.cases) by auto

lemma Par_transT_simp[simp]:
"~ (Par c1 c2, s) \<rightarrow>t s'"
apply clarify apply(erule transT.cases) by auto

lemma Par_transT_invert[elim!]:
assumes "(Par c1 c2, s) \<rightarrow>t s'"
shows phi
using assms by simp

lemma trans_nchotomy:
"(\<exists> c' s'. (c,s) \<rightarrow>c (c',s')) \<or>
 (\<exists> s'. (c,s) \<rightarrow>t s')"
proof-
  let ?phiC = "\<lambda>c. \<exists> c' s'. (c,s) \<rightarrow>c (c',s')"
  let ?phiT = "\<lambda>c. \<exists> s'. (c,s) \<rightarrow>t s'"
  let ?phi = "\<lambda>c. ?phiC c \<or> ?phiT c"
  show "?phi c"
  apply(induct c)
  by(metis Atm, metis SeqC SeqT, metis IfFalse IfTrue,
  metis WhileFalse WhileTrue,
  metis ParCL ParCR ParTL ParTR)
qed

corollary trans_invert:
assumes
"\<And> c' s'. (c,s) \<rightarrow>c (c',s') \<Longrightarrow> phi"
and "\<And> s'. (c,s) \<rightarrow>t s' \<Longrightarrow> phi"
shows phi
using assms trans_nchotomy by blast

lemma not_transC_transT:
"\<lbrakk>cf \<rightarrow>c cf'; cf \<rightarrow>t s'\<rbrakk> \<Longrightarrow> phi"
apply(erule transC.cases) by auto

lemmas MtransT_invert = MtransT.cases

lemma MtransT_invert2:
assumes "(c, s) \<rightarrow>*t s''"
and "\<And> c' s'. \<lbrakk>(c,s) \<rightarrow>*c (c',s'); (c', s') \<rightarrow>t s''\<rbrakk> \<Longrightarrow> phi"
shows phi
using assms apply - apply(erule MtransT.cases) by auto

lemma Seq_MtransC_invert[elim!]:
assumes "(c1 ;; c2, s) \<rightarrow>*c (d', t')"
and "\<And> c1'. \<lbrakk>(c1, s) \<rightarrow>*c (c1',t'); d' = c1' ;; c2\<rbrakk> \<Longrightarrow> phi"
and "\<And> s'. \<lbrakk>(c1, s) \<rightarrow>*t s'; (c2, s') \<rightarrow>*c (d',t')\<rbrakk> \<Longrightarrow> phi"
shows phi
proof-
  {fix c
   have "(c,s) \<rightarrow>*c (d',t') \<Longrightarrow>
   \<forall> c1 c2.
     c = c1 ;; c2 \<longrightarrow>
     (\<exists> c1'. (c1, s) \<rightarrow>*c (c1',t') \<and> d' = c1' ;; c2) \<or>
     (\<exists> s'. (c1, s) \<rightarrow>*t s' \<and> (c2, s') \<rightarrow>*c (d',t'))"
   apply(erule MtransC_induct2) proof(tactic {* mauto_no_simp_tac *})
     fix c s d' t' d'' t'' c1 c2
     assume (*  "(c, s) \<rightarrow>*c (d', t')" and *)
     "\<forall>c1 c2. c = c1 ;; c2 \<longrightarrow>
        (\<exists>c1'. (c1, s) \<rightarrow>*c (c1', t') \<and> d' = c1' ;; c2) \<or>
        (\<exists>s'. (c1, s) \<rightarrow>*t s' \<and> (c2, s') \<rightarrow>*c (d', t'))"
     and 1: "(d', t') \<rightarrow>c (d'', t'')" and "c = c1 ;; c2"
     hence IH:
     "(\<exists>c1'. (c1, s) \<rightarrow>*c (c1', t') \<and> d' = c1' ;; c2) \<or>
      (\<exists>s'. (c1, s) \<rightarrow>*t s' \<and> (c2, s') \<rightarrow>*c (d', t'))" by simp
     show "(\<exists>c1''. (c1, s) \<rightarrow>*c (c1'', t'') \<and> d'' = c1'' ;; c2) \<or>
           (\<exists>s''. (c1, s) \<rightarrow>*t s'' \<and> (c2, s'') \<rightarrow>*c (d'', t''))"
     proof-
       {fix c1' assume 2: "(c1, s) \<rightarrow>*c (c1', t')" and d': "d' = c1' ;; c2"
        have ?thesis
        using 1 unfolding d' apply - proof(erule Seq_transC_invert)
          fix c1'' assume "(c1', t') \<rightarrow>c (c1'', t'')" and d'': "d'' = c1'' ;; c2"
          hence "(c1, s) \<rightarrow>*c (c1'', t'')" using 2 MtransC_StepC by blast
          thus ?thesis using d'' by blast
        next
          assume "(c1', t') \<rightarrow>t t''" and d'': "d'' = c2"
          hence "(c1, s) \<rightarrow>*t t''" using 2 MtransT.StepT by blast
          thus ?thesis unfolding d'' by auto
        qed
       }
       moreover
       {fix s' assume 2: "(c1, s) \<rightarrow>*t s'" and "(c2, s') \<rightarrow>*c (d', t')"
        hence "(c2, s') \<rightarrow>*c (d'', t'')" using 1 MtransC_StepC by blast
        hence ?thesis using 2 by blast
       }
       ultimately show ?thesis using IH by blast
     qed
   qed (metis PL.MtransC_Refl)
  }
  thus ?thesis using assms by blast
qed

lemma Seq_MtransT_invert[elim!]:
assumes *: "(c1 ;; c2, s) \<rightarrow>*t s''"
and **: "\<And> s'. \<lbrakk>(c1, s) \<rightarrow>*t s'; (c2, s') \<rightarrow>*t s''\<rbrakk> \<Longrightarrow> phi"
shows phi
proof-
  obtain d' t' where 1: "(c1 ;; c2, s) \<rightarrow>*c (d',t')" and 2: "(d',t') \<rightarrow>t s''"
  using * apply - apply(erule MtransT_invert2) by auto
  show ?thesis
  using 1 apply - proof(erule Seq_MtransC_invert)
    fix c1' assume "d' = c1' ;; c2"
    hence False using 2 by simp
    thus ?thesis by simp
  next
    fix s' assume 3: "(c1, s) \<rightarrow>*t s'" and "(c2, s') \<rightarrow>*c (d', t')"
    hence "(c2, s') \<rightarrow>*t s''" using 2 MtransT.StepT by blast
    thus ?thesis using 3 ** by blast
  qed
qed

text{* Direct rules for the multi-step relations *}

lemma Seq_MtransC[simp]:
assumes "(c1, s) \<rightarrow>*c (c1', s')"
shows "(c1 ;; c2, s) \<rightarrow>*c (c1' ;; c2, s')"
using assms apply - apply(erule MtransC_induct2)
apply simp by (metis MtransC_StepC SeqC)

lemma Seq_MtransT_MtransC[simp]:
assumes "(c1, s) \<rightarrow>*t s'"
shows "(c1 ;; c2, s) \<rightarrow>*c (c2, s')"
using assms apply - apply(erule MtransT_invert)
by (metis MtransC_StepC MtransT_invert2 PL.SeqT PL.Seq_MtransC assms)

lemma ParCL_MtransC[simp]:
assumes "(c1, s) \<rightarrow>*c (c1', s')"
shows "(Par c1 c2, s) \<rightarrow>*c (Par c1' c2, s')"
using assms apply - apply(erule MtransC_induct2)
apply simp by (metis MtransC_StepC ParCL)

lemma ParCR_MtransC[simp]:
assumes "(c2, s) \<rightarrow>*c (c2', s')"
shows "(Par c1 c2, s) \<rightarrow>*c (Par c1 c2', s')"
using assms apply - apply(erule MtransC_induct2)
apply simp by (metis MtransC_StepC ParCR)

lemma ParTL_MtransC[simp]:
assumes "(c1, s) \<rightarrow>*t s'"
shows "(Par c1 c2, s) \<rightarrow>*c (c2, s')"
using assms apply - apply(erule MtransT_invert)
by (metis MtransC_StepC MtransT_invert2 PL.ParTL ParCL_MtransC assms)

lemma ParTR_MtransC[simp]:
assumes "(c2, s) \<rightarrow>*t s'"
shows "(Par c1 c2, s) \<rightarrow>*c (c1, s')"
using assms apply - apply(erule MtransT_invert)
by (metis MtransC_StepC MtransT_invert2 PL.ParTR ParCR_MtransC assms)

subsection{* Sublanguages *}

(* Commands not containing "while": *)
fun noWhile where
 "noWhile (Atm atm) = True"
|"noWhile (c1 ;; c2) = (noWhile c1 \<and> noWhile c2)"
|"noWhile (If b c1 c2) = (noWhile c1 \<and> noWhile c2)"
|"noWhile (While b c) = False"
|"noWhile (Par c1 c2) = (noWhile c1 \<and> noWhile c2)"

(* Sequential commands: *)
fun seq where
 "seq (Atm atm) = True"
|"seq (c1 ;; c2) = (seq c1 \<and> seq c2)"
|"seq (If b c1 c2) = (seq c1 \<and> seq c2)"
|"seq (While b c) = seq c"
|"seq (Par c1 c2) = False"

lemma noWhile_transC:
assumes "noWhile c" and "(c,s) \<rightarrow>c (c',s')"
shows "noWhile c'"
proof-
  have "(c,s) \<rightarrow>c (c',s') \<Longrightarrow> noWhile c \<longrightarrow> noWhile c'"
  by(erule transC_induct, auto)
  thus ?thesis using assms by simp
qed

lemma seq_transC:
assumes "seq c" and "(c,s) \<rightarrow>c (c',s')"
shows "seq c'"
proof-
  have "(c,s) \<rightarrow>c (c',s') \<Longrightarrow> seq c \<longrightarrow> seq c'"
  by(erule transC_induct, auto)
  thus ?thesis using assms by simp
qed

abbreviation wfP_on where
"wfP_on phi A \<equiv> wfP (\<lambda>a b. a \<in> A \<and> b \<in> A \<and> phi a b)"

(* The number of steps -- makes sense only for the noWhile sublanguage: *)
fun numSt where
 "numSt (Atm atm) = Suc 0"
|"numSt (c1 ;; c2) = numSt c1 + numSt c2"
|"numSt (If b c1 c2) = 1 + max (numSt c1) (numSt c2)"
|"numSt (Par c1 c2) = numSt c1 + numSt c2"

lemma numSt_gt_0[simp]:
"noWhile c \<Longrightarrow> numSt c > 0"
by(induct c, auto)

lemma numSt_transC:
assumes "noWhile c" and "(c,s) \<rightarrow>c (c',s')"
shows "numSt c' < numSt c"
using assms apply - apply(induct c arbitrary: c') by auto

corollary wfP_tranC_noWhile:
"wfP (\<lambda> (c',s') (c,s). noWhile c \<and> (c,s) \<rightarrow>c (c',s'))"
proof-
  let ?K = "{((c',s'),(c,s)). noWhile c \<and> (c,s) \<rightarrow>c (c',s')}"
  have "?K \<le> inv_image {(m,n). m < n} (\<lambda>(c,s). numSt c)" by(auto simp add: numSt_transC)
  hence "wf ?K" using wf_less wf_subset[of _ ?K] by blast
  thus ?thesis unfolding wfP_def
  by (metis CollectD Collect_mem_eq Compl_eq Compl_iff double_complement)
qed

lemma noWhile_MtransT:
assumes "noWhile c"
shows "\<exists> s'. (c,s) \<rightarrow>*t s'"
proof-
  have "noWhile c \<longrightarrow> (\<forall> s. \<exists> s'. (c,s) \<rightarrow>*t s')"
  apply(rule measure_induct[of numSt]) proof clarify
    fix c :: "('test,'atom) com" and s
    assume IH: "\<forall>c'. numSt c' < numSt c \<longrightarrow> noWhile c' \<longrightarrow>
                     (\<forall>s'. \<exists>s''. (c', s') \<rightarrow>*t s'')" and c: "noWhile c"
    show "\<exists>s''. (c, s) \<rightarrow>*t s''"
    proof(rule trans_invert[of c s])
      fix c' s' assume cs: "(c, s) \<rightarrow>c (c', s')"
      hence "numSt c' < numSt c" and "noWhile c'"
      using numSt_transC noWhile_transC c by blast+
      then obtain s'' where "(c', s') \<rightarrow>*t s''" using IH by blast
      hence "(c, s) \<rightarrow>*t s''" using cs by simp
      thus ?thesis by blast
    next
      fix s' assume "(c, s) \<rightarrow>t s'"
      hence "(c, s) \<rightarrow>*t s'" by simp
      thus ?thesis by blast
    qed
  qed
  thus ?thesis using assms by blast
qed

(* Configurations that may diverge: *)

coinductive mayDiverge where
intro:
"\<lbrakk>(c,s) \<rightarrow>c (c',s') \<and> mayDiverge c' s'\<rbrakk>
  \<Longrightarrow> mayDiverge c s"

text{* Coinduction for may-diverge : *}

lemma mayDiverge_coind[consumes 1, case_names Hyp, induct pred: mayDiverge]:
assumes *: "phi c s" and
**: "\<And> c s. phi c s \<Longrightarrow>
            \<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> (phi c' s' \<or> mayDiverge c' s')"
shows "mayDiverge c s"
using * apply(elim mayDiverge.coinduct) using ** by auto

lemma mayDiverge_raw_coind[consumes 1, case_names Hyp]:
assumes *: "phi c s" and
**: "\<And> c s. phi c s \<Longrightarrow>
            \<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> phi c' s'"
shows "mayDiverge c s"
using * apply induct using ** by blast

text{* May-diverge versus transition: *}

lemma mayDiverge_transC:
assumes "mayDiverge c s"
shows "\<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> mayDiverge c' s'"
using assms by (elim mayDiverge.cases) blast

lemma transC_mayDiverge:
assumes "(c,s) \<rightarrow>c (c',s')" and "mayDiverge c' s'"
shows "mayDiverge c s"
using assms by (metis mayDiverge.intro)

lemma mayDiverge_not_transT:
assumes "mayDiverge c s"
shows "\<not> (c,s) \<rightarrow>t s'"
by (metis assms mayDiverge_transC not_transC_transT)

lemma MtransC_mayDiverge:
assumes "(c,s) \<rightarrow>*c (c',s')" and "mayDiverge c' s'"
shows "mayDiverge c s"
using assms transC_mayDiverge by (induct) auto

lemma not_MtransT_mayDiverge:
assumes "\<And> s'. \<not> (c,s) \<rightarrow>*t s'"
shows "mayDiverge c s"
proof-
  have "\<forall> s'. \<not> (c,s) \<rightarrow>*t s' \<Longrightarrow> ?thesis"
  proof (induct rule: mayDiverge_raw_coind)
    case (Hyp c s)
    hence "\<forall> s''. \<not> (c, s) \<rightarrow>t s''" by (metis transT_MtransT)
    then obtain c' s' where 1: "(c,s) \<rightarrow>c (c',s')" by (metis trans_invert)
    hence "\<forall> s''. \<not> (c', s') \<rightarrow>*t s''" using Hyp 1 by (metis transC_MtransT)
    thus ?case using 1 by blast
  qed
  thus ?thesis using assms by simp
qed

lemma not_mayDiverge_Atm[simp]:
"\<not> mayDiverge (Atm atm) s"
by (metis Atm_transC_invert mayDiverge.simps)

lemma mayDiverge_Seq_L:
assumes "mayDiverge c1 s"
shows "mayDiverge (c1 ;; c2) s"
proof-
 {fix c
  assume "\<exists> c1 c2. c = c1 ;; c2 \<and> mayDiverge c1 s"
  hence "mayDiverge c s"
  proof (induct rule: mayDiverge_raw_coind)
    case (Hyp c s)
    then obtain c1 c2 where c: "c = c1 ;; c2"
    and "mayDiverge c1 s" by blast
    then obtain c1' s' where "(c1,s) \<rightarrow>c (c1',s')"
    and "mayDiverge c1' s'" by (metis mayDiverge_transC)
    thus ?case using c SeqC by metis
  qed
 }
 thus ?thesis using assms by auto
qed

lemma mayDiverge_Seq_R:
assumes c1: "(c1, s) \<rightarrow>*t s'" and c2: "mayDiverge c2 s'"
shows "mayDiverge (c1 ;; c2) s"
proof-
  have "(c1 ;; c2, s) \<rightarrow>*c (c2, s')"
  using c1 by (metis Seq_MtransT_MtransC)
  thus ?thesis by (metis MtransC_mayDiverge c2)
qed

lemma mayDiverge_If_L:
assumes "tval tst s" and "mayDiverge c1 s"
shows "mayDiverge (If tst c1 c2) s"
using assms IfTrue transC_mayDiverge by metis

lemma mayDiverge_If_R:
assumes "\<not> tval tst s" and "mayDiverge c2 s"
shows "mayDiverge (If tst c1 c2) s"
using assms IfFalse transC_mayDiverge by metis

lemma mayDiverge_If:
assumes "mayDiverge c1 s" and "mayDiverge c2 s"
shows "mayDiverge (If tst c1 c2) s"
using assms mayDiverge_If_L mayDiverge_If_R
by (cases "tval tst s") auto

lemma mayDiverge_Par_L:
assumes "mayDiverge c1 s"
shows "mayDiverge (Par c1 c2) s"
proof-
 {fix c
  assume "\<exists> c1 c2. c = Par c1 c2 \<and> mayDiverge c1 s"
  hence "mayDiverge c s"
  proof (induct rule: mayDiverge_raw_coind)
    case (Hyp c s)
    then obtain c1 c2 where c: "c = Par c1 c2"
    and "mayDiverge c1 s" by blast
    then obtain c1' s' where "(c1,s) \<rightarrow>c (c1',s')"
    and "mayDiverge c1' s'" by (metis mayDiverge_transC)
    thus ?case using c ParCL by metis
  qed
 }
 thus ?thesis using assms by auto
qed

lemma mayDiverge_Par_R:
assumes "mayDiverge c2 s"
shows "mayDiverge (Par c1 c2) s"
proof-
 {fix c
  assume "\<exists> c1 c2. c = Par c1 c2 \<and> mayDiverge c2 s"
  hence "mayDiverge c s"
  proof (induct rule: mayDiverge_raw_coind)
    case (Hyp c s)
    then obtain c1 c2 where c: "c = Par c1 c2"
    and "mayDiverge c2 s" by blast
    then obtain c2' s' where "(c2,s) \<rightarrow>c (c2',s')"
    and "mayDiverge c2' s'" by (metis mayDiverge_transC)
    thus ?case using c ParCR by metis
  qed
 }
 thus ?thesis using assms by auto
qed

(* Configurations that must terminate: *)
definition mustT where
"mustT c s \<equiv> \<not> mayDiverge c s"

lemma transT_not_mustT:
assumes "(c,s) \<rightarrow>t s'"
shows "mustT c s"
by (metis assms mayDiverge_not_transT mustT_def)

lemma mustT_MtransC:
assumes "mustT c s" and "(c,s) \<rightarrow>*c (c',s')"
shows "mustT c' s'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> mustT c s \<longrightarrow> mustT c' s'"
  apply(erule MtransC_induct2) using mustT_transC by blast+
  thus ?thesis using assms by blast
qed

lemma mustT_Atm[simp]:
"mustT (Atm atm) s"
by (metis not_mayDiverge_Atm mustT_def)

lemma mustT_Seq_L:
assumes "mustT (c1 ;; c2) s"
shows "mustT c1 s"
by (metis PL.mayDiverge_Seq_L assms mustT_def)

lemma mustT_Seq_R:
assumes "mustT (c1 ;; c2) s" and "(c1, s) \<rightarrow>*t s'"
shows "mustT c2 s'"
by (metis Seq_MtransT_MtransC mustT_MtransC assms)

lemma mustT_If_L:
assumes "tval tst s" and "mustT (If tst c1 c2) s"
shows "mustT c1 s"
by (metis assms trans_IfTrue  mustT_transC)

lemma mustT_If_R:
assumes "\<not> tval tst s" and "mustT (If tst c1 c2) s"
shows "mustT c2 s"
by (metis assms trans_IfFalse  mustT_transC)

lemma mustT_If:
assumes "mustT (If tst c1 c2) s"
shows "mustT c1 s \<or> mustT c2 s"
by (metis assms mustT_If_L mustT_If_R)

lemma mustT_Par_L:
assumes "mustT (Par c1 c2) s"
shows "mustT c1 s"
by (metis assms mayDiverge_Par_L mustT_def)

lemma mustT_Par_R:
assumes "mustT (Par c1 c2) s"
shows "mustT c2 s"
by (metis assms mayDiverge_Par_R mustT_def)

(* Semantically deterministic commands: *)
definition determOn where
"determOn phi r \<equiv>
 \<forall> a b b'. phi a \<and> r a b \<and> r a b' \<longrightarrow> b = b'"

lemma determOn_seq_transT:
"determOn (\<lambda>(c,s). seq c) transT"
proof-
  {fix c s s1' s2'
   have "seq c \<and> (c,s) \<rightarrow>t s1' \<and> (c,s) \<rightarrow>t s2' \<longrightarrow> s1' = s2'"
   apply(induct c arbitrary: s1' s2') by auto
  }
  thus ?thesis unfolding determOn_def by fastforce
qed

end (* context PL *)
(*******************************************)

end


theory Compiler_Template
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))" |
  "[] !! i = undefined"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induct xs arbitrary: i) (auto simp: algebra_simps)

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

datatype instr =
  LOADI int | LOAD vname |
  ADD |
  STORE vname |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

(* note: by using hd / tl functions rather than pattern matching, we limit
  reliance on the structure of stk in the behavior of iexec, allowing us
  to simplify preconditions on lemmas that don't rely on the structure of
  the stack
*)
fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
  "iexec (LOAD x) (i, s, stk) = (i + 1, s, s x # stk)" |
  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
  "iexec (STORE x) (i, s, stk) = (i + 1, s(x := hd stk), tl stk)" |
  "iexec (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
  "iexec (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
  "iexec (JMPGE n) (i, s, stk) = (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk)"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

(* an introduction rule that expects the LHS config parameters to already be known *)
lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P !! i) (i, s, stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i, s, stk) \<rightarrow> c'"
  by (simp add: exec1_def)
code_pred exec1 by (metis exec1_def)

abbreviation exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

(* proof by case analysis on instructions, and that each case changes the PC relative to its
  initial value
*)
lemma iexec_shift [simp]:
  "(n + i', s', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
  (i', s', stk') = iexec x (i, s, stk)"
  by (cases x, auto)

(* trivial: iexec (P !! i) depends only on first i elements of P, and 0 \<le> i < size P *)
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow> c'"
  by (auto simp add: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
  by (induct rule: star.induct) (blast intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow> (i', s', stk') \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow> (size P' + i', s', stk')"
  by (auto simp add: exec1_def)

lemma exec_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')  \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow>* (size P' + i', s', stk')"
  by (induct rule: exec_induct) (blast intro: star.step exec1_appendL)+

(* specialize append lemmas to discuss execution through concrete instructions
  while assuming the execution of preceding and following code.
*)
lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0, s, stk) \<rightarrow>* (j, t, stk') \<Longrightarrow>
  instr # P \<turnstile> (1, s, stk) \<rightarrow>* (1 + j, t, stk')"
  by (drule exec_appendL [where P'="[instr]"]) simp

(* as exec_appendL, with (i := i - size P'), precondition necessary to satisfy exec1 precondition *)
lemma exec_appendL_if [intro]:
  fixes i i' j :: int
  shows "size P' <= i \<Longrightarrow>
    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk') \<Longrightarrow>
    i' = size P' + j \<Longrightarrow>
    P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
  by (drule exec_appendL [where P'=P']) simp

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk') \<Longrightarrow>
    size P \<le> i' \<Longrightarrow>
    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'') \<Longrightarrow>
    j'' = size P + i'' \<Longrightarrow>
    P @ P' \<turnstile> (0, s, stk) \<rightarrow>* (j'', s'', stk'')"
  by(metis star_trans [OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
  "acomp (N n) = [LOADI n]" |
  "acomp (V x) = [LOAD x]" |
  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
  by (induction a arbitrary: stk) fastforce+

(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
  step to next instruction upon the expression evaluating to False
  f = False means vice versa

  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
  (we know early that the And expression evaluates to False),
  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)

  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
  (we know early that the And expression evaluates to False),
  and to continue with b2 on True.
*)
fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
  "bcomp (And b1 b2) f n = (let
    cb2 = bcomp b2 f n;
    m = if f
      then size cb2
      else size cb2 + n;
    cb1 = bcomp b1 False m in
    cb1 @ cb2)" |
  "bcomp (Less a1 a2) f n =
    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
proof (induct b arbitrary: f n)
  case Not
  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)
    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
    And(2) [of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
  "ccomp SKIP = []" |
  "ccomp (x ::= a) = acomp a @ [STORE x]" |
  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
    cc\<^sub>1 = ccomp c\<^sub>1;
    cc\<^sub>2 = ccomp c\<^sub>2;
    cb = bcomp b False (size cc\<^sub>1 + 1) in
    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
  "ccomp (WHILE b DO c) = (let
    cc = ccomp c;
    cb = bcomp b False (size cc + 1) in
    cb @ cc @ [JMP (-(size cb + size cc + 1))])"

lemma ccomp_bigstep:
  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
proof(induct arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
    using Seq(2) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
    using Seq(4) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  and ?cw = "ccomp (WHILE b DO c)"
  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)" using \<open>bval b s1\<close> by fastforce
  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
    using WhileTrue(3) by fastforce
  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)" by fastforce
  ultimately show ?case using WhileTrue(5) by(blast intro: star_trans)
qed fastforce+

end


section {* Soundness Theorems *}

theory Wasm_Soundness imports Main Wasm_Properties begin

theorem preservation:
  assumes "\<turnstile> s;f;es : ts"
          "\<lparr>s;f;es\<rparr> \<leadsto> \<lparr>s';f';es'\<rparr>"
  shows "(\<turnstile> s';f';es' : ts) \<and> store_extension s s'"
proof -
  have "store_typing s" "s\<bullet>None \<tturnstile> f;es : ts"
    using assms(1) config_typing.simps
    by blast+
  hence "store_typing s'" "s'\<bullet>None \<tturnstile> f';es' : ts"
        "store_extension s s'"
    using assms(2)
          store_preserved
          types_preserved_e
    by blast+
  thus ?thesis
    using config_typing.intros
    by blast
qed

theorem progress:
  assumes "\<turnstile> s;f;es : ts"
  shows "const_list es \<or> es = [Trap] \<or> (\<exists>a s' f' es'. \<lparr>s;f;es\<rparr> \<leadsto> \<lparr>s';f';es'\<rparr>)"
proof -
  have "store_typing s" "s\<bullet>None \<tturnstile> f;es : ts"
    using assms config_typing.simps
    by blast+
  thus ?thesis
    using progress_e3
    by blast
qed

end