(*  Title:      JinjaDCI/BV/BVExec.thy

    Author:     Tobias Nipkow, Gerwin Klein, Susannah Mansky
    Copyright   2000 TUM, 2020 UIUC

    Based on the Jinja theory BV/BVExec.thy by Tobias Nipkow and Gerwin Klein
*)

section \<open> Kildall for the JVM \label{sec:JVM} \<close>

theory BVExec
imports Jinja.Abstract_BV TF_JVM
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow>
             instr list \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> ty\<^sub>i' err list"
where
  "kiljvm P mxs mxl T\<^sub>r is xt \<equiv>
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
          (exec P mxs T\<^sub>r xt is)"

definition wt_kildall :: "jvm_prog \<Rightarrow> cname \<Rightarrow> staticb \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                 instr list \<Rightarrow> ex_table \<Rightarrow> bool"
where
  "wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<equiv>
   0 < size is \<and>
   (let first  = Some ([],(case b of Static \<Rightarrow> [] | NonStatic \<Rightarrow> [OK (Class C')])
                            @(map OK Ts)@(replicate mxl\<^sub>0 Err));
        start  = (OK first)#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs
                   ((case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1)+size Ts+mxl\<^sub>0)
                     T\<^sub>r is xt start
    in \<forall>n < size is. result!n \<noteq> Err)"

definition wf_jvm_prog\<^sub>k :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog\<^sub>k P \<equiv>
  wf_prog (\<lambda>P C' (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt) P"

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
proof -
  let ?n = "length is"
  have "Semilat A r f" using semilat_JVM[OF wf]
    by (simp add: Semilat.intro sl_def2)
  moreover have "acc r" using wf by simp blast
  moreover have "top r Err" by (simp add: JVM_le_unfold)
  moreover have "pres_type step ?n A" by (rule exec_pres_type)
  moreover have "bounded step ?n" by (rule bounded_step)
  moreover have "mono r step ?n A" using step_mono[OF wf] by simp
  ultimately have "is_bcv r Err step ?n A (kildall r f step)"
    by(rule is_bcv_kildall)
  moreover have kileq: "kiljvm P mxs mxl T\<^sub>r is xt = kildall r f step"
    using f_def kiljvm_def r_def step_def_exec by blast
  ultimately show ?thesis by simp
qed
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x \<in> set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y) \<subseteq> {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is \<Longrightarrow> start \<in> list (size is) A"
  using Ts C
(*<*)
proof(cases b)
qed (force simp: JVM_states_unfold intro!: listI list_appendI
           dest!: in_set_replicate)+
(*>*)

theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  shows "\<exists>\<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from wtk obtain res where
    result:   "res = kiljvm P mxs mxl T\<^sub>r is xt start" and
    success:  "\<forall>n < size is. res!n \<noteq> Err" and
    instrs:   "0 < size is"
    by (unfold wt_kildall_def) simp

  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)

  from instrs have "start \<in> list (size is) A" ..
  with bcv success result have
    "\<exists>ts\<in>list (size is) A. start [\<sqsubseteq>\<^sub>r] ts \<and> wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain \<tau>s' where
    in_A: "\<tau>s' \<in> list (size is) A" and
    s:    "start [\<sqsubseteq>\<^sub>r] \<tau>s'" and
    w:    "wt_step r Err step \<tau>s'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step \<tau>s'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size \<tau>s' = size is" by simp
  moreover {
    from in_A  have "check_types P mxs mxl \<tau>s'" by (simp add: check_types_def)
    also from w have "\<forall>x \<in> set \<tau>s'. x \<noteq> Err"
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val \<tau>s') = \<tau>s'"
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val \<tau>s'))" .
  }
  moreover {
    from s have "start!0 \<sqsubseteq>\<^sub>r \<tau>s'!0" by (rule le_listD) simp
    moreover
    from instrs w l
    have "\<tau>s'!0 \<noteq> Err" by (unfold wt_step_def) simp
    then obtain \<tau>s0 where "\<tau>s'!0 = OK \<tau>s0" by auto
    ultimately
    have "wt_start P C b Ts mxl\<^sub>0 (map ok_val \<tau>s')" using l instrs
      by (unfold wt_start_def)
         (cases b; simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover
  from in_A have "set \<tau>s' \<subseteq> A" by simp
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)

theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  shows "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length \<tau>s = length is" and
    ck_type:  "check_types P mxs mxl (map OK \<tau>s)" and
    wt_start: "wt_start P C b Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK \<tau>s) \<subseteq> A"
    by (simp add: check_types_def)
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size \<tau>s) app eff) (map OK \<tau>s)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK \<tau>s)"
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start \<in> list (size is) A" ..
  moreover
  let ?\<tau>s = "map OK \<tau>s"
  have less_\<tau>s: "start [\<sqsubseteq>\<^sub>r] ?\<tau>s"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK \<tau>s)" by simp
  next
    fix n
    from wt_start have "P \<turnstile> ok_val (start!0) \<le>' \<tau>s!0"
      by (cases b; simp add: wt_start_def)
    moreover from instrs length have "0 < length \<tau>s" by simp
    ultimately have "start!0 \<sqsubseteq>\<^sub>r ?\<tau>s!0"
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None \<sqsubseteq>\<^sub>r ?\<tau>s!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
                 split: err.splits)
      hence "\<lbrakk>n = Suc n'; n < size start\<rbrakk> \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by simp
    }
    ultimately
    show "n < size start \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by (cases n, blast+)
  qed
  moreover
  from ck_type length
  have "?\<tau>s \<in> list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "\<forall>p. p < size is \<longrightarrow> kiljvm P  mxs mxl T\<^sub>r is xt start ! p \<noteq> Err"
    by (unfold is_bcv_def) blast
  with instrs
  show "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)

theorem jvm_kildall_correct:
  "wf_jvm_prog\<^sub>k P = wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C M. let (C,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C M in
              SOME \<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  let ?A = "\<lambda>P C' (M, b, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  let ?B\<^sub>\<Phi> = "\<lambda>\<Phi>. (\<lambda>P C (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)).
                wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"

  show ?thesis proof(rule iffI)
    \<comment> \<open>soundness\<close>
    assume wt: "wf_jvm_prog\<^sub>k P"
    then have "wf_prog ?A P" by(simp add: wf_jvm_prog\<^sub>k_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, b, Ts, T, m)" and
             "?A P Ca bd"
      then have "(?B\<^sub>\<Phi> ?\<Phi>) P Ca bd" using sees_method_is_class[OF sees]
        by (auto dest!: start_context.wt_kil_correct [OF start_context.intro]
                 intro: someI)
    }
    ultimately have "wf_prog (?B\<^sub>\<Phi> ?\<Phi>) P" by(rule wf_prog_lift)
    then have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P" by (simp add: wf_jvm_prog_phi_def)
    thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
  next
    \<comment> \<open>completeness\<close>
    assume wt: "wf_jvm_prog P"
    then obtain \<Phi> where "wf_prog (?B\<^sub>\<Phi> \<Phi>) P" by(clarsimp simp: wf_jvm_prog_def wf_jvm_prog_phi_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, b, Ts, T, m)" and
             "(?B\<^sub>\<Phi> \<Phi>) P Ca bd"
      then have "?A P Ca bd" using sees_method_is_class[OF sees]
        by (auto intro!: start_context.wt_kil_complete start_context.intro)
    }
    ultimately have "wf_prog ?A P" by(rule wf_prog_lift)
    thus "wf_jvm_prog\<^sub>k P" by (simp add: wf_jvm_prog\<^sub>k_def)
  qed
qed
(*>*)

end


(*  Title:      SSA_Semantics.thy
    Author:     Sebastian Ullrich
*)

section {* Proof of Semantic Equivalence *}

theory SSA_Semantics
imports SSA_CFG
begin

type_synonym ('node, 'var) state = "'var \<rightharpoonup> 'node"

