(*  Author:     Bernhard Haeupler

This theory is about of the relative completeness of method comm-ring
method.  As long as the reified atomic polynomials of type 'a pol are
in normal form, the cring method is complete.
*)

section \<open>Proof of the relative completeness of method comm-ring\<close>

theory Commutative_Ring_Complete
imports Commutative_Ring
begin

text \<open>Formalization of normal form\<close>
fun isnorm :: "'a::comm_ring pol \<Rightarrow> bool"
where
  "isnorm (Pc c) \<longleftrightarrow> True"
| "isnorm (Pinj i (Pc c)) \<longleftrightarrow> False"
| "isnorm (Pinj i (Pinj j Q)) \<longleftrightarrow> False"
| "isnorm (Pinj 0 P) \<longleftrightarrow> False"
| "isnorm (Pinj i (PX Q1 j Q2)) \<longleftrightarrow> isnorm (PX Q1 j Q2)"
| "isnorm (PX P 0 Q) \<longleftrightarrow> False"
| "isnorm (PX (Pc c) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm Q"
| "isnorm (PX (PX P1 j (Pc c)) i Q) \<longleftrightarrow> c \<noteq> 0 \<and> isnorm (PX P1 j (Pc c)) \<and> isnorm Q"
| "isnorm (PX P i Q) \<longleftrightarrow> isnorm P \<and> isnorm Q"

(* Some helpful lemmas *)
lemma norm_Pinj_0_False: "isnorm (Pinj 0 P) = False"
  by (cases P) auto

lemma norm_PX_0_False: "isnorm (PX (Pc 0) i Q) = False"
  by (cases i) auto

lemma norm_Pinj: "isnorm (Pinj i Q) \<Longrightarrow> isnorm Q"
  by (cases i) (simp add: norm_Pinj_0_False norm_PX_0_False, cases Q, auto)

lemma norm_PX2: "isnorm (PX P i Q) \<Longrightarrow> isnorm Q"
  apply (cases i)
  apply auto
  apply (cases P)
  apply auto
  subgoal for \<dots> pol2 by (cases pol2) auto
  done

lemma norm_PX1: "isnorm (PX P i Q) \<Longrightarrow> isnorm P"
  apply (cases i)
  apply auto
  apply (cases P)
  apply auto
  subgoal for \<dots> pol2 by (cases pol2) auto
  done

lemma mkPinj_cn: "y \<noteq> 0 \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (mkPinj y Q)"
  apply (auto simp add: mkPinj_def norm_Pinj_0_False split: pol.split)
  apply (rename_tac nat a, case_tac nat, auto simp add: norm_Pinj_0_False)
  apply (rename_tac pol a, case_tac pol, auto)
  apply (case_tac y, auto)
  done

lemma norm_PXtrans:
  assumes A: "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P x Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
    apply auto
    apply (cases p2)
    apply auto
    done
next
  case Pc
  with assms show ?thesis
    by (cases x) auto
next
  case Pinj
  with assms show ?thesis
    by (cases x) auto
qed

lemma norm_PXtrans2:
  assumes "isnorm (PX P x Q)"
    and "isnorm Q2"
  shows "isnorm (PX P (Suc (n + x)) Q2)"
proof (cases P)
  case (PX p1 y p2)
  with assms show ?thesis
    apply (cases x)
    apply auto
    apply (cases p2)
    apply auto
    done
next
  case Pc
  with assms show ?thesis
    by (cases x) auto
next
  case Pinj
  with assms show ?thesis
    by (cases x) auto
qed

text \<open>mkPX conserves normalizedness (\<open>_cn\<close>)\<close>
lemma mkPX_cn:
  assumes "x \<noteq> 0"
    and "isnorm P"
    and "isnorm Q"
  shows "isnorm (mkPX P x Q)"
proof (cases P)
  case (Pc c)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (Pinj i Q)
  with assms show ?thesis
    by (cases x) (auto simp add: mkPinj_cn mkPX_def)
next
  case (PX P1 y P2)
  with assms have Y0: "y > 0"
    by (cases y) auto
  from assms PX have "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 y P2] norm_PX2[of P1 y P2])
  from assms PX Y0 show ?thesis
    apply (cases x)
    apply (auto simp add: mkPX_def norm_PXtrans2[of P1 y _ Q _])
    apply (cases P2)
    apply auto
    done
qed

text \<open>add conserves normalizedness\<close>
lemma add_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<oplus> Q)"
proof (induct P Q rule: add.induct)
  case 1
  then show ?case by simp
next
  case (2 c i P2)
  then show ?case
    apply (cases P2)
    apply simp_all
    apply (cases i)
    apply simp_all
    done
next
  case (3 i P2 c)
  then show ?case
    apply (cases P2)
    apply simp_all
    apply (cases i)
    apply simp_all
    done
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    apply (cases i)
    apply simp
    apply (cases P2)
    apply auto
    subgoal for \<dots> pol2 by (cases pol2) auto
    done
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    apply (cases i)
    apply simp
    apply (cases P2)
    apply auto
    subgoal for \<dots> pol2 by (cases pol2) auto
    done
next
  case (6 x P2 y Q2)
  then have Y0: "y > 0"
    by (cases y) (auto simp add: norm_Pinj_0_False)
  with 6 have X0: "x > 0"
    by (cases x) (auto simp add: norm_Pinj_0_False)
  consider "x < y" | "x = y" | "x > y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy y have "isnorm (Pinj d Q2)"
      by (cases d, simp, cases Q2, auto)
    with 6 X0 y * show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 2
    from 6 have "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    with xy 6 Y0 show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 3
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy x have "isnorm (Pinj d P2)"
      by (cases d) (simp, cases P2, auto)
    with xy 6 Y0 * x show ?thesis by (simp add: mkPinj_cn)
  qed
next
  case (7 x P2 Q2 y R)
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (R \<oplus> P2)"
      by simp
    with 7 x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  next
    case x: 3
    with 7 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 7 x NR have "isnorm (R \<oplus> Pinj (x - 1) P2)"
      by simp
    with \<open>isnorm (PX Q2 y R)\<close> x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  qed
next
  case (8 Q2 y R x P2)
  consider "x = 0" | "x = 1" | "x > 1"
    by arith
  then show ?case
  proof cases
    case 1
    with 8 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    with 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (R \<oplus> P2)"
      by simp
    with 8 x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  next
    case x: 3
    then obtain d where x: "x = Suc (Suc d)" by atomize_elim arith
    with 8 have NR: "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 8 x NR have "isnorm (R \<oplus> Pinj (x - 1) P2)"
      by simp
    with \<open>isnorm (PX Q2 y R)\<close> x show ?thesis
      by (simp add: norm_PXtrans[of Q2 y _])
  qed
next
  case (9 P1 x P2 Q1 y Q2)
  then have Y0: "y > 0" by (cases y) auto
  with 9 have X0: "x > 0" by (cases x) auto
  with 9 have NP1: "isnorm P1" and NP2: "isnorm P2"
    by (auto simp add: norm_PX1[of P1 _ P2] norm_PX2[of P1 _ P2])
  with 9 have NQ1: "isnorm Q1" and NQ2: "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 _ Q2] norm_PX2[of Q1 _ Q2])
  consider "y < x" | "x = y" | "x < y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    have "isnorm (PX P1 d (Pc 0))"
    proof (cases P1)
      case (PX p1 y p2)
      with 9 xy x show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 xy x show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 xy x show ?thesis
        by (cases d) auto
    qed
    with 9 NQ1 NP1 NP2 NQ2 xy x have "isnorm (P2 \<oplus> Q2)" "isnorm (PX P1 (x - y) (Pc 0) \<oplus> Q1)"
      by auto
    with Y0 xy x show ?thesis
      by (simp add: mkPX_cn)
  next
    case xy: 2
    with 9 NP1 NP2 NQ1 NQ2 have "isnorm (P2 \<oplus> Q2)" "isnorm (P1 \<oplus> Q1)"
      by auto
    with xy Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case xy: 3
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    have "isnorm (PX Q1 d (Pc 0))"
    proof (cases Q1)
      case (PX p1 y p2)
      with 9 xy y show ?thesis
        by (cases d) (simp, cases p2, auto)
    next
      case Pc
      with 9 xy y show ?thesis
        by (cases d) auto
    next
      case Pinj
      with 9 xy y show ?thesis
        by (cases d) auto
    qed
    with 9 NQ1 NP1 NP2 NQ2 xy y have "isnorm (P2 \<oplus> Q2)" "isnorm (PX Q1 (y - x) (Pc 0) \<oplus> P1)"
      by auto
    with X0 xy y show ?thesis
      by (simp add: mkPX_cn)
  qed
qed

text \<open>mul concerves normalizedness\<close>
lemma mul_cn: "isnorm P \<Longrightarrow> isnorm Q \<Longrightarrow> isnorm (P \<otimes> Q)"
proof (induct P Q rule: mul.induct)
  case 1
  then show ?case by simp
next
  case (2 c i P2)
  then show ?case
    apply (cases P2)
    apply simp_all
    apply (cases i)
    apply (simp_all add: mkPinj_cn)
    done
next
  case (3 i P2 c)
  then show ?case
    apply (cases P2)
    apply simp_all
    apply (cases i)
    apply (simp_all add: mkPinj_cn)
    done
next
  case (4 c P2 i Q2)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 4 show ?case
    apply (cases "c = 0")
    apply simp_all
    apply (cases "i = 0")
    apply (simp_all add: mkPX_cn)
    done
next
  case (5 P2 i Q2 c)
  then have "isnorm P2" "isnorm Q2"
    by (auto simp only: norm_PX1[of P2 i Q2] norm_PX2[of P2 i Q2])
  with 5 show ?case
    apply (cases "c = 0")
    apply simp_all
    apply (cases "i = 0")
    apply (simp_all add: mkPX_cn)
    done
next
  case (6 x P2 y Q2)
  consider "x < y" | "x = y" | "x > y" by arith
  then show ?case
  proof cases
    case xy: 1
    then obtain d where y: "y = d + x"
      by atomize_elim arith
    from 6 have *: "x > 0"
      by (cases x) (auto simp add: norm_Pinj_0_False)
    from 6 have **: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy y have "isnorm (Pinj d Q2)"
      apply (cases d)
      apply simp
      apply (cases Q2)
      apply auto
      done
    with 6 * ** y show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 2
    from 6 have *: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 have **: "y > 0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    with 6 xy * ** show ?thesis
      by (simp add: mkPinj_cn)
  next
    case xy: 3
    then obtain d where x: "x = d + y"
      by atomize_elim arith
    from 6 have *: "y > 0"
      by (cases y) (auto simp add: norm_Pinj_0_False)
    from 6 have **: "isnorm P2" "isnorm Q2"
      by (auto simp add: norm_Pinj[of _ P2] norm_Pinj[of _ Q2])
    from 6 xy x have "isnorm (Pinj d P2)"
      apply (cases d)
      apply simp
      apply (cases P2)
      apply auto
      done
    with 6 xy * ** x show ?thesis
      by (simp add: mkPinj_cn)
  qed