context CFG_SSA_Transformed
begin
  definition step ::
    "'node \<Rightarrow> ('node, 'var) state \<Rightarrow> ('node, 'var) state"
  where
    "step m s v \<equiv> if v \<in> oldDefs m then Some m else s v"

  no_notation Refine_Basic.conc_fun ("\<Down>")

  inductive bs :: "'node list \<Rightarrow> ('node, 'var) state \<Rightarrow> bool" (infix "\<Down>" 50)
  where
    "Entry\<comment>ns\<rightarrow>last ns \<Longrightarrow> ns\<Down>(fold (step) ns Map.empty)"

  definition ssaStep ::
    "'node \<Rightarrow> nat \<Rightarrow> ('node, 'val) state \<Rightarrow> ('node, 'val) state"
  where
    "ssaStep m i s v \<equiv>
      if v \<in> defs m then
        Some m
      else
        case phis (m,v) of
          Some phiParams \<Rightarrow> s (phiParams ! i)
        | None \<Rightarrow> s v"

  inductive ssaBS :: "'node list \<Rightarrow> ('node, 'val) state \<Rightarrow> bool" (infix "\<Down>\<^sub>s" 50)
  where
    empty: "[Entry]\<Down>\<^sub>s(ssaStep (Entry) 0 Map.empty)"
  | snoc: "\<lbrakk>ns\<Down>\<^sub>ss; last ns = predecessors m ! i; m \<in> set \<alpha>n; i < length (predecessors m)\<rbrakk> \<Longrightarrow>
            (ns@[m])\<Down>\<^sub>s(ssaStep m i s)"

  lemma ssaBS_I:
    assumes "Entry\<comment>ns\<rightarrow>n"
    obtains s where "ns\<Down>\<^sub>ss"
  using assms
  proof (atomize_elim, induction rule:path2_rev_induct)
    case (snoc ns m' m)
    then obtain s where s: "ns\<Down>\<^sub>ss" by auto
    from snoc.hyps(2) obtain i where "m' = predecessors m ! i" "i < length (predecessors m)" by (auto simp:in_set_conv_nth)
    with snoc.hyps snoc.prems s show ?case by -(rule exI, erule ssaBS.snoc, auto dest:path2_last)
  qed (auto intro: ssaBS.empty)

  lemma ssaBS_nonempty[simp]: "\<not> ([]\<Down>\<^sub>ss)"
  by (rule notI, cases rule: ssaBS.cases, auto)

  lemma ssaBS_hd[simp]: "ns\<Down>\<^sub>ss \<Longrightarrow> hd ns = Entry"
    apply (induction rule: ssaBS.induct)
     apply (auto simp: hd_append)[1]
    by (case_tac ns; simp)

  lemma equiv_aux:
    assumes "ns\<Down>s" "ns\<Down>\<^sub>ss'" "last ns\<comment>ms\<rightarrow>m" "v \<in> allUses m" "\<forall>n \<in> set (tl ms). var v \<notin> var ` allDefs n"
    shows "s (var v) = s' v"
  using assms(2) assms(1,3-) proof (induction arbitrary: v s ms m)
    case empty
    have "v \<in> defs (Entry)"
    proof-
      from empty.prems(2,3) have "defAss m v" by - (rule allUses_def_ass, auto)
      with empty.prems(2) obtain n where n: "n \<in> set ms" "v \<in> allDefs n" by - (drule defAssD, auto)
      with empty.prems(4) have "n \<notin> set (tl ms)" by auto
      with empty.prems(2) n have "n = Entry" by (cases ms, auto dest: path2_hd)
      with n(2) show ?thesis by (auto simp: allDefs_def)
    qed
    with empty.prems(1) show ?case
      by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def split: option.split)
  next
    case (snoc ns s' n i)
    from snoc.prems(2) have[simp]: "n \<in> set \<alpha>n" "m \<in> set \<alpha>n" by auto
    from snoc.prems(2,3) have[simp]: "v \<in> allVars" by - (rule allUses_in_allVars, auto)
    from snoc.hyps(4) have[simp]: "n \<noteq> Entry" using Entry_unreachable len_greater_imp_nonempty by blast

    show ?case
    proof (cases "var v \<in> var ` allDefs n")
      case True

      have[simp]: "defNode v = n" (is "?n\<^sub>v = _")
      proof-
        from True obtain v' where v': "v' \<in> allDefs n" "var v' = var v" by auto
        from snoc.prems(3) have "defAss m v" by - (rule allUses_def_ass, auto)
        moreover from snoc.prems(1) obtain ns' where ns': "Entry\<comment>ns'\<rightarrow>n" "set ns' \<subseteq> set (ns@[n])" "distinct ns'"
          by (auto elim!: bs.cases intro: simple_path2)
        ultimately have "?n\<^sub>v \<in> set (ns'@tl ms)"
          using snoc.prems(2) by - (drule defAss_defNode, auto elim!: bs.cases dest: path2_app)
        moreover {
          let ?n'' = "last (butlast ns')"
          assume asm: "?n\<^sub>v \<in> set (butlast ns')"
          with ns'(1,3) have[simp]: "?n\<^sub>v \<noteq> n" by (cases ns' rule: rev_cases, auto dest!: path2_last)
          from ns'(1) have "length ns' \<ge> 2" using \<open>n \<noteq> Entry\<close> path2_nontrivial by blast
          with ns' have bns': "Entry\<comment>butlast ns'\<rightarrow>?n''" "?n'' \<in> set (predecessors n)"
            by (auto elim: path2_unsnoc)
          with asm obtain ns'' where ns'': "?n\<^sub>v\<comment>ns''\<rightarrow>?n''" "suffixeq ns'' (butlast ns')" "?n\<^sub>v \<notin> set (tl ns'')"
            by - (rule path2_split_first_last, auto)
          with bns' snoc.prems(2) have "?n\<^sub>v\<comment>(ns''@[n])@tl ms\<rightarrow>m" by - (rule path2_app, auto)
          hence "defNode v' \<notin> set (tl (ns''@[n]@tl ms))"
            using v' snoc.prems(3,4) bns'(2) ns''(1,3)
            by - (rule conventional''[of v _ m], auto intro!: path2_app simp: path2_not_Nil)
          with ns' ns''(1) v'(1) have False by (auto simp: path2_not_Nil)
        }
        ultimately show ?thesis using snoc.prems(4) ns'(1) by (cases ns' rule: rev_cases, auto dest: path2_last)
      qed
      from `v \<in> allVars` show ?thesis
      proof (cases rule: defNode_cases)
        case simpleDef
        thus ?thesis using snoc.prems(1) by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def)
      next
        case phi
        {
          fix v'
          assume asm: "v' \<in> defs n" "var v = var v'"
          with phi have "v' = v" using allDefs_var_disjoint[of n v' v]
            \<open>defNode v = n\<close> \<open>v \<in> allVars\<close> defNode(2) defs_in_allDefs snoc.hyps(3) by blast
          with asm(1) phi have False using simpleDefs_phiDefs_disjoint[of n]
            by (auto dest!: phi_phiDefs)
        }
        note 1 = this
        {
          fix vs
          assume asm: "Entry\<comment>ns @ [n]\<rightarrow>n" "phis (n, v) = Some vs" "var v \<notin> var ` defs n"
          let ?n' = "last ns"
          from asm(1) have "length ns \<ge> 1"
            by (metis One_nat_def \<open>n \<noteq> Entry\<close> append_Nil graph_path_base.path2_def le_0_eq length_0_conv list.sel(1) not_less_eq_eq)
          hence "Entry\<comment>ns\<rightarrow>?n'"
            by - (rule path2_unsnoc[OF asm(1)], auto)
          moreover have "vs ! i \<in> phiUses ?n'" using snoc.hyps(2,4) phis_wf[OF asm(2)]
            by - (rule phiUsesI[OF _ asm(2)], auto simp: set_zip)
          ultimately have "fold (step) ns Map.empty (var (vs ! i)) = s' (vs ! i)"
          by - (rule snoc.IH[where ms4="[?n']" and m4="?n'"], auto intro!: bs.intros)
          hence "fold (step) ns Map.empty (var v) = s' (vs ! i)" using phis_same_var[OF asm(2), of "vs ! i"] snoc.hyps(4) phis_wf[OF asm(2)]
            by auto
        }
        thus ?thesis using phi snoc.prems(1)
          by - (erule bs.cases, auto dest!: 1 simp: step_def ssaStep_def oldDefs_def phi_def)
      qed
    next
      case False
      hence "phis (n, v) = None" by (auto simp: allDefs_def phiDefs_def)
      moreover have "fold (step) ns Map.empty (var v) = s' v"
      proof-
        from snoc.hyps(1) have "length ns \<ge> 1" by (cases ns, auto)
        moreover from snoc.prems(2,4) False have "\<forall>n \<in> set ms. var v \<notin> var ` allDefs n"
          by (cases ms, auto simp: phiDefs_def dest: path2_hd)
        ultimately show ?thesis
          using snoc.prems(1,2,3) by - (rule snoc.IH[where ms4="last ns#ms"], auto elim!: bs.cases intro!: bs.intros elim: path2_unsnoc intro!: Cons_path2)
      qed
      ultimately show ?thesis
        using snoc.prems(1) False by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def defs_in_allDefs)
    qed
  qed

  theorem equiv:
    assumes "ns\<Down>s" "ns\<Down>\<^sub>ss'" "v \<in> uses (last ns)"
    shows "s (var v) = s' v"
  using assms by - (rule equiv_aux[where ms="[last ns]"], auto elim!: bs.cases)
end

end


(*  Title:      JinjaThreads/Compiler/Compiler1.thy
    Author:     Andreas Lochbihler, Tobias Nipkow

    Based on Jinja/Compiler/Compiler1
*)

header {* \isaheader{Compilation Stage 1} *}

theory Compiler1 imports
  PCompiler
  J1State
  ListIndex
begin

definition fresh_var :: "vname list \<Rightarrow> vname"
where "fresh_var Vs \<equiv> Auxiliary.concat (STR ''V'' # Vs)"

lemma fresh_var_fresh: "fresh_var Vs \<notin> set Vs"
proof -
  have "\<forall>V \<in> set Vs. length (String.explode V) < length (String.explode (fresh_var Vs))"
    by(induct Vs)(auto simp add: fresh_var_def Auxiliary.concat_def STR_inverse implode_def)
  thus ?thesis by auto
qed

text{* Replacing variable names by indices. *}

function compE1  :: "vname list \<Rightarrow> 'addr expr      \<Rightarrow> 'addr expr1"
  and compEs1 :: "vname list \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr1 list"
where
  "compE1 Vs (new C) = new C"
| "compE1 Vs (newA T\<lfloor>e\<rceil>) = newA T\<lfloor>compE1 Vs e\<rceil>"
| "compE1 Vs (Cast T e) = Cast T (compE1 Vs e)"
| "compE1 Vs (e instanceof T) = (compE1 Vs e) instanceof T"
| "compE1 Vs (Val v) = Val v"
| "compE1 Vs (Var V) = Var(index Vs V)"
| "compE1 Vs (e\<guillemotleft>bop\<guillemotright>e') = (compE1 Vs e)\<guillemotleft>bop\<guillemotright>(compE1 Vs e')"
| "compE1 Vs (V:=e) = (index Vs V):= (compE1 Vs e)"
| "compE1 Vs (a\<lfloor>i\<rceil>) = (compE1 Vs a)\<lfloor>compE1 Vs i\<rceil>"
| "compE1 Vs (a\<lfloor>i\<rceil>:=e) = (compE1 Vs a)\<lfloor>compE1 Vs i\<rceil>:=compE1 Vs e"
| "compE1 Vs (a\<bullet>length) = compE1 Vs a\<bullet>length"
| "compE1 Vs (e\<bullet>F{D}) = compE1 Vs e\<bullet>F{D}"
| "compE1 Vs (e\<bullet>F{D}:=e') = compE1 Vs e\<bullet>F{D}:=compE1 Vs e'"
| "compE1 Vs (e\<bullet>M(es)) = (compE1 Vs e)\<bullet>M(compEs1 Vs es)"
| "compE1 Vs {V:T=vo; e} = {(size Vs):T=vo; compE1 (Vs@[V]) e}"
| "compE1 Vs (sync\<^bsub>U\<^esub> (o') e) = sync\<^bsub>length Vs\<^esub> (compE1 Vs o') (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (insync\<^bsub>U\<^esub> (a) e) = insync\<^bsub>length Vs\<^esub> (a) (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (e1;;e2) = (compE1 Vs e1);;(compE1 Vs e2)"
| "compE1 Vs (if (b) e1 else e2) = (if (compE1 Vs b) (compE1 Vs e1) else (compE1 Vs e2))"
| "compE1 Vs (while (b) e) = (while (compE1 Vs b) (compE1 Vs e))"
| "compE1 Vs (throw e) = throw (compE1 Vs e)"
| "compE1 Vs (try e1 catch(C V) e2) = try(compE1 Vs e1) catch(C (size Vs)) (compE1 (Vs@[V]) e2)"

| "compEs1 Vs []     = []"
| "compEs1 Vs (e#es) = compE1 Vs e # compEs1 Vs es"
by pat_completeness auto
termination
apply(relation "case_sum (\<lambda>p. size (snd p)) (\<lambda>p. size_list size (snd p)) <*mlex*> {}")
apply(rule wf_mlex[OF wf_empty])
apply(rule mlex_less, simp)+
done

lemmas compE1_compEs1_induct =
  compE1_compEs1.induct[case_names New NewArray Cast InstanceOf Val Var BinOp LAss AAcc AAss ALen FAcc FAss Call Block Synchronized InSynchronized Seq Cond While throw TryCatch Nil Cons]

lemma compEs1_conv_map [simp]: "compEs1 Vs es = map (compE1 Vs) es"
by(induct es) simp_all

lemmas compEs1_map_Val = compEs1_conv_map

lemma compE1_eq_Val [simp]: "compE1 Vs e = Val v \<longleftrightarrow> e = Val v"
apply(cases e, auto)
done

lemma Val_eq_compE1 [simp]: "Val v = compE1 Vs e \<longleftrightarrow> e = Val v"
apply(cases e, auto)
done

lemma compEs1_eq_map_Val [simp]: "compEs1 Vs es = map Val vs \<longleftrightarrow> es = map Val vs"
apply(induct es arbitrary: vs)
apply(auto, blast)
done

lemma compE1_eq_Var [simp]: "compE1 Vs e = Var V \<longleftrightarrow> (\<exists>V'. e = Var V' \<and> V = index Vs V')"
by(cases e, auto)

lemma compE1_eq_Call [simp]:
  "compE1 Vs e = obj\<bullet>M(params) \<longleftrightarrow> (\<exists>obj' params'. e = obj'\<bullet>M(params') \<and> compE1 Vs obj' = obj \<and> compEs1 Vs params' = params)"
by(cases e, auto)

lemma length_compEs2 [simp]:
  "length (compEs1 Vs es) = length es"
by(simp add: compEs1_conv_map)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows expr_locks_compE1 [simp]: "expr_locks (compE1 Vs e) = expr_locks e"
  and expr_lockss_compEs1 [simp]: "expr_lockss (compEs1 Vs es) = expr_lockss es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)(auto intro: ext)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows contains_insync_compE1 [simp]: "contains_insync (compE1 Vs e) = contains_insync e"
  and contains_insyncs_compEs1 [simp]: "contains_insyncs (compEs1 Vs es) = contains_insyncs es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)simp_all

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows max_vars_compE1: "max_vars (compE1 Vs e) = max_vars e"
  and max_varss_compEs1: "max_varss (compEs1 Vs es) = max_varss es"
apply(induct Vs e and Vs es rule: compE1_compEs1.induct)
apply(auto)
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows \<B>: "size Vs = n \<Longrightarrow> \<B> (compE1 Vs e) n"
  and \<B>s: "size Vs = n \<Longrightarrow> \<B>s (compEs1 Vs es) n"
apply(induct Vs e and Vs es arbitrary: n and n rule: compE1_compEs1.induct)
apply auto
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows fv_compE1: "fv e \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs e) = (index Vs) ` (fv e)"
  and fvs_compEs1: "fvs es \<subseteq> set Vs \<Longrightarrow> fvs (compEs1 Vs es) = (index Vs) ` (fvs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  have IH: "fv exp \<subseteq> set (Vs @ [V]) \<Longrightarrow> fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" by fact
  from `fv {V:ty=vo; exp} \<subseteq> set Vs` have fv': "fv exp \<subseteq> set (Vs @ [V])" by auto
  from IH[OF this] have IH': "fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" .
  have "fv (compE1 (Vs @ [V]) exp) - {length Vs} = index Vs ` (fv exp - {V})"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    hence "x \<noteq> length Vs" by simp
    from x IH' have "x \<in> index (Vs @ [V]) ` fv exp" by simp
    thus "x \<in> index Vs ` (fv exp - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y \<in> fv exp"
      have "y \<noteq> V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with `x \<noteq> length Vs` show False by contradiction
      qed
      moreover with fv' y have "y \<in> set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y `y \<noteq> V` by auto
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` (fv exp - {V})"
    thus "x \<in> fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp - {V}"
      with fv' have "y \<in> set Vs" "y \<noteq> V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x \<in> index (Vs @ [V]) ` fv exp" by auto
      thus ?thesis using IH' `y \<in> set Vs` by simp
    qed
  qed
  thus ?case by simp
next
  case (Synchronized Vs V exp1 exp2)
  have IH1: "fv exp1 \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs exp1) = index Vs ` fv exp1"
    and IH2: "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> fv (compE1 (Vs @ [fresh_var Vs]) exp2) = index (Vs @ [fresh_var Vs]) ` fv exp2"
    by fact+
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set Vs" by auto
  from fv2 have fv2': "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp2 = index Vs ` fv exp2"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus "x \<in> index Vs ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y \<in> fv exp2"
      from y fv2 have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately show ?thesis using y by(auto)
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` fv exp2"
    thus "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp2"
      from y fv2 have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by(auto)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] show ?case by(auto)
next
  case (InSynchronized Vs V a exp)
  have IH: "fv exp \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> fv (compE1 (Vs @ [fresh_var Vs]) exp) = index (Vs @ [fresh_var Vs]) ` fv exp"
    by fact
  from `fv (insync\<^bsub>V\<^esub> (a) exp) \<subseteq> set Vs` have fv: "fv exp \<subseteq> set Vs" by simp
  hence fv': "fv exp \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp = index Vs ` fv exp"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    thus "x \<in> index Vs ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y \<in> fv exp"
      from y fv have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index (Vs @ [fresh_var Vs]) y = index Vs y" by simp
      thus ?thesis using y by simp
    qed
  next
    fix x
    assume "x \<in> index Vs ` fv exp"
    thus "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp"
      from y fv have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by auto
    qed
  qed
  with IH[OF fv'] show ?case by simp
next
  case (TryCatch Vs exp1 C V exp2)
  have IH1: "fv exp1 \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs exp1) = index Vs ` fv exp1"
    and IH2: "fv exp2 \<subseteq> set (Vs @ [V]) \<Longrightarrow> fv (compE1 (Vs @ [V]) exp2) = index (Vs @ [V]) ` fv exp2"
    by fact+
  from `fv (try exp1 catch(C V) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set (Vs @ [V])" by auto
  have "index (Vs @ [V]) ` fv exp2 - {length Vs} = index Vs ` (fv exp2 - {V})"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> index (Vs @ [V]) ` fv exp2 - {length Vs}"
    hence "x \<noteq> length Vs" by simp
    from x have "x \<in> index (Vs @ [V]) ` fv exp2" by auto
    thus "x \<in> index Vs ` (fv exp2 - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y \<in> fv exp2"
      have "y \<noteq> V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with `x \<noteq> length Vs` show False by contradiction
      qed
      moreover with fv2 y have "y \<in> set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y `y \<noteq> V` by auto
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` (fv exp2 - {V})"
    thus "x \<in> index (Vs @ [V]) ` fv exp2 - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp2 - {V}"
      with fv2 have "y \<in> set Vs" "y \<noteq> V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x \<in> index (Vs @ [V]) ` fv exp2" by auto
      thus ?thesis using `y \<in> set Vs` by simp
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed(auto)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows syncvars_compE1: "fv e \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs e)"
  and syncvarss_compEs1: "fvs es \<subseteq> set Vs \<Longrightarrow> syncvarss (compEs1 Vs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  from `fv {V:ty=vo; exp} \<subseteq> set Vs` have "fv exp \<subseteq> set (Vs @ [V])" by auto
  from `fv exp \<subseteq> set (Vs @ [V]) \<Longrightarrow> syncvars (compE1 (Vs @ [V]) exp)`[OF this] show ?case by(simp)
next
  case (Synchronized Vs V exp1 exp2)
  note IH1 = `fv exp1 \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs exp1)`
  note IH2 = `fv exp2 \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> syncvars (compE1 (Vs @ [fresh_var Vs]) exp2)`
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set Vs" and fv2': "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "length Vs \<notin> index (Vs @ [fresh_var Vs]) ` fv exp2"
  proof
    assume "length Vs \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x \<in> fv exp2"
      from x' fv2 have "x \<in> set Vs" "x \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] fv2' show ?case by(simp add: fv_compE1)
next
  case (InSynchronized Vs V a exp)
  note IH = `fv exp \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> syncvars (compE1 (Vs @ [fresh_var Vs]) exp)`
  from `fv (insync\<^bsub>V\<^esub> (a) exp) \<subseteq> set Vs` have fv: "fv exp \<subseteq> set Vs"
    and fv': "fv exp \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "length Vs \<notin> index (Vs @ [fresh_var Vs]) ` fv exp"
  proof
    assume "length Vs \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x \<in> fv exp"
      from x' fv have "x \<in> set Vs" "x \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH[OF fv'] fv' show ?case by(simp add: fv_compE1)