next
  case (7 x P2 Q2 y R)
  then have Y0: "y > 0" by (cases y) auto
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 7 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 7 x have "isnorm (R \<otimes> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 7 x Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case x: 3
    from 7 have *: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    from 7 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 7 x * have "isnorm (R \<otimes> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<otimes> Q2)"
      by auto
    with Y0 x show ?thesis
      by (simp add: mkPX_cn)
  qed
next
  case (8 Q2 y R x P2)
  then have Y0: "y > 0"
    by (cases y) auto
  consider "x = 0" | "x = 1" | d where "x = Suc (Suc d)"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 8 show ?thesis
      by (auto simp add: norm_Pinj_0_False)
  next
    case x: 2
    from 8 have "isnorm R" "isnorm P2"
      by (auto simp add: norm_Pinj[of _ P2] norm_PX2[of Q2 y R])
    with 8 x have "isnorm (R \<otimes> P2)" "isnorm Q2"
      by (auto simp add: norm_PX1[of Q2 y R])
    with 8 x Y0 show ?thesis
      by (simp add: mkPX_cn)
  next
    case x: 3
    from 8 have *: "isnorm R" "isnorm Q2"
      by (auto simp add: norm_PX2[of Q2 y R] norm_PX1[of Q2 y R])
    from 8 x have "isnorm (Pinj (x - 1) P2)"
      by (cases P2) auto
    with 8 x * have "isnorm (R \<otimes> Pinj (x - 1) P2)" "isnorm (Pinj x P2 \<otimes> Q2)"
      by auto
    with Y0 x show ?thesis
      by (simp add: mkPX_cn)
  qed
next
  case (9 P1 x P2 Q1 y Q2)
  from 9 have X0: "x > 0" by (cases x) auto
  from 9 have Y0: "y > 0" by (cases y) auto
  from 9 have *: "isnorm P1" "isnorm P2"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  from 9 have "isnorm Q1" "isnorm Q2"
    by (auto simp add: norm_PX1[of Q1 y Q2] norm_PX2[of Q1 y Q2])
  with 9 * have "isnorm (P1 \<otimes> Q1)" "isnorm (P2 \<otimes> Q2)"
    "isnorm (P1 \<otimes> mkPinj 1 Q2)" "isnorm (Q1 \<otimes> mkPinj 1 P2)"
    by (auto simp add: mkPinj_cn)
  with 9 X0 Y0 have
    "isnorm (mkPX (P1 \<otimes> Q1) (x + y) (P2 \<otimes> Q2))"
    "isnorm (mkPX (P1 \<otimes> mkPinj (Suc 0) Q2) x (Pc 0))"
    "isnorm (mkPX (Q1 \<otimes> mkPinj (Suc 0) P2) y (Pc 0))"
    by (auto simp add: mkPX_cn)
  then show ?case
    by (simp add: add_cn)
qed

text \<open>neg conserves normalizedness\<close>
lemma neg_cn: "isnorm P \<Longrightarrow> isnorm (neg P)"
proof (induct P)
  case Pc
  then show ?case by simp
next
  case (Pinj i P2)
  then have "isnorm P2"
    by (simp add: norm_Pinj[of i P2])
  with Pinj show ?case
    by (cases P2) (auto, cases i, auto)