next
  case (TryCatch Vs exp1 C V exp2)
  note IH1 = `fv exp1 \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs exp1)`
  note IH2 = `fv exp2 \<subseteq> set (Vs @ [V]) \<Longrightarrow> syncvars (compE1 (Vs @ [V]) exp2)`
  from `fv (try exp1 catch(C V) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set (Vs @ [V])" by auto
  from IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed auto

lemma (in heap_base) synthesized_call_compP [simp]:
  "synthesized_call (compP f P) h aMvs = synthesized_call P h aMvs"
by(simp add: synthesized_call_def)

primrec fin1 :: "'addr expr \<Rightarrow> 'addr expr1"
where
  "fin1 (Val v) = Val v"
| "fin1 (throw e) = throw (fin1 e)"

lemma comp_final: "final e \<Longrightarrow> compE1 Vs e = fin1 e"
by(erule finalE, simp_all)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows [simp]: "max_vars (compE1 Vs e) = max_vars e"
  and "max_varss (compEs1 Vs es) = max_varss es"
by (induct Vs e and Vs es rule: compE1_compEs1_induct)(simp_all)

text{* Compiling programs: *}

definition compP1 :: "'addr J_prog \<Rightarrow> 'addr J1_prog"
where
  "compP1  \<equiv>  compP (\<lambda>C M Ts T (pns,body). compE1 (this#pns) body)"

declare compP1_def[simp]

end


theory ARMv8_Syntax
  imports ARMv8_Rules ARMv8_Inter
begin

datatype register = r\<^sub>0 | r\<^sub>1 | r\<^sub>2 | r\<^sub>3 | r\<^sub>4 | r\<^sub>5

syntax
  "_quote"     :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"                ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"                ("\<acute>_" [1000] 1000)
  "_Assert"    :: "'a \<Rightarrow> 'a set"                    ("(\<llangle>_\<rrangle>)" [0] 1000)

translations
  "\<llangle>b\<rrangle>" \<rightharpoonup> "CONST Collect \<guillemotleft>b\<guillemotright>"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr \<^syntax_const>\<open>_antiquote\<close> t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(\<^syntax_const>\<open>_quote\<close>, K quote_tr)] end
\<close>

type_synonym ('v,'r,'a) thread = "(('v,'a) grel \<times> ('v,'a) grel \<times> ('v,'r,'a) pred \<times> ('v,'r,'a) pred \<times> ('v,'r,'a) com_armv8 \<times> ('v,'r,'a) pred)"
type_synonym ('v,'r,'a) threads = "('v,'r,'a) thread list"

definition addI
  where "addI I \<equiv> \<lambda>x. x ! 0 + I"

definition subI
  where "subI I \<equiv> \<lambda>x. x ! 0 - I"

definition addR
  where "addR \<equiv> \<lambda>x. x ! 0 + x ! 1"

definition subR
  where "subR \<equiv> \<lambda>x. x ! 0 - x ! 1"

definition modI
  where "modI I \<equiv> \<lambda>x. x ! 0 mod I"

definition modR
  where "modR \<equiv> \<lambda>x. x ! 0 mod x ! 1"

definition movI
  where "movI I \<equiv> \<lambda>x. I"

definition ODD :: "'b \<Rightarrow> ((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp)"
  where "ODD r = (Exp (\<lambda>x. x ! 0 mod 2) [Var r], (=), Val 1)"

definition NEQ :: "'b \<Rightarrow> 'b \<Rightarrow> ((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp)"
  where "NEQ r1 r2 = (Var r1, (\<noteq>), Var r2)"

definition LE :: "'b \<Rightarrow> 'b \<Rightarrow> ((nat,'b) bexp)"
  where "LE r1 r2 = Exp\<^sub>B (\<lambda>x. x!0 < x!1) [Var r1, Var r2]"

definition Z ::  "'b \<Rightarrow> ((nat,'b) bexp)"
  where "Z r = Exp\<^sub>B (\<lambda>x. x!0 = 0) [Var r]"

syntax
  "_Load"  :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("(_ := [_]~_)" [70, 65] 61)
  "_LoadC"  :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> 'c \<Rightarrow> ('v,'r,'a) com_armv8" ("(_ := [_ + #_]~_)" [70, 65] 61)
  "_LoadIC"  :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> 'c \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> _ := [_ + #_]~_)" [20, 70, 65] 61)

  "_Store" :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("([_] := _ ~ _)" [70, 65] 61)
  "_StoreI" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'v \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> [_ + #_] := _ ~ _)" [20, 70, 65] 61)
  "_StoreIA" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'v \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) auxfn  \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> [_ + #_] := _ ~ _ :\<^sub>a _)" [20, 70, 65] 61)

  "_Fence" :: "(nat,'b,'a) com_armv8" ("(fence)" 61)
  "_CFence" :: "(nat,'b,'a) com_armv8" ("(cfence)" 61)
  "_Cas" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) auxfn  \<Rightarrow> ('v,'b,'a) com_armv8" ("(\<lbrace>_\<rbrace> _ := cas _ _ _ ~ _, _)" [20, 70, 65] 61)

  "_AddI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ + #_)" [70, 65, 65] 61)
  "_SubI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ - #_)" [70, 65, 65] 61)

  "_AddR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ + _)" [70, 65, 65] 61)
  "_SubR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ - _)" [70, 65, 65] 61)

  "_ModI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ % #_)" [70, 65, 65] 61)
  "_ModR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ % _)" [70, 65, 65] 61)
  "_MovI"  :: "'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := #_)" [70, 65] 61)
  "_Seq"   :: "(nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8" ("(_;/ _)" [60,61] 60)

  "_If" :: "((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp) \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8"
                ("(if _/ then _ //else _ /fi)"   [0,0,0] 61)
  "_If1" :: "'b \<Rightarrow> ('v,'r,'a) com_armv8 \<Rightarrow> ('v,'r,'a) com_armv8"
                ("(if _/ then _ /fi)"   [0,0] 61)
  "_Spec" :: "('v,'a) grel \<Rightarrow> ('v,'a) grel \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) com_armv8 \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) thread"
                ("(R: _ //G:_ //I: _ //P: _ //{ _ } //Q: _)" [0,0,0,0] 61)
  "_AuxAssign"    :: "idt \<Rightarrow> 'b \<Rightarrow> ('v,'r,'a) auxfn" ("(\<^sup>a_ :=/ _)" [70, 65] 61)

translations
  "\<^sup>ax := a" \<rightharpoonup> "CONST state_rec.more o \<guillemotleft>\<acute>(state_rec.more_update (_update_name x (\<lambda>_. a)))\<guillemotright>"

  "x := [a]~v" \<rightharpoonup> "CONST Load (CONST UNIV) v (CONST Var a) x (CONST state_rec.more)"
  "x := [a + #I]~v" \<rightharpoonup> "CONST Load (CONST UNIV) v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> x := [a + #I]~v" \<rightharpoonup> "CONST Load \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"

  "[a] := r ~ v" \<rightharpoonup> "CONST Store (CONST UNIV) v (CONST Var a) r (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> [a + #I] := x ~ v" \<rightharpoonup> "CONST Store \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> [ra + #I] := r ~ v :\<^sub>a a" \<rightharpoonup> "CONST Store \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var ra]) r a"

  "\<lbrace>P\<rbrace> r\<^sub>1 := cas r\<^sub>2 r\<^sub>3 r\<^sub>4 ~ v, a" \<rightharpoonup> "CONST CAS \<llangle>P\<rrangle> v r\<^sub>2 r\<^sub>3 r\<^sub>4 r\<^sub>1 1 0 a"

  "X := Y - #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST subI I) [CONST Var Y])"
  "X := Y + #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST addI I) [CONST Var Y])"
  "X := Y + Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST addR) [CONST Var Y, CONST Var Z])"
  "X := Y - Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST subR) [CONST Var Y, CONST Var Z])"
  "X := Y % #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST modI I) [CONST Var Y])"
  "X := Y % Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST modR) [CONST Var Y, CONST Var Z])"

  "X := #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST movI I) [])"
  "fence" \<rightharpoonup> "CONST Fence"
  "cfence" \<rightharpoonup> "CONST Fence"
  "c\<^sub>1 ; c\<^sub>2" \<rightharpoonup> "CONST Seq c\<^sub>1 c\<^sub>2"
  "if b then c\<^sub>1 else c\<^sub>2 fi" \<rightharpoonup> "CONST If b c\<^sub>1 c\<^sub>2"
  "if b then c\<^sub>1 fi" \<rightharpoonup> "CONST If b c\<^sub>1 (CONST Skip)"
  "R: R G: G I: I P: P {c} Q: Q" \<rightharpoonup> "(\<llangle>R\<rrangle>,\<llangle>G\<rrangle>,\<llangle>I\<rrangle>,\<llangle>P\<rrangle>,c,\<llangle>Q\<rrangle>)"

definition inv2
  where "inv2 I \<equiv> {(m,m'). m \<in> glb ` I \<longrightarrow> m' \<in> glb ` I}"

fun fn_valid :: "('v::equal,'r::equal,'a) threads \<Rightarrow> bool"
  where
    "fn_valid [(R,G,I,P,c,Q)] = (stable\<^sub>t R Q \<and> wellformed R G \<and> guar\<^sub>c c (inv2 I \<inter> G) \<and>
                                (stable\<^sub>t R Q \<longrightarrow> P \<subseteq> wp (inv2 I \<inter> R) c Q) \<and>
                                (wellformed R G \<longrightarrow> rif_checks c R G))" |
    "fn_valid _ = undefined"

nonterminal prgs

syntax
  "_PAR"        :: "prgs \<Rightarrow> 'a"              ("COBEGIN//_//COEND" 60)
  "_FN"        :: "prgs \<Rightarrow> 'a"              ("FNBEGIN//_//FNEND" 60)
  "_prg"        :: "'a \<Rightarrow> prgs"              ("_" 57)
  "_prgs"       :: "['a, prgs] \<Rightarrow> prgs"      ("_//\<parallel>//_" [60,57] 57)

translations
  "_prg a" \<rightharpoonup> "[a]"
  "_prgs a ps" \<rightharpoonup> "a # ps"
  "_FN t" \<rightharpoonup> "CONST fn_valid t"

syntax
  "_before"  :: "'b \<Rightarrow> 'a" ("\<^sup>1_" [100] 400)
  "_after"   :: "'b \<Rightarrow> 'a" ("\<^sup>2_" [100] 400)
  "_mem"     :: "'g \<Rightarrow> 'a" ("\<^sup>s[_]")
  "_mbefore" :: "'g \<Rightarrow> 'a" ("\<^sup>1[_]")
  "_mafter"  :: "'g \<Rightarrow> 'a" ("\<^sup>2[_]")
  "_reg"     :: "'r \<Rightarrow> 'a" ("\<^sup>r_" [100] 1000)
  "_rbefore" :: "'r \<Rightarrow> 'a" ("\<^sup>1\<^sup>r_")
  "_rafer"   :: "'r \<Rightarrow> 'a" ("\<^sup>2\<^sup>r_")
  "_aux"     :: "'b \<Rightarrow> 'a" ("\<^sup>a_" [100] 1000)
  "_abefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<^sup>a_" [100] 400)
  "_aafer"   :: "'b \<Rightarrow> 'a" ("\<^sup>2\<^sup>a_" [100] 400)

definition gld :: "('v,'r,'a) state \<Rightarrow> ('v \<Rightarrow> 'v)"
  where "gld m \<equiv> \<lambda>v. st m (Glb v)"

translations
  "\<^sup>1x" \<rightleftharpoons> "x (\<acute>CONST fst)"
  "\<^sup>2x" \<rightleftharpoons> "x (\<acute>CONST snd)"
  "\<^sup>s[X]" \<rightleftharpoons> "(\<acute>CONST gld) X"
  "\<^sup>1[X]" \<rightleftharpoons> "(CONST st (\<acute>CONST fst)) X"
  "\<^sup>2[X]" \<rightleftharpoons> "(CONST st (\<acute>CONST snd)) X"
  "\<^sup>rX" \<rightleftharpoons> "(\<acute>CONST rg) X"
  "\<^sup>1\<^sup>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST fst)) X"
  "\<^sup>2\<^sup>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST snd)) X"
  "\<^sup>aX" \<rightleftharpoons> "X (\<acute>CONST state_rec.more)"
  "\<^sup>1\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST fst))"
  "\<^sup>2\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST snd))"

(*
syntax
  "_before"  :: "'b \<Rightarrow> 'a" ("\<^sup>1_" [100] 400)
  "_after"   :: "'b \<Rightarrow> 'a" ("\<^sup>2_" [100] 400)
  "_mem"     :: "'b \<Rightarrow> 'a" ("\<lbrakk>_\<rbrakk>")
  "_mat"     :: "'b \<Rightarrow> 'a" ("\<^sup>0\<lbrakk>_\<rbrakk>")
  "_mbefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<lbrakk>_\<rbrakk>")
  "_mafter"  :: "'b \<Rightarrow> 'a" ("\<^sup>2\<lbrakk>_\<rbrakk>")
  "_reg"     :: "'r \<Rightarrow> 'a" ("\<^bold>r_" [1000] 1000)
  "_rar"     :: "'r \<Rightarrow> 'a" ("\<^sup>0\<^bold>r_" [100] 1000)
  "_rbefore" :: "'r \<Rightarrow> 'a" ("\<^sup>1\<^bold>r_")
  "_rafer"   :: "'r \<Rightarrow> 'a" ("\<^sup>2\<^bold>r_")
  "_val"     :: "'b \<Rightarrow> 'a" ("#_" [100] 1000)
  "_aux"     :: "'b \<Rightarrow> 'a" ("\<^sup>a_" [100] 1000)
  "_abefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<^sup>a_" [100] 400)
  "_aafer"   :: "'b \<Rightarrow> 'a" ("\<^sup>2\<^sup>a_" [100] 400)

translations
  "\<^sup>1x" \<rightleftharpoons> "x (\<acute>CONST fst)"
  "\<^sup>2x" \<rightleftharpoons> "x (\<acute>CONST snd)"
  "\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "CONST Var (CONST Glb X)"
  "\<^sup>0\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST glb)) X"
  "\<^sup>1\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST fst)) X"
  "\<^sup>2\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST snd)) X"
  "\<^bold>rX" \<rightleftharpoons> "CONST Var (CONST Var X)"
  "\<^sup>0\<^bold>rX" \<rightleftharpoons> "(\<acute>CONST rg) X"
  "\<^sup>1\<^bold>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST fst)) X"
  "\<^sup>2\<^bold>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST snd)) X"
  "#X" \<rightleftharpoons> "CONST Val X"
  "\<^sup>aX" \<rightleftharpoons> "X (\<acute>CONST state_rec.more)"
  "\<^sup>1\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST fst))"
  "\<^sup>2\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST snd))"
*)

syntax
  "_con" :: "nat \<Rightarrow> 'a" ("=[_]" [100] 1000)
  "_inc" :: "nat \<Rightarrow> 'a" ("\<le>[_]" [100] 1000)

translations
  "=[X]" \<rightharpoonup> "(CONST st (\<acute>CONST snd)) X = (CONST st (\<acute>CONST fst)) X"
  "\<le>[X]" \<rightharpoonup> "(CONST st (\<acute>CONST snd)) X \<ge> (CONST st (\<acute>CONST fst)) X"

lemma [simp]:
  "reflexive R \<Longrightarrow> stabilize R {} = {}"
  by (auto simp: reflexive_def stabilize_def)

lemma [simp]:
  "reflexive R \<Longrightarrow> stabilize R (assert P) = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "{m. m(a :=\<^sub>s e) \<in> (assert P)} = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "reflexive R \<Longrightarrow> UNIV \<subseteq> stabilize R P = (\<forall>m. m \<in> P)"
  by (auto simp: reflexive_def stabilize_def assert_def glb_def)

lemma [simp]:
  "stabilize R (P \<inter> Q) = stabilize R P \<inter> stabilize R Q"
  by (auto simp: stabilize_def)

lemma [simp]:
  "{m. (f m) \<in> assert P} = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "UNIV \<subseteq> assert P = P"
  by (auto simp: assert_def)

lemma [simp]:
  "x(aux: state_rec.more) = x"
  by (auto simp: aux_upd_def)

lemma [simp]:
  "st (glb (x(Glb z :=\<^sub>s e))) = (st (glb x))(z := e)"
  by (auto simp: st_upd_def glb_def)

lemma [simp]:
  "st (glb (x(aux:f ))) = (st (glb x))"
  by (auto simp: st_upd_def glb_def)

lemma glb_in [intro!]:
  assumes "\<exists>l. \<lparr> st = (\<lambda>v. case v of Reg v \<Rightarrow> l v | _ \<Rightarrow> st m v), \<dots> = state_rec.more m \<rparr> \<in> P"
  shows "glb m \<in> glb ` P"
proof -
  obtain l where "\<lparr> st = (\<lambda>v. case v of Reg v \<Rightarrow> l v | _ \<Rightarrow> st m v), \<dots> = state_rec.more m \<rparr> \<in> P"
    (is "?m \<in> P")
    using assms by auto
  hence "glb ?m \<in> glb ` P" by auto
  moreover have "glb m = glb ?m" by (auto simp: glb_def)
  ultimately show ?thesis by auto
qed

lemma  a:
  "glb x = glb y \<Longrightarrow> st x (Glb e) = st y (Glb e)"
  unfolding glb_def
  by (metis state_rec.select_convs(1))

lemma  b:
  "glb x = glb y \<Longrightarrow> state_rec.more x = state_rec.more y"
  unfolding glb_def by simp

lemma [simp]:
  "st (glb x) y = st x (Glb y)"
  unfolding glb_def by auto

fun chain
  where "chain [] Q = Q" | "chain (a#xs) Q = chain xs (wpre a Q)"
declare chain.simps [simp del]

lemma chain_singleI:
  "wpre a Q = chain [a] Q"
  unfolding chain.simps by auto

lemma chain_singleI':
  "stabilize R Q = chain [env R] Q"
  unfolding chain.simps by auto

lemma chain_lastE:
  "chain (xs @ [a]) Q = wpre a ( (chain xs Q))"
  by (induct xs arbitrary: Q) (auto simp: chain.simps)

lemma chain_lastI:
  "chain [a] (chain xs Q) = chain (xs@[a]) Q"
  by (induct xs) (auto simp: chain_lastE chain.simps)

lemma chain_merge:
  "chain l (chain l' Q) = chain (l'@l) Q"
  by (induct l' arbitrary: Q) (simp add: chain.simps)+

lemma stabilize_mono:
  "P \<subseteq> Q \<Longrightarrow> stabilize R P  \<subseteq> stabilize R Q"
  unfolding stabilize_def by auto

lemma pre_mono:
  "P \<subseteq> Q \<Longrightarrow> wpre a P \<subseteq> wpre a Q"
  using  stabilize_mono apply (cases a) apply (auto)
  by blast

lemma chain_mono:
  "P \<subseteq> Q \<Longrightarrow> chain xs P \<subseteq> chain xs Q"
  by (induct xs arbitrary: P Q) (auto simp: pre_mono stabilize_mono chain.simps)

lemma chain1_wpre:
  "P \<subseteq> chain xs (wpre a Q) \<Longrightarrow> P \<subseteq> chain (a#xs) Q"
  unfolding chain.simps .

lemma chain1_stab:
  "P \<subseteq> chain xs (stabilize R Q) \<Longrightarrow> P \<subseteq> chain (env R#xs) Q"
  unfolding chain.simps by auto

lemma chain0:
  "P \<subseteq> Q \<Longrightarrow> P \<subseteq>  chain [] Q"
  unfolding chain.simps .

lemma chain_extend:
  "P \<subseteq> chain xs (Q \<inter> X) \<Longrightarrow> P \<subseteq> chain xs Q"
  using chain_mono[of "Q \<inter> X" Q] by (auto simp: )

lemma chain_rewrite:
  "X \<subseteq> Q \<Longrightarrow> P \<subseteq> chain xs X \<Longrightarrow> P \<subseteq> chain xs Q"
  using chain_mono  by blast

definition str where
  "str R P \<equiv> if P \<subseteq> stabilize R P then P else UNIV"

lemma str_mono:
  "Q \<subseteq> P \<Longrightarrow> Q \<subseteq> str R P"
  unfolding str_def by (auto simp: )

lemma stabilize_univ:
  "UNIV \<subseteq> stabilize R UNIV"
  unfolding stabilize_def by auto

lemma stabilize_str:
  "str R P \<subseteq> stabilize R (str R P)"
  unfolding str_def stabilize_def by simp

lemma [simp]: "wpre a (P \<inter> Q) = (wpre a P \<inter> wpre a Q)"
  by (cases a, auto)

lemma chain_inter: "chain l (P \<inter> Q) = (chain l P \<inter> chain l Q)"
  by (induct l arbitrary: P Q, auto simp: chain.simps)

lemma stable_stabilize:
  "stable\<^sub>t R Q \<Longrightarrow> Q \<subseteq> stabilize R Q"
  unfolding stabilize_def stable_def step\<^sub>t_def
  by auto

lemma strI:
  "stable\<^sub>t R Q \<Longrightarrow> K \<subseteq> chain l (str R Q) \<Longrightarrow>  K \<subseteq> chain (env R#l) Q"
  unfolding chain.simps str_def apply simp
  using stable_stabilize
  by (metis (mono_tags) chain_rewrite)

lemma envI:
  "stable\<^sub>t R Q \<Longrightarrow> K \<subseteq> chain l (Q) \<Longrightarrow>  K \<subseteq> chain (env R#l) Q"
  unfolding chain.simps str_def apply simp
  using stable_stabilize
  by (metis (mono_tags) chain_rewrite)

lemma ir_str:
  "wpre (ir r e) (str R Q) \<supseteq> str R (wpre (ir r e) Q)"
  apply (auto simp: str_def stabilize_def st_upd_def)
   apply (subgoal_tac "rg (x\<lparr>st := (st x)(Reg r := ev\<^sub>E (rg m') e)\<rparr>) = rg (m'\<lparr>st := (st m')(Reg r := ev\<^sub>E (rg m') e)\<rparr>)")
     apply (subgoal_tac "(glb (x\<lparr>st := (st x)(Reg r := ev\<^sub>E (rg m') e)\<rparr>), glb (m'\<lparr>st := (st m')(Reg r := ev\<^sub>E (rg m') e)\<rparr>)) \<in> R")
     apply blast
  apply (auto simp: glb_def)[1]
  unfolding rg_def apply auto[1]
  done

lemma cm_str:
  "wpre (cm b) (str R Q) \<supseteq> str R (wpre (cm b) Q)"
  by (auto simp: str_def stabilize_def st_upd_def)

lemma ncm_str:
  "wpre (ncm b) (str R Q) \<supseteq> str R (wpre (ncm b) Q)"
  by (auto simp: str_def stabilize_def st_upd_def)

lemma ign_str:
  "Q \<subseteq> str R Q"
  by (auto simp: str_def)

lemma [simp]:
  "state_rec.more (glb x) = state_rec.more x"
  unfolding glb_def by auto

end


section \<open>The Second Monotonicity Calculus\<close>
theory Mcalc2
imports Mono
begin

subsection\<open>Extension policies\<close>

text\<open>Extension policy: copy, true or false extension:\<close>

datatype epol = Cext | Text | Fext

text\<open>Problem with infinite knowledge and predicate-extension policy:\<close>

locale ProblemIkPol = ProblemIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp
+ fixes (* the predicate-extension policy *) pol :: "'tp \<Rightarrow> 'psym \<Rightarrow> epol"
and (* guard of a variable occurring in a certain literal of a certain clause: *)
    grdOf ::
"('fsym, 'psym) cls \<Rightarrow> ('fsym, 'psym) lit \<Rightarrow> var \<Rightarrow> ('fsym, 'psym) lit"

context ProblemIkPol begin

subsection\<open>Naked variables\<close>

fun nv2T where
"nv2T (Var x) = {x}"
|
"nv2T (Fn f Tl) = {}"

fun nv2L where
"nv2L (Pos (Eq T1 T2)) = nv2T T1 \<union> nv2T T2"
|
"nv2L (Neg (Eq T1 T2)) = {}"
|
"nv2L (Pos (Pr p Tl)) = {x \<in> \<Union> (set (map nv2T Tl)) . pol (tpOfV x) p = Fext}"
|
"nv2L (Neg (Pr p Tl)) = {x \<in> \<Union> (set (map nv2T Tl)) . pol (tpOfV x) p = Text}"

definition "nv2C c \<equiv> \<Union> (set (map nv2L c))"

lemma in_nv2T: "x \<in> nv2T T \<longleftrightarrow> T = Var x"
apply(cases T)
  apply (metis equals0D nv2T.simps singleton_iff)
  by simp

lemma nv2T_vars[simp]: "x \<in> nv2T T \<Longrightarrow> x \<in> vars T"
by (induct T, auto split: if_splits)

lemma nv2L_varsL[simp]:
assumes "x \<in> nv2L l" shows "x \<in> varsL l"
proof (cases l)
  case (Pos at)
  show ?thesis proof(cases at)
    case (Pr p Tl) thus ?thesis using assms unfolding Pos
    apply(cases "pol (tpOfV x) p", simp_all) by (metis nv2T_vars)
  qed(insert assms, unfold Pos, auto)
next
  case (Neg at)
  show ?thesis proof(cases at)
    case (Pr p Tl) thus ?thesis using assms unfolding Neg
    apply(cases "pol (tpOfV x) p", simp_all) by (metis nv2T_vars)
  qed(insert assms, unfold Neg, auto)
qed

lemma nv2C_varsC[simp]: "x \<in> nv2C c \<Longrightarrow> x \<in> varsC c"
unfolding varsC_def nv2C_def by (induct c, auto)

subsection\<open>The calculus\<close>

text\<open>The notion of a literal being a guard for a (typed) variable:\<close>

fun isGuard :: "var \<Rightarrow> ('fsym,'psym) lit \<Rightarrow> bool" where
"isGuard x (Pos (Eq T1 T2)) \<longleftrightarrow> False"
|
"isGuard x (Neg (Eq T1 T2)) \<longleftrightarrow>
 (T1 = Var x \<and> (\<exists> f Tl. T2 = Fn f Tl)) \<or>
 (T2 = Var x \<and> (\<exists> f Tl. T1 = Fn f Tl))"
|
"isGuard x (Pos (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> pol (tpOfV x) p = Text"
|
"isGuard x (Neg (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> pol (tpOfV x) p = Fext"

text\<open>The monotonicity calculus from the Classen et. al. paper, applied
to non-infinite types only: it checks that any variable in any literal of any clause
is indeed guarded by its guard:\<close>

inductive mcalc2 (infix "\<turnstile>2" 40) where
 [simp]: "infTp \<sigma> \<Longrightarrow> \<sigma> \<turnstile>2 c"
|[simp]: "(\<And> l x. \<lbrakk>l \<in> set c; x \<in> nv2L l; tpOfV x = \<sigma>\<rbrakk>
         \<Longrightarrow> isGuard x (grdOf c l x)) \<Longrightarrow> \<sigma> \<turnstile>2 c"