next
  case (PX P1 x P2) note PX1 = this
  from PX have "isnorm P2" "isnorm P1"
    by (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
  with PX show ?case
  proof (cases P1)
    case (PX p1 y p2)
    with PX1 show ?thesis
      by (cases x) (auto, cases p2, auto)
  next
    case Pinj
    with PX1 show ?thesis
      by (cases x) auto
  qed (cases x, auto)
qed

text \<open>sub conserves normalizedness\<close>
lemma sub_cn: "isnorm p \<Longrightarrow> isnorm q \<Longrightarrow> isnorm (p \<ominus> q)"
  by (simp add: sub_def add_cn neg_cn)

text \<open>sqr conserves normalizizedness\<close>
lemma sqr_cn: "isnorm P \<Longrightarrow> isnorm (sqr P)"
proof (induct P)
  case Pc
  then show ?case by simp
next
  case (Pinj i Q)
  then show ?case
    apply (cases Q)
    apply (auto simp add: mkPX_cn mkPinj_cn)
    apply (cases i)
    apply (auto simp add: mkPX_cn mkPinj_cn)
    done
next
  case (PX P1 x P2)
  then have "x + x \<noteq> 0" "isnorm P2" "isnorm P1"
    apply (cases x)
    using PX
    apply (auto simp add: norm_PX1[of P1 x P2] norm_PX2[of P1 x P2])
    done
  with PX have "isnorm (mkPX (Pc (1 + 1) \<otimes> P1 \<otimes> mkPinj (Suc 0) P2) x (Pc 0))"
    and "isnorm (mkPX (sqr P1) (x + x) (sqr P2))"
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
  then show ?case
    by (auto simp add: add_cn mkPX_cn mkPinj_cn mul_cn)
qed

text \<open>pow conserves normalizedness\<close>
lemma pow_cn: "isnorm P \<Longrightarrow> isnorm (pow n P)"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  show ?case
  proof (cases "k = 0")
    case True
    then show ?thesis by simp
  next
    case False
    then have K2: "k div 2 < k"
      by (cases k) auto
    from less have "isnorm (sqr P)"
      by (simp add: sqr_cn)
    with less False K2 show ?thesis
      by (cases "even k") (auto simp add: mul_cn elim: evenE oddE)
  qed
qed

end


(*<*)
theory SPRViewNonDet
imports
  SPRView
  KBPsAuto
begin
(*>*)

subsection{*Perfect Recall in Non-deterministic Broadcast Environments*}

text_raw{*
\begin{figure}[ht]
\begin{isabellebody}%
*}
record ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState =
  es :: "'es"
  ps :: "'a \<Rightarrow> 'ps"
  pubActs :: "'ePubAct \<times> ('a \<Rightarrow> 'pPubAct)"

locale FiniteBroadcastEnvironment =
  Environment jkbp envInit envAction envTrans envVal envObs
    for jkbp :: "('a :: finite, 'p, ('pPubAct :: finite \<times> 'ps :: finite)) JKBP"
    and envInit
         :: "('a, 'ePubAct :: finite, 'es :: finite, 'pPubAct, 'ps) BEState list"
    and envAction :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState
                   \<Rightarrow> ('ePubAct \<times> 'ePrivAct) list"
    and envTrans :: "('ePubAct \<times> 'ePrivAct)
                  \<Rightarrow> ('a \<Rightarrow> ('pPubAct \<times> 'ps))
                  \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState
                  \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState"
    and envVal :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState \<Rightarrow> 'p \<Rightarrow> bool"
    and envObs :: "'a \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState
                \<Rightarrow> ('cobs \<times> 'ps \<times> ('ePubAct \<times> ('a \<Rightarrow> 'pPubAct)))"

+ fixes envObsC :: "'es \<Rightarrow> 'cobs"
    and envActionES :: "'es \<Rightarrow> ('ePubAct \<times> ('a \<Rightarrow> 'pPubAct))
                            \<Rightarrow> ('ePubAct \<times> 'ePrivAct) list"
    and envTransES :: "('ePubAct \<times> 'ePrivAct) \<Rightarrow> ('a \<Rightarrow> 'pPubAct)
                    \<Rightarrow> 'es \<Rightarrow> 'es"
  defines envObs_def: "envObs a \<equiv> (\<lambda>s. (envObsC (es s), ps s a, pubActs s))"
      and envAction_def: "envAction s \<equiv> envActionES (es s) (pubActs s)"
      and envTrans_def:
           "envTrans eact aact s \<equiv> \<lparr> es = envTransES eact (fst \<circ> aact) (es s)
                                    , ps = snd \<circ> aact
                                    , pubActs = (fst eact, fst \<circ> aact) \<rparr>"
text_raw{*
  \end{isabellebody}%
  \caption{Finite broadcast environments with non-deterministic KBPs.}
  \label{fig:kbps-theory-broadcast-envs}
\end{figure}
*}

(*<*)
instance BEState_ext :: (finite, finite, finite, finite, finite, finite) finite
proof
 let ?U = "UNIV :: ('a, 'b, 'c, 'd, 'e, 'f) BEState_ext set"
 { fix x :: "('a, 'b, 'c, 'd, 'e, 'f) BEState_scheme"
   have "\<exists>a b c d. x = BEState_ext a b c d"
     by (cases x) simp
 } then have U:
   "?U = (\<lambda>(((a, b), c), d). BEState_ext a b c d) ` (((UNIV \<times> UNIV) \<times> UNIV) \<times> UNIV)"
     by (auto simp add: image_def)
 show "finite ?U" by (simp add: U)
qed

(*>*)
text{*

\label{sec:kbps-theory-spr-non-deterministic-protocols}

For completeness we reproduce the results of \citet{Ron:1996}
regarding non-deterministic KBPs in broadcast environments.

The determinism requirement is replaced by the constraint that actions
be split into public and private components, where the private part
influences the agents' private states, and the public part is
broadcast and recorded in the system state. Moreover the protocol of
the environment is only a function of the environment state, and not
the agents' private states. Once again an agent's view consists of the
common observation and their private state. The situation is described
by the locale in Figure~\ref{fig:kbps-theory-broadcast-envs}. Note
that as we do not intend to generate code for this case, we adopt more
transparent but less effective representations.

Our goal in the following is to instantiate the @{term
"SimIncrEnvironment"} locale with respect to the assumptions made in
the @{term "FiniteBroadcastEnvironment"} locale. We begin by defining
similar simulation machinery to the previous section.

*}

context FiniteBroadcastEnvironment
begin

text{*

As for the deterministic variant, we abstract traces using the common
observation. Note that this now includes the public part of the
agents' actions.

*}

definition
  tObsC :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
         \<Rightarrow> ('cobs \<times> 'ePubAct \<times> ('a \<Rightarrow> 'pPubAct)) Trace"
where
  "tObsC \<equiv> tMap (\<lambda>s. (envObsC (es s), pubActs s))"
(*<*)

lemma spr_jview_tObsC:
  assumes "spr_jview a t = spr_jview a t'"
  shows "tObsC t = tObsC t'"
  using SPR.sync[rule_format, OF assms] assms
  by (induct rule: trace_induct2) (auto simp: envObs_def tObsC_def)

lemma tObsC_tLength:
  "tObsC t = tObsC t' \<Longrightarrow> tLength t = tLength t'"
  unfolding tObsC_def by (rule tMap_eq_imp_tLength_eq)

lemma tObsC_tStep_eq_inv:
  "tObsC t' = tObsC (t \<leadsto> s) \<Longrightarrow> \<exists>t'' s'. t' = t'' \<leadsto> s'"
  unfolding tObsC_def by auto

lemma tObsC_prefix_closed[dest]:
  "tObsC (t \<leadsto> s) = tObsC (t' \<leadsto> s') \<Longrightarrow> tObsC t = tObsC t'"
  unfolding tObsC_def by simp

lemma tObsC_tLast[iff]:
  "tLast (tObsC t) = (envObsC (es (tLast t)), pubActs (tLast t))"
  unfolding tObsC_def by simp

lemma tObsC_tStep:
  "tObsC (t \<leadsto> s) = tObsC t \<leadsto> (envObsC (es s), pubActs s)"
  unfolding tObsC_def by simp

lemma tObsC_initial[iff]:
  "tFirst (tObsC t) = (envObsC (es (tFirst t)), pubActs (tFirst t))"
  "tObsC (tInit s) = tInit (envObsC (es s), pubActs s)"
  "tObsC t = tInit cobs \<longleftrightarrow> (\<exists>s. t = tInit s \<and> envObsC (es s) = fst cobs \<and> pubActs s = snd cobs)"
  unfolding tObsC_def by auto

lemma spr_tObsC_trc_aux:
  assumes "(t, t') \<in> (\<Union>a. relations SPR.MC a)\<^sup>*"
  shows "tObsC t = tObsC t'"
  using assms
  apply (induct)
   apply simp
  apply clarsimp
  apply (rule_tac a=x in spr_jview_tObsC)
  apply simp
  done

(*>*)
text{*

Similarly we introduce common and agent-specific abstraction functions:

*}

definition
  tObsC_abs :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
             \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Relation"
where
  "tObsC_abs t \<equiv> { (tFirst t', tLast t')
                   |t'. t' \<in> SPR.jkbpC \<and> tObsC t' = tObsC t }"

definition
  agent_abs :: "'a \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
             \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Relation"
where
  "agent_abs a t \<equiv> { (tFirst t', tLast t')
                     |t'. t' \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t }"
(*<*)

lemma tObsC_abs_jview_eq[dest, intro]:
  "spr_jview a t' = spr_jview a t
    \<Longrightarrow> tObsC_abs t = tObsC_abs t'"
  unfolding tObsC_abs_def by (fastforce dest: spr_jview_tObsC)

lemma tObsC_absI[intro]:
  "\<lbrakk> t' \<in> SPR.jkbpC; tObsC t' = tObsC t; u = tFirst t'; v = tLast t' \<rbrakk>
    \<Longrightarrow> (u, v) \<in> tObsC_abs t"
  unfolding tObsC_abs_def by blast

lemma tObsC_abs_conv:
  "(u, v) \<in> tObsC_abs t
    \<longleftrightarrow> (\<exists>t'. t' \<in> SPR.jkbpC \<and> tObsC t' = tObsC t \<and> u = tFirst t' \<and> v = tLast t')"
  unfolding tObsC_abs_def by blast

lemma agent_absI[elim]:
  "\<lbrakk> t' \<in> SPR.jkbpC; spr_jview a t' = spr_jview a t; u = tFirst t'; v = tLast t' \<rbrakk>
    \<Longrightarrow> (u, v) \<in> agent_abs a t"
  unfolding agent_abs_def by blast

lemma agent_abs_tLastD[simp]:
  "(u, v) \<in> agent_abs a t \<Longrightarrow> envObs a v = envObs a (tLast t)"
  unfolding agent_abs_def by auto

lemma agent_abs_inv[dest]:
  "(u, v) \<in> agent_abs a t
    \<Longrightarrow> \<exists>t'. t' \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t
           \<and> u = tFirst t' \<and> v = tLast t'"
  unfolding agent_abs_def by blast

(*>*)

end (* context FiniteBroadcastEnvironment *)

text{*

The simulation is identical to that in the previous section:

*}

record ('a, 'ePubAct, 'es, 'pPubAct, 'ps) SPRstate =
  sprFst :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState"
  sprLst :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState"
  sprCRel :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Relation"

context FiniteBroadcastEnvironment
begin

definition
  spr_sim :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
           \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) SPRstate"
where
  "spr_sim \<equiv> \<lambda>t. \<lparr> sprFst = tFirst t, sprLst = tLast t, sprCRel = tObsC_abs t \<rparr>"
(*<*)

lemma spr_sim_tFirst_tLast:
  "\<lbrakk> spr_sim t = s; t \<in> SPR.jkbpC \<rbrakk> \<Longrightarrow> (sprFst s, sprLst s) \<in> sprCRel s"
  unfolding spr_sim_def by auto

(*>*)
text{*

The Kripke structure over simulated traces is also the same:

*}

definition
  spr_simRels :: "'a \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) SPRstate Relation"
where
  "spr_simRels \<equiv> \<lambda>a. { (s, s') |s s'.
                         envObs a (sprFst s) = envObs a (sprFst s')
                       \<and> envObs a (sprLst s) = envObs a (sprLst s')
                       \<and> sprCRel s = sprCRel s' }"

definition
  spr_simVal :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) SPRstate \<Rightarrow> 'p \<Rightarrow> bool"
where
  "spr_simVal \<equiv> envVal \<circ> sprLst"

abbreviation
  "spr_simMC \<equiv> mkKripke (spr_sim ` SPR.jkbpC) spr_simRels spr_simVal"
(*<*)

lemma spr_simVal_def2[iff]:
  "spr_simVal (spr_sim t) = envVal (tLast t)"
  unfolding spr_sim_def spr_simVal_def by simp

(*>*)
text{*

As usual, showing that @{term "spr_sim"} is in fact a simulation is
routine for all properties except for reverse simulation. For that we
use proof techniques similar to those of
\citet{DBLP:journals/tocl/LomuscioMR00}: the goal is to show that,
given @{term "t \<in> jkbpC"}, we can construct a trace @{term "t' \<in>
jkbpC"} indistinguishable from @{term "t"} by agent @{term "a"}, based
on the public actions, the common observation and @{term "a"}'s
private and initial states.

To do this we define a splicing operation:

*}

definition
  sSplice :: "'a
           \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState
           \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState
           \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState"
where
  "sSplice a s s' \<equiv> s\<lparr> ps := (ps s)(a := ps s' a) \<rparr>"
(*<*)

lemma sSplice_es[simp]:
  "es (sSplice a s s') = es s"
  unfolding sSplice_def by simp

lemma sSplice_pubActs[simp]:
  "pubActs (sSplice a s s') = pubActs s"
  unfolding sSplice_def by simp

lemma sSplice_envObs[simp]:
  assumes init: "envObs a s = envObs a s'"
  shows "sSplice a s s' = s"
proof -
  from init have "ps s a = ps s' a"
    by (auto simp: envObs_def)
  thus ?thesis
    unfolding sSplice_def by (simp add: fun_upd_idem_iff)
qed

lemma sSplice_envObs_a:
  assumes "envObsC (es s) = envObsC (es s')"
  assumes "pubActs s = pubActs s'"
  shows "envObs a (sSplice a s s') = envObs a s'"
  using assms
  unfolding sSplice_def envObs_def by simp

lemma sSplice_envObs_not_a:
  assumes "a' \<noteq> a"
  shows "envObs a' (sSplice a s s') = envObs a' s"
  using assms
  unfolding sSplice_def envObs_def by simp

(*>*)
text{*

The effect of @{term "sSplice a s s'"} is to update @{term "s"} with
@{term "a"}'s private state in @{term "s'"}. The key properties are
that provided the common observation on @{term "s"} and @{term "s'"}
are the same, then agent @{term "a"}'s observation on @{term "sSplice
a s s'"} is the same as
 at @{term "s'"}, while everyone else's is the
same as at @{term "s"}.

We hoist this operation pointwise to traces:

*}

abbreviation
  tSplice :: "('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
            \<Rightarrow> 'a
            \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace
            \<Rightarrow> ('a, 'ePubAct, 'es, 'pPubAct, 'ps) BEState Trace"
      ("_ \<^bsub>\<^esub>\<bowtie>\<^bsub>_\<^esub> _" [55, 1000, 56] 55)
where
  "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t' \<equiv> tZip (sSplice a) t t'"
(*<*)

declare sSplice_envObs_a[simp] sSplice_envObs_not_a[simp]

lemma tSplice_tObsC:
  assumes tObsC: "tObsC t = tObsC t'"
  shows "tObsC (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') = tObsC t"
  using tObsC_tLength[OF tObsC] tObsC
  by (induct rule: trace_induct2) (simp_all add: tObsC_tStep)

lemma tSplice_spr_jview_a:
  assumes tObsC: "tObsC t = tObsC t'"
  shows "spr_jview a (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') = spr_jview a t'"
  using tObsC_tLength[OF tObsC] tObsC
  by (induct rule: trace_induct2) (simp_all add: tObsC_tStep spr_jview_def)

lemma tSplice_spr_jview_not_a:
  assumes tObsC: "tObsC t = tObsC t'"
  assumes aa': "a \<noteq> a'"
  shows "spr_jview a' (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') = spr_jview a' t"
  using tObsC_tLength[OF tObsC] tObsC aa'
  by (induct rule: trace_induct2) (simp_all add: tObsC_tStep spr_jview_def)

lemma tSplice_es:
  assumes tLen: "tLength t = tLength t'"
  shows "es (tLast (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t')) = es (tLast t)"
  using tLen by (induct rule: trace_induct2) simp_all

lemma tSplice_pubActs:
  assumes tLen: "tLength t = tLength t'"
  shows "pubActs (tLast (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t')) = pubActs (tLast t)"
  using tLen by (induct rule: trace_induct2) simp_all

lemma tSplice_tFirst[simp]:
  assumes tLen: "tLength t = tLength t'"
  assumes init: "envObs a (tFirst t) = envObs a (tFirst t')"
  shows "tFirst (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') = tFirst t"
  using tLen init by (induct rule: trace_induct2) simp_all

lemma tSplice_tLast[simp]:
  assumes tLen: "tLength t = tLength t'"
  assumes last: "envObs a (tLast t) = envObs a (tLast t')"
  shows "tLast (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') = tLast t"
  using tLen last
  unfolding envObs_def
  apply (induct rule: trace_induct2)
  apply (auto iff: sSplice_def fun_upd_idem_iff)
  done

(*>*)
text{*

The key properties are that after splicing, if @{term "t"} and @{term
"t'"} have the same common observation, then so does @{term "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub>
t'"}, and for all agents @{term "a' \<noteq> a"}, the view @{term "a'"} has
of @{term "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t'"} is the same as it has of @{term "t"}, while for
@{term "a"} it is the same as @{term "t'"}.

We can conclude that provided the two traces are initially
indistinguishable to @{term "a"}, and not commonly distinguishable,
then @{term "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t'"} is a canonical trace:

*}

lemma tSplice_jkbpC:
  assumes tt': "{t, t'} \<subseteq> SPR.jkbpC"
  assumes init: "envObs a (tFirst t) = envObs a (tFirst t')"
  assumes tObsC: "tObsC t = tObsC t'"
  shows "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t' \<in> SPR.jkbpC"
(*<*)
using tObsC_tLength[OF tObsC] tt' init tObsC
proof(induct rule: trace_induct2)
  case (tInit s s') thus ?case by simp
next
  case (tStep s s' t t')

  hence tt': "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t' \<in> SPR.jkbpC"
    and tLen: "tLength t' = tLength t"
    and tObsC: "tObsC (t \<leadsto> s) = tObsC (t' \<leadsto> s')"
    by auto

  hence tt'n: "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t' \<in> SPR.jkbpCn (tLength t)"
    by auto

  from tStep
  have ts: "t \<leadsto> s \<in> SPR.jkbpCn (Suc (tLength t))"
   and t's': "t' \<leadsto> s' \<in> SPR.jkbpCn (Suc (tLength t'))"
    apply -
     apply ((rule SPR.jkbpC_tLength_inv, simp_all)[1])+
    done

  from ts obtain eact aact
    where eact: "eact \<in> set (envAction (tLast t))"
      and aact: "\<forall>a. aact a \<in> set (jAction (SPR.mkM (SPR.jkbpCn (tLength t))) t a)"
      and trans: "envTrans eact aact (tLast t) = s"
    apply (auto iff: Let_def)
    done

  from t's' obtain eact' aact'
    where eact': "eact' \<in> set (envAction (tLast t'))"
      and aact': "\<forall>a. aact' a \<in> set (jAction (SPR.mkM (SPR.jkbpCn (tLength t'))) t' a)"
      and trans': "envTrans eact' aact' (tLast t') = s'"
    apply (auto iff: Let_def)
    done

  def aact'' \<equiv> "aact (a := aact' a)"

  from tObsC trans trans'
  have aact''_fst: "fst \<circ> aact'' = fst \<circ> aact"
    unfolding envTrans_def aact''_def
    apply -
    apply (rule ext)
    apply (auto iff: tObsC_tStep)
    apply (erule o_eq_elim)
    apply simp
    done

  from tObsC trans trans'
  have aact''_snd: "snd \<circ> aact'' = (snd \<circ> aact)(a := ps s' a)"
    unfolding envTrans_def aact''_def
    apply -
    apply (rule ext)
    apply auto
    done

  have "envTrans eact aact'' (tLast (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t'))
      = sSplice a (envTrans eact aact (tLast t)) s'"
    unfolding envTrans_def sSplice_def
    using tSplice_es[OF tLen[symmetric]] aact''_fst aact''_snd
    apply clarsimp
    done

  moreover

  { fix a'
    have "aact'' a' \<in> set (jAction (SPR.mkM (SPR.jkbpCn (tLength t))) (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') a')"
    proof(cases "a' = a")
      case False
      with tStep have "jAction (SPR.mkM (SPR.jkbpCn (tLength t))) (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') a'
                     = jAction (SPR.mkM (SPR.jkbpCn (tLength t))) t a'"
        apply -
        apply (rule S5n_jAction_eq)
         apply simp
        unfolding SPR.mkM_def
        using tSplice_spr_jview_not_a tt'
        apply auto
        done
      with False aact show ?thesis
        unfolding aact''_def by simp
    next
      case True
      with tStep have "jAction (SPR.mkM (SPR.jkbpCn (tLength t))) (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') a
                     = jAction (SPR.mkM (SPR.jkbpCn (tLength t))) t' a"
        apply -
        apply (rule S5n_jAction_eq)
         apply simp
        unfolding SPR.mkM_def
        using tSplice_spr_jview_a tt'
        apply auto
        done
      with True aact' tLen show ?thesis
        unfolding aact''_def by simp
    qed }

  moreover

  from tStep have "envAction (tLast (t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t')) = envAction (tLast t)"
    using tSplice_envAction by blast

  moreover note eact trans tt'n

  ultimately have "(t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> t') \<leadsto> sSplice a s s' \<in> SPR.jkbpCn (Suc (tLength t))"
    apply (simp add: Let_def del: split_paired_Ex)
    apply (rule exI[where x="eact"])
    apply (rule exI[where x="aact''"])
    apply simp
    done

  thus ?case
    apply (simp only: tZip.simps)
    apply blast
    done
qed

lemma spr_sim_r:
  "sim_r SPR.MC spr_simMC spr_sim"
proof(rule sim_rI)
  fix a p q'
  assume pT: "p \<in> worlds SPR.MC"
     and fpq': "(spr_sim p, q') \<in> relations spr_simMC a"
  from fpq' obtain uq fq vq
    where q': "q' = \<lparr> sprFst = uq, sprLst = vq, sprCRel = tObsC_abs p \<rparr>"
      and uq: "envObs a (tFirst p) = envObs a uq"
      and vq: "envObs a (tLast p) = envObs a vq"
    unfolding mkKripke_def spr_sim_def spr_simRels_def
    by fastforce

  from fpq' have "q' \<in> worlds spr_simMC" by simp
  with q' have "(uq, vq) \<in> tObsC_abs p"
    using spr_sim_tFirst_tLast[where s=q']
    apply auto
    done

  then obtain t
    where tT: "t \<in> SPR.jkbpC"
      and tp: "tObsC t = tObsC p"
      and tuq: "tFirst t = uq"
      and tvq: "tLast t = vq"
    by (auto iff: tObsC_abs_conv)

  def q \<equiv> "t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> p"

  from tp tuq uq
  have "spr_jview a p = spr_jview a q"
    unfolding q_def by (simp add: tSplice_spr_jview_a)

  with pT tT tp tuq uq
  have pt: "(p, q) \<in> relations SPR.MC a"
    unfolding SPR.mkM_def q_def by (simp add: tSplice_jkbpC)
  from q' uq vq tp tuq tvq
  have ftq': "spr_sim q = q'"
    unfolding spr_sim_def q_def
    using tSplice_tObsC[where a=a and t=t and t'=p]
    apply clarsimp
    apply (intro conjI)
      apply (auto dest: tObsC_tLength)[2]
    unfolding tObsC_abs_def (* FIXME abstract *)
    apply simp
    done
  from pt ftq'
  show "\<exists>q. (p, q) \<in> relations SPR.MC a \<and> spr_sim q = q'"
    by blast
qed

(*>*)
text{*

The proof is by induction over @{term "t"} and @{term "t'"}, and
depends crucially on the public actions being recorded in the state
and commonly observed. Showing the reverse simulation property is then
straightforward.

*}

lemma spr_sim: "sim SPR.MC spr_simMC spr_sim"
(*<*)
proof
  show "sim_range SPR.MC spr_simMC spr_sim"
    by (rule sim_rangeI) (simp_all add: spr_sim_def)
next
  show "sim_val SPR.MC spr_simMC spr_sim"
    by (rule sim_valI) simp
next
  show "sim_f SPR.MC spr_simMC spr_sim"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by (rule sim_fI, auto simp del: split_paired_Ex)
next
  show "sim_r SPR.MC spr_simMC spr_sim"
    by (rule spr_sim_r)
qed

(*>*)
end (* context FiniteBroadcastEnvironment *)

sublocale FiniteBroadcastEnvironment
        < SPR!: SimIncrEnvironment jkbp envInit envAction envTrans envVal
                                       spr_jview envObs spr_jviewInit spr_jviewIncr
                                       spr_sim spr_simRels spr_simVal
(*<*)
  by default (simp add: spr_sim)

(*>*)
text{*

The algorithmic representations and machinery of the deterministic
JKBP case suffice for this one too, and so we omit the details.

\FloatBarrier

*}
(*<*)

end
(*>*)


(*  Title:       Inductive definition of Hoare logic for total correctness
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory PHoareTotal imports PHoare PTermi begin

subsection\<open>Hoare logic for total correctness\<close>

text\<open>Validity is defined as expected:\<close>

definition
 tvalid :: "'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
    "\<Turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow>  \<Turnstile> {P}c{Q} \<and> (\<forall>z s. P z s \<longrightarrow> c\<down>s)"

definition
 ctvalid :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool"
            ("(_ /\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_))}" 50) where
 "C \<Turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow> (\<forall>(P',c',Q') \<in> C. \<Turnstile>\<^sub>t {P'}c'{Q'}) \<longrightarrow> \<Turnstile>\<^sub>t {P}c{Q}"

inductive
  thoare :: "'a cntxt \<Rightarrow> 'a assn \<Rightarrow> com \<Rightarrow> 'a assn \<Rightarrow> bool"
   ("(_ \<turnstile>\<^sub>t/ ({(1_)}/ (_)/ {(1_)}))" [50,0,0,0] 50)
where
  Do: "C \<turnstile>\<^sub>t {\<lambda>z s. (\<forall>t \<in> f s . P z t) \<and> f s \<noteq> {}} Do f {P}"
| Semi: "\<lbrakk> C \<turnstile>\<^sub>t {P}c1{Q}; C \<turnstile>\<^sub>t {Q}c2{R} \<rbrakk> \<Longrightarrow> C \<turnstile>\<^sub>t {P} c1;c2 {R}"
| If: "\<lbrakk> C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> b s}c{Q}; C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> ~b s}d{Q}  \<rbrakk> \<Longrightarrow>
      C \<turnstile>\<^sub>t {P} IF b THEN c ELSE d {Q}"
| While:
  "\<lbrakk>wf r;  \<forall>s'. C \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> b s \<and> s' = s} c {\<lambda>z s. P z s \<and> (s,s') \<in> r}\<rbrakk>
   \<Longrightarrow> C \<turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>z s. P z s \<and> \<not>b s}"

| Call:
  "\<lbrakk>wf r;  \<forall>s'. {(\<lambda>z s. P z s \<and> (s,s') \<in> r, CALL, Q)}
                 \<turnstile>\<^sub>t {\<lambda>z s. P z s \<and> s = s'} body {Q}\<rbrakk>
   \<Longrightarrow> {} \<turnstile>\<^sub>t {P} CALL {Q}"

| Asm: "{(P,CALL,Q)} \<turnstile>\<^sub>t {P} CALL {Q}"

| Conseq:
  "\<lbrakk> C \<turnstile>\<^sub>t {P'}c{Q'};
     (\<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t)) \<and>
     (\<forall>s. (\<exists>z. P z s) \<longrightarrow> (\<exists>z. P' z s)) \<rbrakk>
   \<Longrightarrow> C \<turnstile>\<^sub>t {P}c{Q}"

| Local: "\<lbrakk> \<forall>s'. C \<turnstile>\<^sub>t {\<lambda>z s. P z s' \<and> s = f s'} c {\<lambda>z t. Q z (g s' t)} \<rbrakk> \<Longrightarrow>
        C \<turnstile>\<^sub>t {P} LOCAL f;c;g {Q}"

abbreviation hoare1 :: "'a cntxt \<Rightarrow> 'a assn \<times> com \<times> 'a assn \<Rightarrow> bool" ("_ \<turnstile>\<^sub>t _") where
  "C \<turnstile>\<^sub>t x \<equiv> C \<turnstile>\<^sub>t {fst x}fst (snd x){snd (snd x)}"

text\<open>The side condition in our rule of consequence looks quite different
from the one by Kleymann, but the two are in fact equivalent:\<close>

lemma "((\<forall>s t. (\<forall>z. P' z s \<longrightarrow> Q' z t) \<longrightarrow> (\<forall>z. P z s \<longrightarrow> Q z t)) \<and>
            (\<forall>s. (\<exists>z. P z s) \<longrightarrow> (\<exists>z. P' z s)))
        = (\<forall>z s. P z s \<longrightarrow> (\<forall>t.\<exists>z'. P' z' s \<and> (Q' z' t \<longrightarrow> Q z t)))"
by blast

text\<open>The key difference to the work by Kleymann (and America and de
Boer) is that soundness and completeness are shown for arbitrary,
i.e.\ unbounded nondeterminism.  This is a significant extension and
appears to have been an open problem. The details are found below and
are explained in a separate paper~\cite{Nipkow-CSL02}.\<close>

lemmas tvalid_defs = tvalid_def ctvalid_def valid_defs

lemma [iff]:
"(\<Turnstile>\<^sub>t {\<lambda>z s. P z s \<and> P'}c{Q}) = (P' \<longrightarrow> \<Turnstile>\<^sub>t {P}c{Q})"
apply(unfold tvalid_defs)
apply fast
done

lemma [iff]: "(\<Turnstile>\<^sub>t {P}CALL{Q}) = (\<Turnstile>\<^sub>t {P}body{Q})"
apply(unfold tvalid_defs)
apply fast
done

theorem "C \<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  C \<Turnstile>\<^sub>t {P}c{Q}"
apply(erule thoare.induct)
       apply(simp only:tvalid_defs)
       apply fast
      apply(simp only:tvalid_defs)
      apply fast
     apply(simp only:tvalid_defs)
     apply clarsimp
    prefer 3
    apply(simp add:tvalid_defs)
   prefer 3
   apply(simp only:tvalid_defs)
   apply blast
  apply(simp only:tvalid_defs)
  apply(rule impI, rule conjI)
   apply(rule allI)
   apply(erule wf_induct)
   apply clarify
   apply(drule unfold_while[THEN iffD1])
   apply (simp split: if_split_asm)
   apply fast
  apply(rule allI, rule allI)
  apply(erule wf_induct)
  apply clarify
  apply(case_tac "b x")
   prefer 2
   apply (erule termi.WhileFalse)
  apply(rule termi.WhileTrue, assumption)
   apply fast
  apply (subgoal_tac "(t,x):r")
   apply fast
  apply blast
 apply(simp (no_asm_use) add:ctvalid_def)
 apply(subgoal_tac "\<forall>n. \<Turnstile>\<^sub>t {\<lambda>z s. P z s \<and> s=n} body {Q}")
  apply(simp (no_asm_use) add:tvalid_defs)
  apply blast
 apply(rule allI)
 apply(erule wf_induct)
 apply(unfold tvalid_defs)
 apply fast
apply fast
done

definition MGT\<^sub>t :: "com \<Rightarrow> state assn \<times> com \<times> state assn" where
  [simp]: "MGT\<^sub>t c = (\<lambda>z s. z = s \<and> c\<down>s, c, \<lambda>z t. z -c\<rightarrow> t)"

lemma MGT_implies_complete:
 "{} \<turnstile>\<^sub>t MGT\<^sub>t c \<Longrightarrow> {} \<Turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> {} \<turnstile>\<^sub>t {P}c{Q::state assn}"
apply(simp add: MGT\<^sub>t_def)
apply (erule thoare.Conseq)
apply(simp add: tvalid_defs)
apply blast
done

lemma while_termiE: "\<lbrakk> WHILE b DO c \<down> s; b s \<rbrakk> \<Longrightarrow> c \<down> s"
by(erule termi.cases, auto)

lemma while_termiE2:
  "\<lbrakk> WHILE b DO c \<down> s; b s; s -c\<rightarrow> t \<rbrakk> \<Longrightarrow> WHILE b DO c \<down> t"
by(erule termi.cases, auto)

lemma MGT_lemma: "C \<turnstile>\<^sub>t MGT\<^sub>t CALL \<Longrightarrow> C \<turnstile>\<^sub>t MGT\<^sub>t c"
apply (simp)
apply(induct_tac c)
     apply (rule strengthen_pre[OF _ thoare.Do])
     apply blast
    apply(rename_tac com1 com2)
    apply(rule_tac Q = "\<lambda>z s. z -com1\<rightarrow>s & com2\<down>s" in thoare.Semi)
     apply(erule thoare.Conseq)
     apply fast
    apply(erule thoare.Conseq)
    apply fast
   apply(rule thoare.If)
    apply(erule thoare.Conseq)
    apply simp
   apply(erule thoare.Conseq)
   apply simp
  defer
  apply simp
 apply(fast intro:thoare.Local elim!: thoare.Conseq)
apply(rename_tac b c)
apply(rule_tac P' = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^* \<and>
                           WHILE b DO c \<down> s" in thoare.Conseq)
 apply(rule_tac thoare.While[OF wf_termi])
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply(fastforce intro:rtrancl_into_rtrancl dest:while_termiE while_termiE2)
apply(rule conjI)
 apply clarsimp
 apply(erule_tac x = s in allE)
 apply clarsimp
 apply(erule converse_rtrancl_induct)
  apply simp
 apply(fast elim:exec.WhileTrue)
apply(fast intro: rtrancl_refl)
done

inductive_set
  exec1 :: "((com list \<times> state) \<times> (com list \<times> state))set"
  and exec1' :: "(com list \<times> state) \<Rightarrow> (com list \<times> state) \<Rightarrow> bool"  ("_ \<rightarrow> _" [81,81] 100)
where
  "cs0 \<rightarrow> cs1 \<equiv> (cs0,cs1) : exec1"

| Do[iff]: "t \<in> f s \<Longrightarrow> ((Do f)#cs,s) \<rightarrow> (cs,t)"

| Semi[iff]: "((c1;c2)#cs,s) \<rightarrow> (c1#c2#cs,s)"

| IfTrue:   "b s \<Longrightarrow> ((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (c1#cs,s)"
| IfFalse: "\<not>b s \<Longrightarrow> ((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (c2#cs,s)"

| WhileFalse: "\<not>b s \<Longrightarrow> ((WHILE b DO c)#cs,s) \<rightarrow> (cs,s)"
| WhileTrue:   "b s \<Longrightarrow> ((WHILE b DO c)#cs,s) \<rightarrow> (c#(WHILE b DO c)#cs,s)"

| Call[iff]: "(CALL#cs,s) \<rightarrow> (body#cs,s)"

| Local[iff]: "((LOCAL f;c;g)#cs,s) \<rightarrow> (c # Do(\<lambda>t. {g s t})#cs, f s)"

abbreviation
  exectr :: "(com list \<times> state) \<Rightarrow> (com list \<times> state) \<Rightarrow> bool"   ("_ \<rightarrow>\<^sup>* _" [81,81] 100)
  where "cs0 \<rightarrow>\<^sup>* cs1 \<equiv> (cs0,cs1) : exec1^*"

inductive_cases exec1E[elim!]:
 "([],s) \<rightarrow> (cs',s')"
 "(Do f#cs,s) \<rightarrow> (cs',s')"
 "((c1;c2)#cs,s) \<rightarrow> (cs',s')"
 "((IF b THEN c1 ELSE c2)#cs,s) \<rightarrow> (cs',s')"
 "((WHILE b DO c)#cs,s) \<rightarrow> (cs',s')"
 "(CALL#cs,s) \<rightarrow> (cs',s')"
 "((LOCAL f;c;g)#cs,s) \<rightarrow> (cs',s')"

lemma [iff]: "\<not> ([],s) \<rightarrow> u"
by (induct u) blast

lemma app_exec: "(cs,s) \<rightarrow> (cs',s') \<Longrightarrow> (cs@cs2,s) \<rightarrow> (cs'@cs2,s')"
apply(erule exec1.induct)
       apply(simp_all del:fun_upd_apply)
   apply(blast intro:exec1.intros)+
done

lemma app_execs: "(cs,s) \<rightarrow>\<^sup>* (cs',s') \<Longrightarrow> (cs@cs2,s) \<rightarrow>\<^sup>* (cs'@cs2,s')"
apply(erule rtrancl_induct2)
 apply blast
apply(blast intro:app_exec rtrancl_trans)
done

lemma exec_impl_execs[rule_format]:
 "s -c\<rightarrow> s' \<Longrightarrow> \<forall>cs. (c#cs,s) \<rightarrow>\<^sup>* (cs,s')"
apply(erule exec.induct)
         apply blast
        apply(blast intro:rtrancl_trans)
       apply(blast intro:exec1.IfTrue rtrancl_trans)
      apply(blast intro:exec1.IfFalse rtrancl_trans)
     apply(blast intro:exec1.WhileFalse rtrancl_trans)
    apply(blast intro:exec1.WhileTrue rtrancl_trans)
   apply(blast intro: rtrancl_trans)
apply(blast intro: rtrancl_trans)
done

inductive
  execs :: "state \<Rightarrow> com list \<Rightarrow> state \<Rightarrow> bool"   ("_/ =_\<Rightarrow>/ _" [50,0,50] 50)
where
  "s =[]\<Rightarrow> s"
| "s -c\<rightarrow> t \<Longrightarrow> t =cs\<Rightarrow> u \<Longrightarrow> s =c#cs\<Rightarrow> u"

inductive_cases [elim!]:
 "s =[]\<Rightarrow> t"
 "s =c#cs\<Rightarrow> t"

theorem exec1s_impl_execs: "(cs,s) \<rightarrow>\<^sup>* ([],t) \<Longrightarrow> s =cs\<Rightarrow> t"
apply(erule converse_rtrancl_induct2)
 apply(rule execs.intros)
apply(erule exec1.cases)
apply(blast intro:execs.intros)
apply(blast intro:execs.intros)
apply(fastforce intro:execs.intros)
apply(fastforce intro:execs.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
apply(blast intro:execs.intros exec.intros)
done

theorem exec1s_impl_exec: "([c],s) \<rightarrow>\<^sup>* ([],t) \<Longrightarrow> s -c\<rightarrow> t"
by(blast dest: exec1s_impl_execs)

primrec termis :: "com list \<Rightarrow> state \<Rightarrow> bool" (infixl "\<Down>" 60) where
  "[]\<Down>s = True"
| "c#cs \<Down> s = (c\<down>s \<and> (\<forall>t. s -c\<rightarrow> t \<longrightarrow> cs\<Down>t))"

lemma exec1_pres_termis: "(cs,s) \<rightarrow> (cs',s') \<Longrightarrow> cs\<Down>s \<longrightarrow> cs'\<Down>s'"
apply(erule exec1.induct)
       apply(simp_all)
  apply blast
 apply(blast intro:while_termiE while_termiE2 exec.WhileTrue)
apply blast
done

lemma execs_pres_termis: "(cs,s) \<rightarrow>\<^sup>* (cs',s') \<Longrightarrow> cs\<Down>s \<longrightarrow> cs'\<Down>s'"
apply(erule rtrancl_induct2)
 apply blast
apply(blast dest:exec1_pres_termis)
done

definition
 termi_call_steps :: "(state \<times> state)set" where
"termi_call_steps = {(t,s). body\<down>s \<and> (\<exists>cs. ([body], s) \<rightarrow>\<^sup>* (CALL # cs, t))}"

lemma lem:
  "\<forall>y. (a,y)\<in>r\<^sup>+ \<longrightarrow> P a \<longrightarrow> P y \<Longrightarrow> ((b,a) \<in> {(y,x). P x \<and> (x,y):r}\<^sup>+) = ((b,a) \<in> {(y,x). P x \<and> (x,y)\<in>r\<^sup>+})"
apply(rule iffI)
 apply clarify
 apply(erule trancl_induct)
  apply blast
 apply(blast intro:trancl_trans)
apply clarify
apply(erule trancl_induct)
 apply blast
apply(blast intro:trancl_trans)
done

lemma renumber_aux:
 "\<lbrakk>\<forall>i. (a,f i) : r^* \<and> (f i,f(Suc i)) : r; (a,b) : r^* \<rbrakk> \<Longrightarrow> b = f 0 \<longrightarrow> (\<exists>f. f 0 = a & (\<forall>i. (f i, f(Suc i)) : r))"
apply(erule converse_rtrancl_induct)
 apply blast
apply(clarsimp)
apply(rule_tac x="\<lambda>i. case i of 0 \<Rightarrow> y | Suc i \<Rightarrow> fa i" in exI)
apply simp
apply clarify
apply(case_tac i)
 apply simp_all
done

lemma renumber:
 "\<forall>i. (a,f i) : r^* \<and> (f i,f(Suc i)) : r \<Longrightarrow> \<exists>f. f 0 = a & (\<forall>i. (f i, f(Suc i)) : r)"
by(blast dest:renumber_aux)

definition inf :: "com list \<Rightarrow> state \<Rightarrow> bool" where
"inf cs s \<longleftrightarrow> (\<exists>f. f 0 = (cs,s) \<and> (\<forall>i. f i \<rightarrow> f(Suc i)))"

lemma [iff]: "\<not> inf [] s"
apply(unfold inf_def)
apply clarify
apply(erule_tac x = 0 in allE)
apply simp
done

lemma [iff]: "\<not> inf [Do f] s"
apply(unfold inf_def)
apply clarify
apply(frule_tac x = 0 in spec)
apply(erule_tac x = 1 in allE)
apply(case_tac "fa (Suc 0)")
apply clarsimp
done

lemma [iff]: "inf ((c1;c2)#cs) s = inf (c1#c2#cs) s"
apply(unfold inf_def)
apply(rule iffI)
apply clarify
apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
apply(frule_tac x = 0 in spec)
apply(case_tac "f (Suc 0)")
apply clarsimp
apply clarify
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((c1;c2)#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp split:nat.split)
done

lemma [iff]: "inf ((IF b THEN c1 ELSE c2)#cs) s =
              inf ((if b s then c1 else c2)#cs) s"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(frule_tac x = 0 in spec)
 apply (case_tac "f (Suc 0)")
 apply(rule conjI)
  apply clarsimp
  apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
  apply clarsimp
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
 apply clarsimp
apply clarsimp
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((IF b THEN c1 ELSE c2)#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma [iff]: "inf (CALL#cs) s =  inf (body#cs) s"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(frule_tac x = 0 in spec)
 apply (case_tac "f (Suc 0)")
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. f(Suc i)" in exI)
 apply clarsimp
apply clarsimp
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> (CALL#cs,s) | Suc i \<Rightarrow> f i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma [iff]: "inf ((LOCAL f;c;g)#cs) s =
              inf (c#Do(\<lambda>t. {g s t})#cs) (f s)"
apply(unfold inf_def)
apply(rule iffI)
 apply clarsimp
 apply(rename_tac F)
 apply(frule_tac x = 0 in spec)
 apply (case_tac "F (Suc 0)")
 apply clarsimp
 apply(rule_tac x = "\<lambda>i. F(Suc i)" in exI)
 apply clarsimp
apply (clarsimp)
apply(rename_tac F)
apply(rule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> ((LOCAL f;c;g)#cs,s) | Suc i \<Rightarrow> F i" in exI)
apply(simp add: exec1.intros split:nat.split)
done

lemma exec1_only1_aux: "(ccs,s) \<rightarrow> (cs',t) \<Longrightarrow>
                    \<forall>c cs. ccs = c#cs \<longrightarrow> (\<exists>cs1. cs' = cs1 @ cs)"
apply(erule exec1.induct)
apply blast
apply force+
done

lemma exec1_only1: "(c#cs,s) \<rightarrow> (cs',t) \<Longrightarrow> \<exists>cs1. cs' = cs1 @ cs"
by(blast dest:exec1_only1_aux)

lemma exec1_drop_suffix_aux:
"(cs12,s) \<rightarrow> (cs1'2,s') \<Longrightarrow> \<forall>cs1 cs2 cs1'.
 cs12 = cs1@cs2 & cs1'2 = cs1'@cs2 & cs1 \<noteq> [] \<longrightarrow> (cs1,s) \<rightarrow> (cs1',s')"
apply(erule exec1.induct)
       apply (force intro:exec1.intros simp add: neq_Nil_conv)+
done

lemma exec1_drop_suffix:
 "(cs1@cs2,s) \<rightarrow> (cs1'@cs2,s') \<Longrightarrow> cs1 \<noteq> [] \<Longrightarrow> (cs1,s) \<rightarrow> (cs1',s')"
by(blast dest:exec1_drop_suffix_aux)

lemma execs_drop_suffix[rule_format(no_asm)]:
  "\<lbrakk> f 0 = (c#cs,s);\<forall>i. f(i) \<rightarrow> f(Suc i) \<rbrakk> \<Longrightarrow>
   (\<forall>i<k. p i \<noteq> [] & fst(f i) = p i@cs) \<longrightarrow> fst(f k) = p k@cs
   \<longrightarrow> ([c],s) \<rightarrow>\<^sup>* (p k,snd(f k))"
apply(induct_tac k)
 apply simp
apply (clarsimp)
apply(erule rtrancl_into_rtrancl)
apply(erule_tac x = n in allE)
apply(erule_tac x = n in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply simp
apply(blast dest:exec1_drop_suffix)
done

lemma execs_drop_suffix0:
  "\<lbrakk> f 0 = (c#cs,s);\<forall>i. f(i) \<rightarrow> f(Suc i); \<forall>i<k. p i \<noteq> [] & fst(f i) = p i@cs;
     fst(f k) = cs; p k = [] \<rbrakk> \<Longrightarrow> ([c],s) \<rightarrow>\<^sup>* ([],snd(f k))"
apply(drule execs_drop_suffix,assumption,assumption)
 apply simp
apply simp
done

lemma skolemize1: "\<forall>x. P x \<longrightarrow> (\<exists>y. Q x y) \<Longrightarrow> \<exists>f.\<forall>x. P x \<longrightarrow> Q x (f x)"
apply(rule_tac x = "\<lambda>x. SOME y. Q x y" in exI)
apply(fast intro:someI2)
done

lemma least_aux: "\<lbrakk>f 0 = (c # cs, s); \<forall>i. f i \<rightarrow> f (Suc i);
        fst(f k) = cs; \<forall>i<k. fst(f i) \<noteq> cs\<rbrakk>
       \<Longrightarrow> \<forall>i \<le> k. (\<exists>p. (p \<noteq> []) = (i < k) & fst(f i) = p @ cs)"
apply(rule allI)
apply(induct_tac i)
 apply simp
 apply (rule ccontr)
 apply simp
apply clarsimp
apply(drule order_le_imp_less_or_eq)
apply(erule disjE)
 prefer 2
 apply simp
apply simp
apply(erule_tac x = n in allE)
apply(erule_tac x = "Suc n" in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply simp
apply(rename_tac sn csn1 sn1)
apply (clarsimp simp add: neq_Nil_conv)
apply(drule exec1_only1)
apply (clarsimp simp add: neq_Nil_conv)
apply(erule disjE)
 apply clarsimp
apply clarsimp
apply(case_tac cs1)
 apply simp
apply simp
done

lemma least_lem: "\<lbrakk>f 0 = (c#cs,s); \<forall>i. f i \<rightarrow> f(Suc i); \<exists>i. fst(f i) = cs \<rbrakk>
       \<Longrightarrow> \<exists>k. fst(f k) = cs & ([c],s) \<rightarrow>\<^sup>* ([],snd(f k))"
apply(rule_tac x="LEAST i. fst(f i) = cs" in exI)
apply(rule conjI)
 apply(fast intro: LeastI)
apply(subgoal_tac
 "\<forall>i\<le>LEAST i. fst (f i) = cs. \<exists>p. ((p \<noteq> []) = (i<(LEAST i. fst (f i) = cs))) & fst(f i) = p@cs")
 apply(drule skolemize1)
 apply clarify
 apply(rename_tac p)
 apply(erule_tac p=p in execs_drop_suffix0, assumption)
   apply (blast dest:order_less_imp_le)
  apply(fast intro: LeastI)
 apply(erule thin_rl)
 apply(erule_tac x = "LEAST j. fst (f j) = fst (f i)" in allE)
 apply blast
apply(erule least_aux,assumption)
 apply(fast intro: LeastI)
apply clarify
apply(drule not_less_Least)
apply blast
done

lemma skolemize2: "\<forall>x.\<exists>y. P x y \<Longrightarrow> \<exists>f.\<forall>x. P x (f x)"
apply(rule_tac x = "\<lambda>x. SOME y. P x y" in exI)
apply(fast intro:someI2)
done

lemma inf_cases: "inf (c#cs) s \<Longrightarrow> inf [c] s \<or> (\<exists>t. s -c\<rightarrow> t \<and> inf cs t)"
apply(unfold inf_def)
apply (clarsimp del: disjCI)
apply(case_tac "\<exists>i. fst(f i) = cs")
 apply(rule disjI2)
 apply(drule least_lem, assumption, assumption)
 apply clarify
 apply(drule exec1s_impl_exec)
 apply(case_tac "f k")
 apply simp
 apply (rule exI, rule conjI, assumption)
 apply(rule_tac x="\<lambda>i. f(i+k)" in exI)
 apply (clarsimp)
apply(rule disjI1)
apply simp
apply(subgoal_tac "\<forall>i. \<exists>p. p \<noteq> [] \<and> fst(f i) = p@cs")
 apply(drule skolemize2)
 apply clarify
 apply(rename_tac p)
 apply(rule_tac x = "\<lambda>i. (p i, snd(f i))" in exI)
 apply(rule conjI)
  apply(erule_tac x = 0 in allE, erule conjE)
  apply simp
 apply clarify
 apply(erule_tac x = i in allE)
 apply(erule_tac x = i in allE)
 apply(frule_tac x = i in spec)
 apply(erule_tac x = "Suc i" in allE)
 apply(case_tac "f i")
 apply(case_tac "f(Suc i)")
 apply clarsimp
 apply(blast intro:exec1_drop_suffix)
apply(clarify)
apply(induct_tac i)
 apply force
apply clarsimp
apply(case_tac p)
 apply blast
apply(erule_tac x=n in allE)
apply(erule_tac x="Suc n" in allE)
apply(case_tac "f n")
apply(case_tac "f(Suc n)")
apply clarsimp
apply(drule exec1_only1)
apply clarsimp
done

lemma termi_impl_not_inf: "c \<down> s \<Longrightarrow> \<not> inf [c] s"
apply(erule termi.induct)
        (*Do*)
        apply clarify
       (*Semi*)
       apply(blast dest:inf_cases)
      (* Cond *)
      apply clarsimp
     apply clarsimp
    (*While*)
    apply clarsimp
   apply(fastforce dest:inf_cases)
  (*Call*)
  apply blast
(*Local*)
apply(blast dest:inf_cases)
done

lemma termi_impl_no_inf_chain:
 "c\<down>s \<Longrightarrow> \<not>(\<exists>f. f 0 = ([c],s) \<and> (\<forall>i::nat. (f i, f(i+1)) : exec1^+))"
apply(subgoal_tac "wf({(y,x). ([c],s) \<rightarrow>\<^sup>* x & x \<rightarrow> y}^+)")
 apply(simp only:wf_iff_no_infinite_down_chain)
 apply(erule contrapos_nn)
 apply clarify
 apply(subgoal_tac "\<forall>i. ([c], s) \<rightarrow>\<^sup>* f i")
  prefer 2
  apply(rule allI)
  apply(induct_tac i)
   apply simp
  apply simp
  apply(blast intro: trancl_into_rtrancl rtrancl_trans)
 apply(rule_tac x=f in exI)
 apply clarify
 apply(drule_tac x=i in spec)
 apply(subst lem)
  apply(blast intro: trancl_into_rtrancl rtrancl_trans)
 apply clarsimp
apply(rule wf_trancl)
apply(simp only:wf_iff_no_infinite_down_chain)
apply(clarify)
apply simp
apply(drule renumber)
apply(fold inf_def)
apply(simp add: termi_impl_not_inf)
done

primrec cseq :: "(nat \<Rightarrow> state) \<Rightarrow> nat \<Rightarrow> com list" where
  "cseq S 0 = []"
| "cseq S (Suc i) = (SOME cs. ([body], S i) \<rightarrow>\<^sup>* (CALL # cs, S(i+1))) @ cseq S i"

lemma wf_termi_call_steps: "wf termi_call_steps"
apply(unfold termi_call_steps_def)
apply(simp only:wf_iff_no_infinite_down_chain)
apply(clarify)
apply(rename_tac S)
apply simp
apply(subgoal_tac "\<exists>Cs. Cs 0 = [] & (\<forall>i. (body # Cs i,S i) \<rightarrow>\<^sup>* (CALL # Cs(i+1), S(i+1)))")
prefer 2
 apply(rule_tac x = "cseq S" in exI)
 apply clarsimp
 apply(erule_tac x=i in allE)
 apply(clarify)
 apply(erule_tac P = "\<lambda>cs.([body],S i) \<rightarrow>\<^sup>* (CALL # cs, S(Suc i))" in someI2)
 apply(fastforce dest:app_execs)
apply clarify
apply(subgoal_tac "\<forall>i. ((body # Cs i,S i), (body # Cs(i+1), S(i+1))) : exec1^+")
 prefer 2
 apply(blast intro:rtrancl_into_trancl1)
apply(subgoal_tac "\<exists>f. f 0 = ([body],S 0) \<and> (\<forall>i. (f i, f(i+1)) : exec1^+)")
 prefer 2
 apply(rule_tac x = "\<lambda>i.(body#Cs i,S i)" in exI)
 apply blast
apply(blast dest:termi_impl_no_inf_chain)
done

lemma CALL_lemma:
"{(\<lambda>z s. (z=s \<and> body\<down>s) \<and> (s,t) \<in> termi_call_steps, CALL, \<lambda>z s. z -body\<rightarrow> s)} \<turnstile>\<^sub>t
 {\<lambda>z s. (z=s \<and> body\<down>t) \<and> (\<exists>cs. ([body],t) \<rightarrow>\<^sup>* (c#cs,s))} c {\<lambda>z s. z -c\<rightarrow> s}"
apply(induct_tac c)
(*Do*)
     apply (rule strengthen_pre[OF _ thoare.Do])
     apply(blast dest: execs_pres_termi)
(*Semi*)
    apply(rename_tac c1 c2)
    apply(rule_tac Q = "\<lambda>z s. body\<down>t & (\<exists>cs. ([body], t) \<rightarrow>\<^sup>* (c2#cs,s)) & z -c1\<rightarrow>s & c2\<down>s" in thoare.Semi)
     apply(erule thoare.Conseq)
     apply(rule conjI)
      apply clarsimp
      apply(subgoal_tac "s -c1\<rightarrow> ta")
       prefer 2
       apply(blast intro: exec1.Semi exec_impl_execs rtrancl_trans)
      apply(subgoal_tac "([body], t) \<rightarrow>\<^sup>* (c2 # cs, ta)")
       prefer 2
       apply(blast intro:exec1.Semi[THEN r_into_rtrancl] exec_impl_execs rtrancl_trans)
      apply(subgoal_tac "([body], t) \<rightarrow>\<^sup>* (c2 # cs, ta)")
       prefer 2
       apply(blast intro: exec_impl_execs rtrancl_trans)
      apply(blast intro:exec_impl_execs rtrancl_trans execs_pres_termi)
     apply(fast intro: exec1.Semi rtrancl_trans)
    apply(erule thoare.Conseq)
    apply blast
(*Call*)
   prefer 3
   apply(simp only:termi_call_steps_def)
   apply(rule thoare.Conseq[OF thoare.Asm])
   apply(blast dest: execs_pres_termi)
(*If*)
  apply(rule thoare.If)
   apply(erule thoare.Conseq)
   apply simp
   apply(blast intro: exec1.IfTrue rtrancl_trans)
  apply(erule thoare.Conseq)
  apply simp
  apply(blast intro: exec1.IfFalse rtrancl_trans)
(*Var*)
 defer
 apply simp
 apply(rule thoare.Local)
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply (clarsimp)
 apply(rule conjI)
  apply (clarsimp)
  apply(drule rtrancl_trans[OF _ r_into_rtrancl[OF exec1.Local]])
  apply(fast)
 apply (clarsimp)
 apply(drule rtrancl_trans[OF _ r_into_rtrancl[OF exec1.Local]])
 apply blast
apply(rename_tac b c)
apply(rule_tac P' = "\<lambda>z s. (z,s) \<in> ({(s,t). b s \<and> s -c\<rightarrow> t})^* \<and> body \<down> t \<and>
           (\<exists>cs. ([body], t) \<rightarrow>\<^sup>* ((WHILE b DO c) # cs, s))" in thoare.Conseq)
 apply(rule_tac thoare.While[OF wf_termi])
 apply(rule allI)
 apply(erule thoare.Conseq)
 apply clarsimp
 apply(rule conjI)
  apply clarsimp
  apply(rule conjI)
   apply(blast intro: rtrancl_trans exec1.WhileTrue)
  apply(rule conjI)
   apply(rule exI, rule rtrancl_trans, assumption)
   apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
  apply(rule conjI)
   apply(blast intro:execs_pres_termi)
  apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
 apply(blast intro: exec1.WhileTrue exec_impl_execs rtrancl_trans)
apply(rule conjI)
 apply clarsimp
 apply(erule_tac x = s in allE)
 apply clarsimp
 apply(erule impE)
  apply blast
 apply clarify
 apply(erule_tac a=s in converse_rtrancl_induct)
  apply simp
 apply(fast elim:exec.WhileTrue)
apply(fast intro: rtrancl_refl)
done

theorem "{} \<Turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  {} \<turnstile>\<^sub>t {P}c{Q::state assn}"
apply(erule MGT_implies_complete[OF MGT_lemma[OF MGT_CALL]])
done

end


header{*Theory of Cryptographic Keys for Security Protocols against the General Attacker*}

theory PublicGA imports EventGA begin

lemma invKey_K: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)

subsection{*Asymmetric Keys*}

datatype keymode = Signature | Encryption

consts
  publicKey :: "[keymode,agent] => key"

abbreviation
  pubEK :: "agent => key" where
  "pubEK == publicKey Encryption"

abbreviation
  pubSK :: "agent => key" where
  "pubSK == publicKey Signature"

abbreviation
  privateKey :: "[keymode, agent] => key" where
  "privateKey b A == invKey (publicKey b A)"

abbreviation
  (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
  priEK :: "agent => key" where
  "priEK A == privateKey Encryption A"

abbreviation
  priSK :: "agent => key" where
  "priSK A == privateKey Signature A"

text{*These abbreviations give backward compatibility.  They represent the
simple situation where the signature and encryption keys are the same.*}

abbreviation
  pubK :: "agent => key" where
  "pubK A == pubEK A"

abbreviation
  priK :: "agent => key" where
  "priK A == invKey (pubEK A)"

text{*By freeness of agents, no two agents have the same key.  Since
  @{term "True\<noteq>False"}, no agent has identical signing and encryption keys*}
specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' ==> b=c & A=A'"
   apply (rule exI [of _
       "%b A. 2 * case_agent (\<lambda>n. n + 2) A + case_keymode 0 1 b"])
   apply (auto simp add: inj_on_def split: agent.split keymode.split)
   apply presburger
   apply presburger
   done

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]: "privateKey b A \<noteq> publicKey c A'"

lemmas publicKey_neq_privateKey = privateKey_neq_publicKey [THEN not_sym]
declare publicKey_neq_privateKey [iff]

subsection{*Basic properties of @{term pubK} and @{term priK}*}

lemma publicKey_inject [iff]: "(publicKey b A = publicKey c A') = (b=c & A=A')"
by (blast dest!: injective_publicKey)

lemma not_symKeys_pubK [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "privateKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priEK: "K \<in> symKeys ==> K \<noteq> priEK A"
by auto

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) ==> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
by (unfold symKeys_def, auto)

lemma analz_symKeys_Decrypt:
     "[| Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H |]
      ==> X \<in> analz H"
by (auto simp add: symKeys_def)

subsection{*"Image" equations that hold for injective functions*}

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)
lemma publicKey_image_eq [simp]:
     "(publicKey b x \<in> publicKey c ` AA) = (b=c & x \<in> AA)"
by auto

lemma privateKey_notin_image_publicKey [simp]: "privateKey b x \<notin> publicKey c ` AA"
by auto

lemma privateKey_image_eq [simp]:
     "(privateKey b A \<in> invKey ` publicKey c ` AS) = (b=c & A\<in>AS)"
by auto

lemma publicKey_notin_image_privateKey [simp]: "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

subsection{*Symmetric Keys*}

text{*For some protocols, it is convenient to equip agents with symmetric as
well as asymmetric keys.  The theory @{text Shared} assumes that all keys
are symmetric.*}

consts
  shrK    :: "agent => key"    --{*long-term shared keys*}

specification (shrK)
  inj_shrK: "inj shrK"
  --{*No two agents have the same long-term key*}
   apply (rule exI [of _ "case_agent (\<lambda>n. n + 2)"])
   apply (simp add: inj_on_def split: agent.split)
   done

axiomatization where
  sym_shrK [iff]: "shrK X \<in> symKeys" --{*All shared keys are symmetric*}

text{*Injectiveness: Agents' long-term keys are distinct.*}
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_shrK [simp]: "invKey (shrK A) = shrK A"
by (simp add: invKey_K)

lemma analz_shrK_Decrypt:
     "[| Crypt (shrK A) X \<in> analz H; Key(shrK A) \<in> analz H |] ==> X \<in> analz H"
by auto

lemma analz_Decrypt':
     "[| Crypt K X \<in> analz H; K \<in> symKeys; Key K \<in> analz H |] ==> X \<in> analz H"
by (auto simp add: invKey_K)

lemma priK_neq_shrK [iff]: "shrK A \<noteq> privateKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_priK = priK_neq_shrK [THEN not_sym]
declare shrK_neq_priK [simp]

lemma pubK_neq_shrK [iff]: "shrK A \<noteq> publicKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_pubK = pubK_neq_shrK [THEN not_sym]
declare shrK_neq_pubK [simp]

lemma priEK_noteq_shrK [simp]: "priEK A \<noteq> shrK B"
by auto

lemma publicKey_notin_image_shrK [simp]: "publicKey b x \<notin> shrK ` AA"
by auto

lemma privateKey_notin_image_shrK [simp]: "privateKey b x \<notin> shrK ` AA"
by auto

lemma shrK_notin_image_publicKey [simp]: "shrK x \<notin> publicKey b ` AA"
by auto

lemma shrK_notin_image_privateKey [simp]: "shrK x \<notin> invKey ` publicKey b ` AA"
by auto

lemma shrK_image_eq [simp]: "(shrK x \<in> shrK ` AA) = (x \<in> AA)"
by auto

text{*For some reason, moving this up can make some proofs loop!*}
declare invKey_K [simp]

subsection{*Initial States of Agents*}

overloading
  initState \<equiv> initState
begin

primrec initState where

  initState_Friend:
    "initState (Friend i) =
       {Key (priEK (Friend i)), Key (priSK (Friend i)), Key (shrK (Friend i))} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"
end

lemma used_parts_subset_parts [rule_format]:
     "\<forall>X \<in> used evs. parts {X} \<subseteq> used evs"
apply (induct evs)
 prefer 2
 apply (simp add: used_Cons)
 apply (rule ballI)
 apply (case_tac a, auto)
apply (auto dest!: parts_cut)
txt{*Base case*}
apply (simp add: used_Nil)
done

lemma MPair_used_D: "{|X,Y|} \<in> used H ==> X \<in> used H & Y \<in> used H"
by (drule used_parts_subset_parts, simp, blast)

text{*There was a similar theorem in Event.thy, so perhaps this one can
  be moved up if proved directly by induction.*}
lemma MPair_used [elim!]:
     "[| {|X,Y|} \<in> used H;
         [| X \<in> used H; Y \<in> used H |] ==> P |]
      ==> P"
by (blast dest: MPair_used_D)

text{*Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.*}

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

lemma Crypt_notin_initState: "Crypt K X \<notin> parts (initState B)"
by (induct B, auto)

lemma Crypt_notin_used_empty [simp]: "Crypt K X \<notin> used []"
by (simp add: Crypt_notin_initState used_Nil)

(*** Basic properties of shrK ***)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_knows [iff]: "Key (shrK A) \<in> knows A evs"
by (simp add: initState_subset_knows [THEN subsetD])

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(** Fresh keys never clash with long-term shared keys **)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas neq_shrK = shrK_neq [THEN not_sym]
declare neq_shrK [simp]

subsection{*Function @{term "knows Spy"} *}

lemma not_SignatureE [elim!]: "b \<noteq> Signature \<Longrightarrow> b = Encryption"
  by (cases b, auto)

text{*Agents see their own private keys!*}
lemma priK_in_initState [iff]: "Key (privateKey b A) \<in> initState A"
  by (cases A, auto)

text{*Agents see all public keys!*}
lemma publicKey_in_initState [iff]: "Key (publicKey b A) \<in> initState B"
  by (cases B, auto)

text{*All public keys are visible*}
lemma spies_pubK [iff]: "Key (publicKey b A) \<in> knows B evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split add: event.split)
done

lemmas analz_spies_pubK = spies_pubK [THEN analz.Inj]
declare analz_spies_pubK [iff]

(*Note: there never is at this stage a lemma about what an agent cannot know*)

lemma publicKey_into_used [iff] :"Key (publicKey b A) \<in> used evs"
apply (rule initState_into_used)
apply (rule publicKey_in_initState [THEN parts.Inj])
done

lemma privateKey_into_used [iff]: "Key (privateKey b A) \<in> used evs"
apply(rule initState_into_used)
apply(rule priK_in_initState [THEN parts.Inj])
done

lemma Crypt_analz_bad:
     "[| Crypt (shrK A) X \<in> analz (knows A evs) |]
      ==> X \<in> analz (knows A evs)"
by force

subsection{*Fresh Nonces*}

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection{*Supply fresh nonces for possibility theorems*}

text{*In any trace, there is an upper bound N on the greatest nonce in use*}
lemma Nonce_supply_lemma: "EX N. ALL n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split add: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "EX N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection{*Specialized Rewriting for Theorems About @{term analz} and Image*}

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} Un H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

lemma Crypt_imp_keysFor :"[|Crypt K X \<in> H; K \<in> symKeys|] ==> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text{*Lemma for the trivial direction of the if-and-only-if of the
Session Key Compromise Theorem*}
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) --> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemmas analz_image_freshK_simps =
       simp_thms mem_simps --{*these two allow its use with @{text "only:"}*}
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD]
       insert_Key_singleton
       Key_not_used insert_Key_image Un_assoc [THEN sym]

ML {*
structure Public =
struct

val analz_image_freshK_ss =
  simpset_of (@{context}
    delsimps [image_insert, image_Un]
    delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
    addsimps @{thms analz_image_freshK_simps})

(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt delsimps [@{thm used_Says}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac [refl, conjI]))

end
*}

method_setup analz_freshK = {*
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac [allI, ballI, impI]),
          REPEAT_FIRST (rtac @{thm analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Public.analz_image_freshK_ss ctxt))]))) *}
    "for proving the Session Key Compromise theorem"

subsection{*Specialized Methods for Possibility Theorems*}

method_setup possibility = {*
    Scan.succeed (SIMPLE_METHOD o Public.possibility_tac) *}
    "for proving possibility theorems"

method_setup basic_possibility = {*
    Scan.succeed (SIMPLE_METHOD o Public.basic_possibility_tac) *}
    "for proving possibility theorems"

end