lemma mcalc2_iff:
"\<sigma> \<turnstile>2 c \<longleftrightarrow>
 infTp \<sigma> \<or> (\<forall> l x. l \<in> set c \<and> x \<in> nv2L l \<and> tpOfV x = \<sigma> \<longrightarrow> isGuard x (grdOf c l x))"
unfolding mcalc2.simps by auto

end (* context ProblemIk *)

locale ProblemIkPolMcalc2 = ProblemIkPol wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and pol and grdOf
+ assumes
(* well-definednedd of the guard: *)
    grdOf: "\<And> c l x. \<lbrakk>c \<in> \<Phi>; l \<in> set c; x \<in> nv2L l; \<not> infTp (tpOfV x)\<rbrakk>
                     \<Longrightarrow> grdOf c l x \<in> set c"
and mcalc2: "\<And> \<sigma> c. c \<in> \<Phi> \<Longrightarrow> \<sigma> \<turnstile>2 c"
begin
lemma wtL_grdOf[simp]:
assumes "c \<in> \<Phi>" and "l \<in> set c" and "x \<in> nv2L l" and "\<not> infTp (tpOfV x)"
shows "wtL (grdOf c l x)"
using grdOf[OF assms] by (metis assms list_all_iff wtC_def wtPB_def wt_\<Phi>)
end

locale ModelIkPolMcalc2 =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkPolMcalc2 wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp pol and grdOf and intT and intF and intP

end


theory Failures_Stable_TickTock
  imports Failures_TickTock Failures
begin

thm sf2f_def F2f_def mkF24_def ttproc2F_def

(* mapping from  tick-tock to stable failures (with stable tick) *)
definition tt2sf :: "'a ttprocess \<Rightarrow> 'a process" where
  "tt2sf P =
    ({ (t, X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[ttevt2F ` X]\<^sub>R] \<in> P }
      \<union> {(t, X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[Tick]\<^sub>E] \<in> P \<and> X \<subseteq> UNIV-{tick}}
      \<union> {(t @ [tick], X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[Tick]\<^sub>E] \<in> P \<and> X \<subseteq> UNIV},
    {tt2T y |y. y \<in> P})"

lemma end_tick_in_traces:
  "\<And>P. ttWF (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[Tick]\<^sub>E]) \<Longrightarrow>
       map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow>
  a @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  apply (induct a, simp_all)
  using traces_def apply force
  apply (case_tac a1, simp_all)
  apply (metis Nil_is_append_conv neq_Nil_conv ttWF.simps(8))
proof -
  fix a1 a2 P x2
  assume ind_hyp: "\<And>P. map (\<lambda>e. [ttevt2F e]\<^sub>E) a2 @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow>
           a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  assume "[Event x2]\<^sub>E # map (\<lambda>e. [ttevt2F e]\<^sub>E) a2 @ [[Tick]\<^sub>E] \<in> P"
  then have "a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> {t. [Event x2]\<^sub>E # t \<in> P}},
         {tt2T y |y. y \<in> {t. [Event x2]\<^sub>E # t \<in> P}}))"
    using ind_hyp by force
  then show "evt x2 # a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
    by (smt mem_Collect_eq snd_conv traces_def tt2T.simps(2))
qed

lemma end_refusal_ttWF_eq:
  "ttWF (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R])
    \<Longrightarrow> Some (a, b) = tt2F (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R])"
  apply (induct a, auto)
  using Some_tt2F_set apply fastforce
  apply (case_tac a1, auto)
  apply (metis Nil_is_append_conv neq_Nil_conv ttWF.simps(8))
  by (metis fst_conv option.simps(5) snd_conv)

lemma tt2F_Some_ref_end_refusal:
  "\<And>a. Some (a, b) = tt2F y \<Longrightarrow>
    y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
    \<or> y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[(ttevt2F ` b) \<union> {Tock}]\<^sub>R]"
  apply (induct y rule:ttWF.induct, auto)
    apply (smt image_def mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))
  apply (case_tac xa, auto)
  apply (metis image_eqI mem_Collect_eq ttevt2F.simps(1))
   apply (metis mem_Collect_eq rev_image_eqI ttevt2F.simps(2))
  by (case_tac "tt2F \<sigma>", auto)

lemma tt2F_Some_ref_end_refusal_in_TT1:
  "TT1 P \<Longrightarrow> Some (a, b) = tt2F y \<Longrightarrow> y \<in> P \<Longrightarrow>
    map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
proof -
  assume TT1_P: "TT1 P"
  assume y_in_P: "y \<in> P"
  assume tt2F_y_Some: "Some (a, b) = tt2F y"

  have "y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
    \<or> y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[(ttevt2F ` b) \<union> {Tock}]\<^sub>R]"
    using tt2F_Some_ref_end_refusal tt2F_y_Some by blast
  then show "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
    using y_in_P
  proof auto
    have "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
      \<lesssim>\<^sub>C map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[insert Tock (ttevt2F ` b)]\<^sub>R]"
      by (induct a, auto)
    then show "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[insert Tock (ttevt2F ` b)]\<^sub>R] \<in> P
      \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
      using TT1_P TT1_def by blast
  qed
qed

lemma end_tick_in_traces_imp_in_ttproc:
  "\<And>P. s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))
    \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
proof (induct s, auto)
  fix P
  show "[tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow> [[Tick]\<^sub>E] \<in> P"
    by (smt append_Nil mem_Collect_eq snd_conv tick_tt2T_concat_TickE traces_def tt2T_tick_exists_Cons)
next
  fix a s P
  assume ind_hyp: "\<And>P. s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow>
             map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
  assume "a # s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  then have "s @ [tick]
    \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}},
               {tt2T y |y. y \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}}))"
    unfolding traces_def
  proof auto
    fix y
    assume case_assms: "a # s @ [tick] = tt2T y" "y \<in> P"
    then obtain y' where y'_assms: "s @ [tick] = tt2T y' \<and> y = [ttevt2F a]\<^sub>E # y'"
      apply (cases y, auto, cases a, auto, case_tac aa, auto, case_tac x1, auto)
      apply (metis append_Cons neq_Nil_conv self_append_conv2 tt2T.simps(1) tt2T.simps(7))
      apply (case_tac aa, auto, case_tac x1, auto)
      by (metis append_Cons neq_Nil_conv self_append_conv2 tt2T.simps(1) tt2T.simps(7))
    then have "map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}"
      using ind_hyp[where P="{t. [ttevt2F a]\<^sub>E # t \<in> P}"] case_assms(2) traces_def by fastforce
    then show "\<exists>y. s @ [tick] = tt2T y \<and> [ttevt2F a]\<^sub>E # y \<in> P"
      using y'_assms case_assms(2) by blast
  qed
  then show "a # s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow>
       [ttevt2F a]\<^sub>E # map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
    using ind_hyp by blast
qed

lemma tt2sf_eq_mkF24_ttproc2F:
  assumes P_wf: "\<forall>x\<in>P. ttWF x" and TT1_P: "TT1 P"
  shows "tt2sf P = mkF24 (ttproc2F P)"
  unfolding mkF24_def tt2sf_def ttproc2F_def
  apply auto
  using assms end_refusal_ttWF_eq apply blast
  using assms end_tick_in_traces apply blast
  using assms end_tick_in_traces apply blast
  apply (simp add: TT1_P tt2F_Some_ref_end_refusal_in_TT1)
  apply (simp add: TT1_P tt2F_Some_ref_end_refusal_in_TT1)
  using end_tick_in_traces_imp_in_ttproc apply blast
  using end_tick_in_traces_imp_in_ttproc apply blast
  using end_tick_in_traces_imp_in_ttproc apply blast
  by (auto simp add: traces_def)

end


(*  Title:      Mapping_Exts.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

subsection "Mapping Extensions"

text \<open>Some lifted definition on mapping and efficient implementations.\<close>

theory Mapping_Exts
imports "HOL-Library.Mapping" FormalSSA_Misc
begin

lift_definition mapping_delete_all :: "('a \<Rightarrow> bool) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
  is "\<lambda>P m x. if (P x) then None else m x" .
lift_definition map_keys :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a,'c) mapping \<Rightarrow> ('b,'c) mapping"
  is "\<lambda>f m x. if f -` {x} \<noteq> {} then m (THE k. f -` {x} = {k}) else None" .
lift_definition map_values :: "('a \<Rightarrow> 'b \<Rightarrow> 'c option) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'c) mapping"
  is "\<lambda>f m x. Option.bind (m x) (f x)" .
lift_definition restrict_mapping :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>f. restrict_map (Some \<circ> f)" .
lift_definition mapping_add :: "('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "(++)" .

definition "mmap = Mapping.map id"

lemma lookup_map_keys: "Mapping.lookup (map_keys f m) x = (if f -` {x} \<noteq> {} then Mapping.lookup m (THE k. f -` {x} = {k}) else None)"
apply transfer ..

lemma Mapping_Mapping_lookup [simp, code_unfold]: "Mapping.Mapping (Mapping.lookup m) = m" by transfer simp
declare Mapping.lookup.abs_eq[simp]

lemma Mapping_eq_lookup: "m = m' \<longleftrightarrow> Mapping.lookup m = Mapping.lookup m'" by transfer simp

lemma map_of_map_if_conv:
  "map_of (map (\<lambda>k. (k, f k)) xs) x = (if (x \<in> set xs) then Some (f x) else None)"
  by (clarsimp simp: map_of_map_restrict)

lemma Mapping_lookup_map: "Mapping.lookup (Mapping.map f g m) a = map_option g (Mapping.lookup m (f a))"
  by transfer simp

lemma Mapping_lookup_map_default: "Mapping.lookup (Mapping.map_default k d f m) k' = (if k = k'
  then (Some \<circ> f) (case Mapping.lookup m k of None \<Rightarrow> d | Some x \<Rightarrow> x)
  else Mapping.lookup m k')"
  unfolding Mapping.map_default_def Mapping.default_def
  by transfer auto

lemma Mapping_lookup_mapping_add: "Mapping.lookup (mapping_add m1 m2) k =
  case_option (Mapping.lookup m1 k) Some (Mapping.lookup m2 k)"
  by transfer (simp add: map_add_def)

lemma Mapping_lookup_map_values: "Mapping.lookup (map_values f m) k =
  Option.bind (Mapping.lookup m k) (f k)"
  by transfer simp

lemma lookup_fold_update [simp]: "Mapping.lookup (fold (\<lambda>n. Mapping.update n (g n)) xs m) x
  = (if (x \<in> set xs) then Some (g x) else Mapping.lookup m x)"
  by transfer (rule fold_update_conv)

lemma mapping_eq_iff: "m1 = m2 \<longleftrightarrow> (\<forall>k. Mapping.lookup m1 k = Mapping.lookup m2 k)"
  by transfer auto

lemma lookup_delete: "Mapping.lookup (Mapping.delete k m) k' = (if k = k' then None else Mapping.lookup m k')"
  by transfer auto

lemma keys_map_values: "Mapping.keys (map_values f m) = Mapping.keys m - {k\<in>Mapping.keys m. f k (the (Mapping.lookup m k)) = None}"
  by transfer (auto simp add: bind_eq_Some_conv)

lemma map_default_eq: "Mapping.map_default k v f m = m \<longleftrightarrow> (\<exists>v. Mapping.lookup m k = Some v \<and> f v = v)"
  apply (clarsimp simp: Mapping.map_default_def Mapping.default_def)
  by transfer' (auto simp: fun_eq_iff split: if_splits)

lemma lookup_update_cases: "Mapping.lookup (Mapping.update k v m) k' = (if k=k' then Some v else Mapping.lookup m k')"
by (cases "k=k'", simp_all add: Mapping.lookup_update Mapping.lookup_update_neq)

end


(* TODO: Move to Refine-Monadic *)
theory Refine_Monadic_Add
imports Refine_Monadic_Thin
begin

  lemma option_rel_inv_conv:
    "(x,Some v')\<in>\<langle>V\<rangle>option_rel \<longleftrightarrow> (\<exists>v. x=Some v \<and> (v,v')\<in>V)"
    "(Some v,x')\<in>\<langle>V\<rangle>option_rel \<longleftrightarrow> (\<exists>v'. x'=Some v' \<and> (v,v')\<in>V)"
    subgoal by (cases x; auto)
    subgoal by (cases x'; auto)
    done

  definition "monadic_WHILEIT I b f s \<equiv> do {
    RECT (\<lambda>D s. do {
      ASSERT (I s);
      bv \<leftarrow> b s;
      if bv then do {
        s \<leftarrow> f s;
        D s
      } else do {RETURN s}
    }) s
  }"

  lemma WHILEIT_to_monadic: "WHILEIT I b f s = monadic_WHILEIT I (\<lambda>s. RETURN (b s)) f s"
    unfolding WHILEIT_def monadic_WHILEIT_def
    unfolding WHILEI_body_def bind_ASSERT_eq_if
    by (simp cong: if_cong)

lemma monadic_WHILEIT_refine[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le>\<Down>bool_rel (b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; nofail (b s); inres (b s) True \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT I' b' f' s' \<le>\<Down>R (monadic_WHILEIT I b f s)"
  unfolding monadic_WHILEIT_def
  by (refine_rcg bind_refine'; assumption?; auto)

lemma monadic_WHILEIT_refine_WHILEIT[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [THEN order_trans,refine_vcg]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le> SPEC (\<lambda>r. r = b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; b s \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT I' b' f' s' \<le>\<Down>R (WHILEIT I b f s)"
  unfolding WHILEIT_to_monadic
  by (refine_vcg; assumption?; auto)

lemma monadic_WHILEIT_refine_WHILET[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [THEN order_trans,refine_vcg]: "\<And>s' s. \<lbrakk> (s',s)\<in>R \<rbrakk> \<Longrightarrow> b' s' \<le> SPEC (\<lambda>r. r = b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; b s \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT (\<lambda>_. True) b' f' s' \<le>\<Down>R (WHILET b f s)"
  unfolding WHILET_def
  by (refine_vcg; assumption?)

end


theory "WooLam_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Woo and Lam Mutual Authentication Protocol  *)

(* text:
  Modeled after the description in the SPORE library:

    http://www.lsv.ens-cachan.fr/Software/spore/wooLamMutual.html

  Notable differences:

    1. We are using explicit global constants to discern between different
       encryptions instead of the implicit typing, which introduces
       ambiguities. This implies that we are not precisely modeling the Woo and
       Lam protocol of the SPORE library and hence we may miss some attacks
       possible on it. However, every implementation of the SPORE model could
       easily be changed to our version and benefit from the full correctness
       proof.
 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'', sN ''na'' |>
  , Recv ''2'' <| sMV ''B'', sMV ''nb'' |>
  , Send ''3'' ( PEnc <| sC ''enc3'', sAV ''A'', sMV ''B'', sN ''na'',
                         sMV ''nb''
                      |>
                      ( sK ''A'' ''S'' )
               )
  , Recv ''6'' <| PEnc <| sC ''enc51'', sMV ''B'', sN ''na'', sMV ''nb'',
                          sMV ''kab''
                       |>
                       ( sK ''A'' ''S'' ),
                  PEnc <| sC ''enc6'', sN ''na'', sMV ''nb'' |> ( sMV ''kab'' )
               |>
  , Send ''7'' ( PEnc <| sC ''enc7'', sMV ''nb'' |> ( sMV ''kab'' ) )
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'', sMV ''na'' |>
  , Send ''2'' <| sAV ''B'', sN ''nb'' |>
  , Recv ''3'' ( sMV ''Ticket1'' )
  , Send ''4'' <| sMV ''Ticket1'',
                  PEnc <| sC ''enc4'', sMV ''A'', sAV ''B'', sMV ''na'', sN ''nb'' |>
                       ( sK ''B'' ''S'' )
               |>
  , Recv ''5'' <| sMV ''Ticket2'',
                  PEnc <| sC ''enc52'', sMV ''A'', sMV ''na'', sN ''nb'', sMV ''kab'' |>
                       ( sK ''B'' ''S'' )
               |>
  , Send ''6'' <| sMV ''Ticket2'',
                  PEnc <| sC ''enc6'', sMV ''na'', sN ''nb'' |> ( sMV ''kab'' )
               |>
  , Recv ''7'' ( PEnc <| sC ''enc7'', sN ''nb'' |> ( sMV ''kab'' ) )
  ]"

role S
where "S =
  [ Recv ''4'' <| PEnc <| sC ''enc3'', sMV ''A'', sMV ''B'', sMV ''na'',
                          sMV ''nb''
                       |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) ),
                  PEnc <| sC ''enc4'', sMV ''A'', sMV ''B'', sMV ''na'', sMV ''nb'' |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) )
               |>
  , Send ''5'' <| PEnc <| sC ''enc51'', sMV ''B'', sMV ''na'', sMV ''nb'',
                          sN ''kab''
                       |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''S'' ) ),
                  PEnc <| sC ''enc52'', sMV ''A'', sMV ''na'', sMV ''nb'', sN ''kab'' |>
                       ( PSymK ( sMV ''B'' ) ( sAV ''S'' ) )
               |>
  ]"

protocol WooLam
where "WooLam = { A, B, S }"

locale restricted_WooLam_state = WooLam_state

type_invariant WooLam_msc_typing for WooLam
where "WooLam_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((S, ''A''), (SumT (KnownT S_4) AgentT))
  , ((A, ''B''), (KnownT A_2))
  , ((S, ''B''), (SumT (KnownT S_4) AgentT))
  , ((B, ''Ticket1''), (KnownT B_3))
  , ((B, ''Ticket2''), (KnownT B_5))
  , ((A, ''kab''), (SumT (KnownT A_6) (NonceT S ''kab'')))
  , ((B, ''kab''), (SumT (KnownT B_5) (NonceT S ''kab'')))
  , ((B, ''na''), (KnownT B_1))
  , ((S, ''na''), (SumT (KnownT S_4) (NonceT A ''na'')))
  , ((A, ''nb''), (KnownT A_2))
  , ((S, ''nb''), (SumT (KnownT S_4) (NonceT B ''nb'')))
  ]"

sublocale WooLam_state < WooLam_msc_typing_state
proof -
  have "(t,r,s) : approx WooLam_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WooLam_msc_typing.monoTyp, completeness_cases_rule])
    case (A_2_B t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_2_nb t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_nb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_6_kab t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_6_kab
    thus ?case
    proof(sources! "
        Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
               s(MV ''kab'' tid0)
            |}
            ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (B_1_A t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_na t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_na
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_5_Ticket2 t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_5_Ticket2
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_5_kab t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_5_kab
    thus ?case
    proof(sources! "
        Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
               s(MV ''kab'' tid0)
            |}
            ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_A t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_A
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_B t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_B
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_na t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_na
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_4_nb t r s tid0)
    then interpret state: WooLam_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_4_nb
    thus ?case
    proof(sources! "
        Enc {| LC ''enc3'', s(MV ''A'' tid0), s(MV ''B'' tid0),
               s(MV ''na'' tid0), s(MV ''nb'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "WooLam_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WooLam_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_WooLam_state) S_sec_kab:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "LN ''kab'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''kab'' tid0 ")
  case S_5_kab note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case S_5_kab_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WooLam_state) A_sec_kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_6 ) : steps t"
    "s(MV ''kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_sec_kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_5 ) : steps t"
    "s(MV ''kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) A_sec_inv_kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_6 ) : steps t"
    "inv(s(MV ''kab'' tid0)) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid0), LN ''na'' tid0, s(MV ''nb'' tid0),
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''A'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_sec_inv_kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_5 ) : steps t"
    "inv(s(MV ''kab'' tid0)) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid0), s(MV ''na'' tid0), LN ''nb'' tid0,
                          s(MV ''kab'' tid0)
                       |}
                       ( K ( s(AV ''B'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication  *)

lemma (in restricted_WooLam_state) na_first_send:
  assumes facts:
    "roleMap r tid1 = Some A"
    "LN ''na'' tid1 : knows t"
  shows "predOrd t (St( tid1, A_1 )) (Ln(LN ''na'' tid1))"
using facts proof(sources! " LN ''na'' tid1 ")
  case A_1_na note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case A_3_na note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case (S_5_na tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2), LN ''na'' tid1,
                          s(MV ''nb'' tid2)
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case (A_3_enc tid3) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case (S_5_na_1 tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2), LN ''na'' tid1,
                          s(MV ''nb'' tid2)
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case (A_3_enc tid3) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WooLam_state) nb_first_send:
  assumes facts:
    "roleMap r tid1 = Some B"
    "LN ''nb'' tid1 : knows t"
  shows "predOrd t (St( tid1, B_2 )) (Ln(LN ''nb'' tid1))"
using facts proof(sources! " LN ''nb'' tid1 ")
  case B_2_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case B_4_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case B_6_nb note_unified facts = this facts
  thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
next
  case (S_5_nb tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2),
                          s(MV ''na'' tid2), LN ''nb'' tid1
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case (S_5_nb_1 tid2) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid2), s(MV ''B'' tid2),
                          s(MV ''na'' tid2), LN ''nb'' tid1
                       |}
                       ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_WooLam_state) A_ni_synch:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(AV ''S'' tid1)) ~: reveals t"
    "RLKR(s(MV ''B'' tid1)) ~: reveals t"
    "( tid1, A_6 ) : steps t"
  shows
    "(?  tid2.
        (?  tid3.
           roleMap r tid2 = Some B &
           roleMap r tid3 = Some S &
           s(AV ''A'' tid1) = s(MV ''A'' tid2) &
           s(MV ''B'' tid1) = s(AV ''B'' tid2) &
           s(AV ''S'' tid1) = s(AV ''S'' tid2) &
           LN ''na'' tid1 = s(MV ''na'' tid2) &
           s(MV ''nb'' tid1) = LN ''nb'' tid2 &
           s(MV ''kab'' tid1) = s(MV ''kab'' tid2) &
           s(AV ''A'' tid1) = s(MV ''A'' tid3) &
           s(MV ''B'' tid1) = s(MV ''B'' tid3) &
           s(AV ''S'' tid1) = s(AV ''S'' tid3) &
           LN ''na'' tid1 = s(MV ''na'' tid3) &
           s(MV ''nb'' tid1) = s(MV ''nb'' tid3) &
           s(MV ''kab'' tid1) = LN ''kab'' tid3 &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid3, S_4 )) (St( tid3, S_5 )) &
           predOrd t (St( tid3, S_5 )) (St( tid2, B_5 )) &
           predOrd t (St( tid2, B_5 )) (St( tid2, B_6 )) &
           predOrd t (St( tid2, B_6 )) (St( tid1, A_6 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc51'', s(MV ''B'' tid1), LN ''na'' tid1, s(MV ''nb'' tid1),
                          s(MV ''kab'' tid1)
                       |}
                       ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc3'', s(AV ''A'' tid1), s(MV ''B'' tid1), LN ''na'' tid1,
                            s(MV ''nb'' tid1)
                         |}
                         ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_3_enc tid3) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''enc4'', s(AV ''A'' tid1), s(MV ''B'' tid1), LN ''na'' tid1,
                              s(MV ''nb'' tid1)
                           |}
                           ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (B_4_enc tid3) note_unified facts = this facts
        have f1: "roleMap r tid1 = Some A" using facts by (auto intro: event_predOrdI)
        have f2: "LN ''na'' tid1 : knows t" using facts by (auto intro: event_predOrdI)
        note facts = facts na_first_send[OF f1 f2, simplified]
        have f1: "roleMap r tid3 = Some B" using facts by (auto intro: event_predOrdI)
        have f2: "LN ''nb'' tid3 : knows t" using facts by (auto intro: event_predOrdI)
        note facts = facts nb_first_send[OF f1 f2, simplified]
        thus ?thesis proof(sources! "
                         Enc {| LC ''enc6'', LN ''na'' tid1, LN ''nb'' tid3 |}
                             ( LN ''kab'' tid2 ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
        next
          case (B_6_enc tid4) note_unified facts = this facts
          thus ?thesis proof(sources! "
                           Enc {| LC ''enc52'', s(AV ''A'' tid1), LN ''na'' tid1, LN ''nb'' tid3,
                                  LN ''kab'' tid2
                               |}
                               ( K ( s(AV ''A'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
            case fake note_unified facts = this facts
            thus ?thesis by (auto dest!: ltk_secrecy)
          next
            case (S_5_enc_1 tid4) note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) B_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(AV ''S'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_7 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some A &
           roleMap r tid3 = Some S &
           s(MV ''A'' tid2) = s(AV ''A'' tid1) &
           s(AV ''B'' tid2) = s(MV ''B'' tid1) &
           s(AV ''S'' tid2) = s(AV ''S'' tid1) &
           s(MV ''na'' tid2) = LN ''na'' tid1 &
           LN ''nb'' tid2 = s(MV ''nb'' tid1) &
           s(MV ''kab'' tid2) = s(MV ''kab'' tid1) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           s(MV ''na'' tid2) = s(MV ''na'' tid3) &
           LN ''nb'' tid2 = s(MV ''nb'' tid3) &
           s(MV ''kab'' tid2) = LN ''kab'' tid3 &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid3, S_4 )) (St( tid3, S_5 )) &
           predOrd t (St( tid3, S_5 )) (St( tid2, B_5 )) &
           predOrd t (St( tid2, B_5 )) (St( tid2, B_6 )) &
           predOrd t (St( tid2, B_6 )) (St( tid1, A_6 )) &
           predOrd t (St( tid1, A_6 )) (St( tid1, A_7 )) &
           predOrd t (St( tid1, A_7 )) (St( tid2, B_7 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc52'', s(MV ''A'' tid2), s(MV ''na'' tid2), LN ''nb'' tid2,
                          s(MV ''kab'' tid2)
                       |}
                       ( K ( s(AV ''B'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_5_enc_1 tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc3'', s(MV ''A'' tid2), s(AV ''B'' tid2),
                            s(MV ''na'' tid2), LN ''nb'' tid2
                         |}
                         ( K ( s(MV ''A'' tid2) ) ( s(AV ''S'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_3_enc tid4) note_unified facts = this facts
      have f1: "roleMap r tid4 = Some A" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''na'' tid4 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts na_first_send[OF f1 f2, simplified]
      have f1: "roleMap r tid2 = Some B" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''nb'' tid2 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts nb_first_send[OF f1 f2, simplified]
      thus ?thesis proof(sources! "
                       Enc {| LC ''enc7'', LN ''nb'' tid2 |} ( LN ''kab'' tid3 ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
      next
        case (A_7_enc tid5) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''enc4'', s(AV ''A'' tid4), s(AV ''B'' tid2), LN ''na'' tid4,
                                LN ''nb'' tid2
                             |}
                             ( K ( s(AV ''A'' tid4) ) ( s(AV ''S'' tid2) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (auto dest!: ltk_secrecy)
        next
          case (B_4_enc tid6) note_unified facts = this facts
          thus ?thesis proof(sources! "
                           Enc {| LC ''enc6'', LN ''na'' tid5, LN ''nb'' tid2 |}
                               ( LN ''kab'' tid3 ) ")
            case fake note_unified facts = this facts
            thus ?thesis by (fastforce dest: S_sec_kab intro: event_predOrdI)
          next
            case (B_6_enc tid6) note_unified facts = this facts
            thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_WooLam_state) S_ni_synch:
  assumes facts:
    "roleMap r tid3 = Some S"
    "RLKR(s(AV ''S'' tid3)) ~: reveals t"
    "RLKR(s(MV ''A'' tid3)) ~: reveals t"
    "RLKR(s(MV ''B'' tid3)) ~: reveals t"
    "( tid3, S_4 ) : steps t"
  shows
    "(?  tid1.
        (?  tid2.
           roleMap r tid1 = Some A &
           roleMap r tid2 = Some B &
           s(MV ''A'' tid2) = s(AV ''A'' tid1) &
           s(AV ''B'' tid2) = s(MV ''B'' tid1) &
           s(AV ''S'' tid2) = s(AV ''S'' tid1) &
           s(MV ''na'' tid2) = LN ''na'' tid1 &
           LN ''nb'' tid2 = s(MV ''nb'' tid1) &
           s(MV ''A'' tid2) = s(MV ''A'' tid3) &
           s(AV ''B'' tid2) = s(MV ''B'' tid3) &
           s(AV ''S'' tid2) = s(AV ''S'' tid3) &
           s(MV ''na'' tid2) = s(MV ''na'' tid3) &
           LN ''nb'' tid2 = s(MV ''nb'' tid3) &
           predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
           predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
           predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
           predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
           predOrd t (St( tid1, A_3 )) (St( tid3, S_4 )) &
           predOrd t (St( tid2, B_3 )) (St( tid2, B_4 )) &
           predOrd t (St( tid2, B_4 )) (St( tid3, S_4 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''enc3'', s(MV ''A'' tid3), s(MV ''B'' tid3),
                          s(MV ''na'' tid3), s(MV ''nb'' tid3)
                       |}
                       ( K ( s(MV ''A'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_3_enc tid4) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''enc4'', s(AV ''A'' tid4), s(MV ''B'' tid3), LN ''na'' tid4,
                            s(MV ''nb'' tid3)
                         |}
                         ( K ( s(AV ''A'' tid4) ) ( s(AV ''S'' tid3) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (B_4_enc tid5) note_unified facts = this facts
      have f1: "roleMap r tid4 = Some A" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''na'' tid4 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts na_first_send[OF f1 f2, simplified]
      have f1: "roleMap r tid5 = Some B" using facts by (auto intro: event_predOrdI)
      have f2: "LN ''nb'' tid5 : knows t" using facts by (auto intro: event_predOrdI)
      note facts = facts nb_first_send[OF f1 f2, simplified]
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end