(*******************************************************************************

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  sklvl1.thy (Isabelle/HOL 2016-1)
  ID:      $Id: sklvl1.thy 133183 2017-01-31 13:55:43Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Level-1 Diffie-Hellman guard protocol augmented with two nonces.
  Refines model dhlvl1, moving towards SKEME/IKEv1 protocol.

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>SKEME Protocol (L1)\<close>

theory sklvl1
imports dhlvl1
begin

declare option.split_asm [split]

(**************************************************************************************************)
subsection \<open>State and Events\<close>
(**************************************************************************************************)

abbreviation ni :: nat where "ni \<equiv> 4"
abbreviation nr :: nat where "nr \<equiv> 5"

text \<open>Proofs break if @{term "1"} is used, because @{method "simp"} replaces it with
@{term "Suc 0"}\dots.\<close>

abbreviation
  "xni \<equiv> Var 7"

abbreviation
  "xnr \<equiv> Var 8"

text \<open>Domain of each role (protocol-dependent).\<close>

fun domain :: "role_t \<Rightarrow> var set" where
  "domain Init = {xnx, xni, xnr, xgnx, xgny, xsk, xEnd}"
| "domain Resp = {xny, xni, xnr, xgnx, xgny, xsk, xEnd}"

consts
  guessed_frame :: "rid_t \<Rightarrow> frame"

text \<open>Specification of the guessed frame:
\begin{enumerate}
\item Domain.
\item Well-typedness.
  The messages in the frame of a run never contain implementation material
  even if the agents of the run are dishonest.
  Therefore we consider only well-typed frames.
  This is notably required for the session key compromise; it also helps proving
  the partitionning of ik,
  since we know that the messages added by the protocol do not contain ltkeys in their
  payload and are therefore valid implementations.
\item We also ensure that the values generated by the frame owner are correctly guessed.
\item The new frame extends the previous one (from @{theory Key_Agreement_Strong_Adversaries.dhlvl1})
\end{enumerate}
\<close>
specification (guessed_frame)
  guessed_frame_dom_spec [simp]:
    "dom (guessed_frame R) = domain (role (guessed_runs R))"
  guessed_frame_payload_spec [simp, elim]:
    "guessed_frame R x = Some y \<Longrightarrow> y \<in> payload"
  guessed_frame_Init_xnx [simp]:
    "role (guessed_runs R) = Init \<Longrightarrow> guessed_frame R xnx = Some (NonceF (R$nx))"
  guessed_frame_Init_xgnx [simp]:
    "role (guessed_runs R) = Init \<Longrightarrow> guessed_frame R xgnx = Some (Exp Gen (NonceF (R$nx)))"
  guessed_frame_Init_xni [simp]:
    "role (guessed_runs R) = Init \<Longrightarrow> guessed_frame R xni = Some (NonceF (R$ni))"
  guessed_frame_Resp_xny [simp]:
    "role (guessed_runs R) = Resp \<Longrightarrow> guessed_frame R xny = Some (NonceF (R$ny))"
  guessed_frame_Resp_xgny [simp]:
    "role (guessed_runs R) = Resp \<Longrightarrow> guessed_frame R xgny = Some (Exp Gen (NonceF (R$ny)))"
  guessed_frame_Resp_xnr [simp]:
    "role (guessed_runs R) = Resp \<Longrightarrow> guessed_frame R xnr = Some (NonceF (R$nr))"
  guessed_frame_xEnd [simp]:
    "guessed_frame R xEnd = Some End"
  guessed_frame_eq [simp]:
    "x \<in> {xnx, xny, xgnx, xgny, xsk, xEnd} \<Longrightarrow> dhlvl1.guessed_frame R x = guessed_frame R x"
apply (rule exI [of _
    "\<lambda>R.
      if role (guessed_runs R) = Init then
        (dhlvl1.guessed_frame R) (xni \<mapsto> NonceF (R$ni), xnr \<mapsto> End)
      else
        (dhlvl1.guessed_frame R) (xnr \<mapsto> NonceF (R$nr), xni \<mapsto> End)"],
  auto simp add: domIff intro: role_t.exhaust)
done

record skl1_state =
  l1_state +
  signalsInit2 :: "signal \<Rightarrow> nat"
  signalsResp2 :: "signal \<Rightarrow> nat"

type_synonym skl1_obs = "skl1_state"

text \<open>Protocol events:
\begin{itemize}
\item step 1: create @{term "Ra"}, @{term "A"} generates @{term "nx"} and @{term "ni"},
  computes $@{term "g"}^@{term "nx"}$
\item step 2: create @{term "Rb"}, @{term "B"} reads @{term "ni"} and $@{term "g"}^@{term "nx"}$
  insecurely,
  generates @{term "ny"} and @{term "nr"}, computes $@{term "g"}^@{term "ny"}$,
  computes $@{term "g"}^@{term "nx*ny"}$,
  emits a running signal for @{term "Init"}, @{term "ni"}, @{term "nr"}, $@{term "g"}^@{term "nx*ny"}$
\item step 3: @{term "A"} reads $@{term "g"}^@{term "ny"}$ and $@{term "g"}^@{term "nx"}$
  authentically,
  computes $@{term "g"}^@{term "ny*nx"}$, emits a commit signal for @{term "Init"}, @{term "ni"},
  @{term "nr"}, $@{term "g"}^@{term "ny*nx"}$,
  a running signal for @{term "Resp"}, @{term "ni"}, @{term "nr"}, $@{term "g"}^@{term "ny*nx"}$,
  declares the secret $@{term "g"}^@{term "ny*nx"}$
\item step 4: @{term "B"} reads @{term "nr"}, @{term "ni"}, $@{term "g"}^@{term "nx"}$
  and $@{term "g"}^@{term "ny"}$ authentically,
  emits a commit signal for @{term "Resp"}, @{term "ni"}, @{term "nr"},
  $@{term "g"}^@{term "nx*ny"}$,
  declares the secret $@{term "g"}^@{term "nx*ny"}$
\end{itemize}
\<close>
definition
  skl1_step1 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> ('a skl1_state_scheme * 'a skl1_state_scheme) set"
where
  "skl1_step1 Ra A B \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    Ra \<notin> dom (progress s) \<and>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      progress := (progress s)(Ra \<mapsto> {xnx, xni, xgnx})
      \<rparr>
  }"

definition
  skl1_step2 ::
    "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> msg \<Rightarrow> ('a skl1_state_scheme * 'a skl1_state_scheme) set"
where
  "skl1_step2 Rb A B Ni gnx \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
    Rb \<notin> dom (progress s) \<and>
    guessed_frame Rb xgnx = Some gnx \<and>
    guessed_frame Rb xni = Some Ni \<and>
    guessed_frame Rb xsk = Some (Exp gnx (NonceF (Rb$ny))) \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr> progress := (progress s)(Rb \<mapsto> {xny, xni, xnr, xgny, xgnx, xsk}),
            signalsInit :=
              if can_signal s A B then
                addSignal (signalsInit s)
                          (Running A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>)
              else
                signalsInit s,
            signalsInit2 :=
              if can_signal s A B then
                addSignal (signalsInit2 s) (Running A B (Exp gnx (NonceF (Rb$ny))))
              else
                signalsInit2 s
          \<rparr>
  }"

definition
  skl1_step3 ::
    "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> msg \<Rightarrow> ('a skl1_state_scheme * 'a skl1_state_scheme) set"
where
  "skl1_step3 Ra A B Nr gny \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    progress s Ra = Some {xnx, xni, xgnx} \<and>
    guessed_frame Ra xgny = Some gny \<and>
    guessed_frame Ra xnr = Some Nr \<and>
    guessed_frame Ra xsk = Some (Exp gny (NonceF (Ra$nx))) \<and>
    (can_signal s A B \<longrightarrow> \<comment> \<open>authentication guard\<close>
      (\<exists> Rb. guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
             in_progressS (progress s Rb) {xny, xni, xnr, xgnx, xgny, xsk} \<and>
             guessed_frame Rb xgny = Some gny \<and>
             guessed_frame Rb xnr = Some Nr \<and>
             guessed_frame Rb xni = Some (NonceF (Ra$ni)) \<and>
             guessed_frame Rb xgnx = Some (Exp Gen (NonceF (Ra$nx))))) \<and>
    (Ra = test \<longrightarrow> Exp gny (NonceF (Ra$nx)) \<notin> synth (analz (ik s))) \<and>

    \<comment> \<open>actions:\<close>
    s' = s\<lparr> progress := (progress s)(Ra \<mapsto> {xnx, xni, xnr, xgnx, xgny, xsk, xEnd}),
            secret := {x. x = Exp gny (NonceF (Ra$nx)) \<and> Ra = test} \<union> secret s,
            signalsInit :=
              if can_signal s A B then
                addSignal (signalsInit s)
                          (Commit A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>)
              else
                signalsInit s,
            signalsInit2 :=
              if can_signal s A B then
                addSignal (signalsInit2 s) (Commit A B (Exp gny (NonceF (Ra$nx))))
              else
                signalsInit2 s,
            signalsResp :=
              if can_signal s A B then
                addSignal (signalsResp s)
                          (Running A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>)
              else
                signalsResp s,
            signalsResp2 :=
              if can_signal s A B then
                addSignal (signalsResp2 s) (Running A B (Exp gny (NonceF (Ra$nx))))
              else
                signalsResp2 s
          \<rparr>
  }"

definition
  skl1_step4 ::
    "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> msg \<Rightarrow> ('a skl1_state_scheme * 'a skl1_state_scheme) set"
where
  "skl1_step4 Rb A B Ni gnx \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
    progress s Rb = Some {xny, xni, xnr, xgnx, xgny, xsk} \<and>
    guessed_frame Rb xgnx = Some gnx \<and>
    guessed_frame Rb xni = Some Ni \<and>
    (can_signal s A B \<longrightarrow> \<comment> \<open>authentication guard\<close>
      (\<exists> Ra. guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
             in_progressS (progress s Ra) {xnx, xni, xnr, xgnx, xgny, xsk, xEnd} \<and>
             guessed_frame Ra xgnx = Some gnx \<and>
             guessed_frame Ra xni = Some Ni \<and>
             guessed_frame Ra xnr = Some (NonceF (Rb$nr)) \<and>
             guessed_frame Ra xgny = Some (Exp Gen (NonceF (Rb$ny))))) \<and>
    (Rb = test \<longrightarrow> Exp gnx (NonceF (Rb$ny)) \<notin> synth (analz (ik s))) \<and>

    \<comment> \<open>actions:\<close>
    s' = s\<lparr> progress := (progress s)(Rb \<mapsto> {xny, xni, xnr, xgnx, xgny, xsk, xEnd}),
            secret := {x. x = Exp gnx (NonceF (Rb$ny)) \<and> Rb = test} \<union> secret s,
            signalsResp :=
              if can_signal s A B then
                addSignal (signalsResp s)
                          (Commit A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>)
              else
                signalsResp s,
            signalsResp2 :=
              if can_signal s A B then
                addSignal (signalsResp2 s) (Commit A B (Exp gnx (NonceF (Rb$ny))))
              else
                signalsResp2 s
          \<rparr>
  }"

text \<open>Specification.\<close>

definition
  skl1_trans :: "('a skl1_state_scheme * 'a skl1_state_scheme) set" where
  "skl1_trans \<equiv> (\<Union>m Ra Rb A B x y.
     skl1_step1 Ra A B \<union>
     skl1_step2 Rb A B x y \<union>
     skl1_step3 Ra A B x y \<union>
     skl1_step4 Rb A B x y \<union>
     l1_learn m \<union>
     Id
  )"

definition
  skl1_init :: "skl1_state set"
where
  "skl1_init \<equiv> { \<lparr>
    ik = {},
    secret = {},
    progress = Map.empty,
    signalsInit = \<lambda>x. 0,
    signalsResp = \<lambda>x. 0,
    signalsInit2 = \<lambda>x. 0,
    signalsResp2 = \<lambda>x. 0
    \<rparr> }"

definition
  skl1 :: "(skl1_state, skl1_obs) spec" where
  "skl1 \<equiv> \<lparr>
    init = skl1_init,
    trans = skl1_trans,
    obs = id
  \<rparr>"

lemmas skl1_defs =
  skl1_def skl1_init_def skl1_trans_def
  l1_learn_def
  skl1_step1_def skl1_step2_def skl1_step3_def skl1_step4_def

lemmas skl1_nostep_defs =
  skl1_def skl1_init_def skl1_trans_def

lemma skl1_obs_id [simp]: "obs skl1 = id"
by (simp add: skl1_def)

lemma run_ended_trans:
  "run_ended (progress s R) \<Longrightarrow>
   (s, s') \<in> trans skl1 \<Longrightarrow>
   run_ended (progress s' R)"
by (auto simp add: skl1_nostep_defs)
   (auto simp add: skl1_defs ik_dy_def domIff)

lemma can_signal_trans:
  "can_signal s' A B \<Longrightarrow>
  (s, s') \<in> trans skl1 \<Longrightarrow>
  can_signal s A B"
by (auto simp add: can_signal_def run_ended_trans)

(**************************************************************************************************)
subsection \<open>Refinement: secrecy\<close>
(**************************************************************************************************)

fun option_inter :: "var set \<Rightarrow> var set option \<Rightarrow> var set option"
where
  "option_inter S (Some x) = Some (x \<inter> S)"
 |"option_inter S None = None"

definition med_progress :: "progress_t \<Rightarrow> progress_t"
where
  "med_progress r \<equiv> \<lambda> R. option_inter {xnx, xny, xgnx, xgny, xsk, xEnd} (r R)"

lemma med_progress_upd [simp]:
  "med_progress (r(R \<mapsto> S)) = (med_progress r) (R \<mapsto> S \<inter> {xnx, xny, xgnx, xgny, xsk, xEnd})"
by (auto simp add: med_progress_def)

lemma med_progress_Some:
  "r x = Some s \<Longrightarrow> med_progress r x = Some (s \<inter> {xnx, xny, xgnx, xgny, xsk, xEnd})"
by (auto simp add: med_progress_def)

lemma med_progress_None [simp]: "med_progress r x = None \<longleftrightarrow> r x = None"
by (cases "r x", auto simp add: med_progress_def)

lemma med_progress_Some2 [dest]:
  "med_progress r x = Some y \<Longrightarrow> \<exists> z. r x = Some z \<and> y = z \<inter> {xnx, xny, xgnx, xgny, xsk, xEnd}"
by (cases "r x", auto simp add: med_progress_def)

lemma med_progress_dom [simp]: "dom (med_progress r) = dom r"
apply (auto simp add: domIff med_progress_def)
apply (rename_tac x y, case_tac "r x", auto)
done

lemma med_progress_empty [simp]: "med_progress Map.empty = Map.empty"
by (rule ext, auto)

text \<open>Mediator function.\<close>

definition
  med11 :: "skl1_obs \<Rightarrow> l1_obs"
where
  "med11 t \<equiv> \<lparr>ik = ik t,
              secret=secret t,
              progress = med_progress (progress t),
              signalsInit = signalsInit2 t,
              signalsResp = signalsResp2 t\<rparr>"

text \<open>relation between states\<close>
definition
  R11 :: "(l1_state * skl1_state) set"
where
  "R11 \<equiv> {(s,s').
    s = med11 s'
    }"

lemmas R11_defs = R11_def med11_def

lemma in_progress_med_progress:
  "x \<in> {xnx, xny, xgnx, xgny, xsk, xEnd}
  \<Longrightarrow> in_progress (med_progress r R) x \<longleftrightarrow> in_progress (r R) x"
by (cases "r R", auto)
   (cases "med_progress r R", auto)+

lemma in_progressS_eq: "in_progressS S S' \<longleftrightarrow> (S \<noteq> None \<and> (\<forall> x \<in> S'. in_progress S x))"
by (cases S, auto)

lemma in_progressS_med_progress:
  "in_progressS (r R) S
  \<Longrightarrow> in_progressS (med_progress r R) (S \<inter> {xnx, xny, xgnx, xgny, xsk, xEnd})"
by (auto simp add: in_progressS_eq in_progress_med_progress)

lemma can_signal_R11 [simp]:
  "(s1, s2) \<in> R11 \<Longrightarrow>
   can_signal s1 A B \<longleftrightarrow> can_signal s2 A B"
by (auto simp add: can_signal_def R11_defs in_progress_med_progress)

text \<open>Protocol-independent events.\<close>

lemma skl1_learn_refines_learn:
  "{R11} l1_learn m, l1_learn m {>R11}"
by (auto simp add: PO_rhoare_defs R11_defs)
   (simp add: l1_defs)

text \<open>Protocol events.\<close>

lemma skl1_step1_refines_step1:
  "{R11} l1_step1 Ra A B, skl1_step1 Ra A B {>R11}"
by (auto simp add: PO_rhoare_defs R11_defs l1_step1_def skl1_step1_def)

lemma skl1_step2_refines_step2:
  "{R11} l1_step2 Rb A B gnx, skl1_step2 Rb A B Ni gnx {>R11}"
by (auto simp add: PO_rhoare_defs R11_defs  l1_step2_def)
   (auto simp add: skl1_step2_def)

lemma skl1_step3_refines_step3:
  "{R11} l1_step3 Ra A B gny, skl1_step3 Ra A B Nr gny {>R11}"
apply (auto simp add: PO_rhoare_defs R11_defs l1_step3_def)
apply (auto simp add: skl1_step3_def, auto dest: med_progress_Some)
apply (drule in_progressS_med_progress, auto)+
done

lemma skl1_step4_refines_step4:
  "{R11} l1_step4 Rb A B gnx, skl1_step4 Rb A B Ni gnx {>R11}"
apply (auto simp add: PO_rhoare_defs R11_defs l1_step4_def)
apply (auto simp add: skl1_step4_def, auto dest: med_progress_Some)
apply (drule in_progressS_med_progress, auto)+
done

text \<open>Refinement proof.\<close>

lemmas skl1_trans_refines_l1_trans =
  skl1_learn_refines_learn
  skl1_step1_refines_step1 skl1_step2_refines_step2
  skl1_step3_refines_step3 skl1_step4_refines_step4

lemma skl1_refines_init_l1 [iff]:
  "init skl1 \<subseteq> R11 `` (init l1)"
by (auto simp add: R11_defs l1_defs skl1_defs)

lemma skl1_refines_trans_l1 [iff]:
  "{R11} trans l1, trans skl1 {> R11}"
by (auto 0 3 simp add: l1_def skl1_def l1_trans_def skl1_trans_def
             intro: skl1_trans_refines_l1_trans)

lemma obs_consistent_med11 [iff]:
  "obs_consistent R11 med11 l1 skl1"
by (auto simp add: obs_consistent_def R11_defs)

text \<open>Refinement result.\<close>

lemma skl1_refines_l1 [iff]:
  "refines
     R11
     med11 l1 skl1"
by (auto simp add:refines_def PO_refines_def)

lemma  skl1_implements_l1 [iff]: "implements med11 l1 skl1"
by (rule refinement_soundness) (fast)

(**************************************************************************************************)
subsection \<open>Derived invariants: secrecy\<close>
(**************************************************************************************************)

lemma skl1_obs_secrecy [iff]: "oreach skl1 \<subseteq> s0_secrecy"
apply (rule external_invariant_translation [OF l1_obs_secrecy _ skl1_implements_l1])
apply (auto simp add: med11_def s0_secrecy_def)
done

lemma skl1_secrecy [iff]: "reach skl1 \<subseteq> s0_secrecy"
by (rule external_to_internal_invariant [OF skl1_obs_secrecy], auto)

(**************************************************************************************************)
subsection \<open>Invariants: @{term "Init"} authenticates @{term "Resp"}\<close>
(**************************************************************************************************)

subsubsection \<open>inv1\<close>
(**************************************************************************************************)

text \<open>If an initiator commit signal exists for @{term "Ra$ni"}, @{term "Nr"},
  $(@{term "g"}^@{term "ny"})^@{term "Ra$nx"}$, then @{term "Ra"} is
  @{term "Init"}, has passed step 3, and has the nonce @{term "Nr"}, and
  \<open>(g^ny)^(Ra$nx)\<close> as the key in its frame.
\<close>
definition
  skl1_inv1 :: "skl1_state set"
where
  "skl1_inv1 \<equiv> {s. \<forall> Ra A B gny Nr.
    signalsInit s (Commit A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>) > 0 \<longrightarrow>
      guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
      progress s Ra = Some {xnx, xni, xnr, xgnx, xgny, xsk, xEnd} \<and>
      guessed_frame Ra xnr = Some Nr \<and>
      guessed_frame Ra xsk = Some (Exp gny (NonceF (Ra$nx)))
   }"

lemmas skl1_inv1I = skl1_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv1E [elim] = skl1_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv1D = skl1_inv1_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv1_init [iff]:
  "init skl1 \<subseteq> skl1_inv1"
by (auto simp add: skl1_def skl1_init_def skl1_inv1_def)

lemma skl1_inv1_trans [iff]:
  "{skl1_inv1} trans skl1 {> skl1_inv1}"
apply (auto simp add: PO_hoare_defs skl1_nostep_defs intro!: skl1_inv1I)
apply (auto simp add: skl1_defs ik_dy_def skl1_inv1_def domIff dest: Exp_Exp_Gen_inj2 [OF sym])
done

lemma PO_skl1_inv1 [iff]: "reach skl1 \<subseteq> skl1_inv1"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv2\<close>
(**************************************************************************************************)

text \<open>If a @{term "Resp"} run @{term "Rb"} has passed step 2 then (if possible)
an initiator running signal has been emitted.\<close>

definition
  skl1_inv2 :: "skl1_state set"
where
  "skl1_inv2 \<equiv> {s. \<forall> gnx A B Rb Ni.
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<longrightarrow>
    in_progressS (progress s Rb) {xny, xni, xnr, xgnx, xgny, xsk} \<longrightarrow>
    guessed_frame Rb xgnx = Some gnx \<longrightarrow>
    guessed_frame Rb xni = Some Ni \<longrightarrow>
    can_signal s A B \<longrightarrow>
      signalsInit s (Running A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>) > 0
  }"

lemmas skl1_inv2I = skl1_inv2_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv2E [elim] = skl1_inv2_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv2D = skl1_inv2_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv2_init [iff]:
  "init skl1 \<subseteq> skl1_inv2"
by (auto simp add: skl1_def skl1_init_def skl1_inv2_def)

lemma skl1_inv2_trans [iff]:
  "{skl1_inv2} trans skl1 {> skl1_inv2}"
apply (auto simp add: PO_hoare_defs intro!: skl1_inv2I)
apply (drule can_signal_trans, assumption)
apply (auto simp add: skl1_nostep_defs)
apply (auto simp add: skl1_defs ik_dy_def skl1_inv2_def)
done

lemma PO_skl1_inv2 [iff]: "reach skl1 \<subseteq> skl1_inv2"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv3 (derived)\<close>
(**************************************************************************************************)

text \<open>If an @{term "Init"} run before step 3 and a @{term "Resp"} run after step 2 both know
  the same half-keys and nonces (more or less), then the number of @{term "Init"} running signals
  for the key is strictly greater than the number of @{term "Init"} commit signals.
  (actually, there are 0 commit and 1 running).
\<close>

definition
  skl1_inv3 :: "skl1_state set"
where
  "skl1_inv3 \<equiv> {s. \<forall> A B Rb Ra gny Nr.
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<longrightarrow>
    in_progressS (progress s Rb) {xny, xni, xnr, xgnx, xgny, xsk} \<longrightarrow>
    guessed_frame Rb xgny = Some gny \<longrightarrow>
    guessed_frame Rb xnr = Some Nr \<longrightarrow>
    guessed_frame Rb xni = Some (NonceF (Ra$ni)) \<longrightarrow>
    guessed_frame Rb xgnx = Some (Exp Gen (NonceF (Ra$nx))) \<longrightarrow>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<longrightarrow>
    progress s Ra = Some {xnx, xgnx, xni} \<longrightarrow>
    can_signal s A B \<longrightarrow>
      signalsInit s (Commit A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>)
    < signalsInit s (Running A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>)
  }"

lemmas skl1_inv3I = skl1_inv3_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv3E [elim] = skl1_inv3_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv3D = skl1_inv3_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv3_derived: "skl1_inv1 \<inter> skl1_inv2 \<subseteq> skl1_inv3"
apply (auto intro!:skl1_inv3I)
apply (auto dest!: skl1_inv2D)
apply (rename_tac x A B Rb Ra)
apply (case_tac
  "signalsInit x (Commit A B
     \<langle>NonceF (Ra $ ni), NonceF (Rb $ nr),
      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>) > 0", auto)
apply (fastforce dest: skl1_inv1D elim: equalityE)
done

subsection \<open>Invariants: Resp authenticates Init\<close>
(**************************************************************************************************)

subsubsection \<open>inv4\<close>
(**************************************************************************************************)

text \<open>If a @{term "Resp"} commit signal exists for @{term "Ni"}, @{term "Rb$nr"},
  $(@{term "g"}^@{term "nx"})^@{term "Rb$ny"}$
  then @{term "Rb"} is @{term "Resp"}, has finished its run, and has the nonce @{term "Ni"} and
  $(@{term "g"}^@{term "nx"})^@{term "Rb$ny"}$ as the key in its frame.
\<close>
definition
  skl1_inv4 :: "skl1_state set"
where
  "skl1_inv4 \<equiv> {s. \<forall> Rb A B gnx Ni.
    signalsResp s (Commit A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>) > 0 \<longrightarrow>
      guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
      progress s Rb = Some {xny, xni, xnr, xgnx, xgny, xsk, xEnd} \<and>
      guessed_frame Rb xgnx = Some gnx \<and>
      guessed_frame Rb xni = Some Ni
   }"

lemmas skl1_inv4I = skl1_inv4_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv4E [elim] = skl1_inv4_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv4D = skl1_inv4_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv4_init [iff]:
  "init skl1 \<subseteq> skl1_inv4"
by (auto simp add: skl1_def skl1_init_def skl1_inv4_def)

lemma skl1_inv4_trans [iff]:
  "{skl1_inv4} trans skl1 {> skl1_inv4}"
apply (auto simp add: PO_hoare_defs skl1_nostep_defs intro!: skl1_inv4I)
apply (auto simp add: skl1_inv4_def skl1_defs ik_dy_def domIff dest: Exp_Exp_Gen_inj2 [OF sym])
done

lemma PO_skl1_inv4 [iff]: "reach skl1 \<subseteq> skl1_inv4"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv5\<close>
(**************************************************************************************************)

text \<open>If an @{term "Init"} run @{term "Ra"} has passed step3 then (if possible) a
@{term "Resp"} running signal has been emitted.\<close>

definition
  skl1_inv5 :: "skl1_state set"
where
  "skl1_inv5 \<equiv> {s. \<forall> gny A B Ra Nr.
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<longrightarrow>
    in_progressS (progress s Ra) {xnx, xni, xnr, xgnx, xgny, xsk, xEnd} \<longrightarrow>
    guessed_frame Ra xgny = Some gny \<longrightarrow>
    guessed_frame Ra xnr = Some Nr \<longrightarrow>
    can_signal s A B \<longrightarrow>
      signalsResp s (Running A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle>) > 0
  }"

lemmas skl1_inv5I = skl1_inv5_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv5E [elim] = skl1_inv5_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv5D = skl1_inv5_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv5_init [iff]:
  "init skl1 \<subseteq> skl1_inv5"
by (auto simp add: skl1_def skl1_init_def skl1_inv5_def)

lemma skl1_inv5_trans [iff]:
  "{skl1_inv5} trans skl1 {> skl1_inv5}"
apply (auto simp add: PO_hoare_defs intro!: skl1_inv5I)
apply (drule can_signal_trans, assumption)
apply (auto simp add: skl1_nostep_defs)
apply (auto simp add: skl1_defs ik_dy_def dest: skl1_inv5D)
done

lemma PO_skl1_inv5 [iff]: "reach skl1 \<subseteq> skl1_inv5"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv6 (derived)\<close>
(**************************************************************************************************)

text \<open>If a @{term "Resp"} run before step 4 and an @{term "Init"} run after step 3 both know
  the same half-keys (more or less), then the number of @{term "Resp"} running signals
  for the key is strictly greater than the number of @{term "Resp"} commit signals.
  (actually, there are 0 commit and 1 running).
\<close>

definition
  skl1_inv6 :: "skl1_state set"
where
  "skl1_inv6 \<equiv> {s. \<forall> A B Rb Ra gnx Ni.
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<longrightarrow>
    in_progressS (progress s Ra) {xnx, xni, xnr, xgnx, xgny, xsk, xEnd} \<longrightarrow>
    guessed_frame Ra xgnx = Some gnx \<longrightarrow>
    guessed_frame Ra xni = Some Ni \<longrightarrow>
    guessed_frame Ra xgny = Some (Exp Gen (NonceF (Rb$ny))) \<longrightarrow>
    guessed_frame Ra xnr = Some (NonceF (Rb$nr)) \<longrightarrow>
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<longrightarrow>
    progress s Rb = Some {xny, xni, xnr, xgnx, xgny, xsk} \<longrightarrow>
    can_signal s A B \<longrightarrow>
      signalsResp s (Commit A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>)
    < signalsResp s (Running A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle>)
  }"

lemmas skl1_inv6I = skl1_inv6_def [THEN setc_def_to_intro, rule_format]
lemmas skl1_inv6E [elim] = skl1_inv6_def [THEN setc_def_to_elim, rule_format]
lemmas skl1_inv6D = skl1_inv6_def [THEN setc_def_to_dest, rule_format, rotated 1, simplified]

lemma skl1_inv6_derived:
  "skl1_inv4 \<inter> skl1_inv5 \<subseteq> skl1_inv6"
proof (auto intro!: skl1_inv6I)
  fix s::skl1_state fix A B Rb Ra
  assume HRun:"guessed_runs Ra = \<lparr>role = Init, owner = A, partner = B\<rparr>"
              "in_progressS (progress s Ra) {xnx, xni, xnr, xgnx, xgny, xsk, xEnd}"
              "guessed_frame Ra xgny = Some (Exp Gen (NonceF (Rb $ ny)))"
              "guessed_frame Ra xnr = Some (NonceF (Rb $ nr))"
              "can_signal s A B"
  assume HRb: "progress s Rb = Some {xny, xni, xnr, xgnx, xgny, xsk}"
  assume I4:"s \<in> skl1_inv4"
  assume I5:"s \<in> skl1_inv5"
  from I4 HRb have "signalsResp s (Commit A B \<langle>NonceF (Ra$ni), NonceF (Rb$nr),
                      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>) > 0 \<Longrightarrow> False"
    proof (auto dest!: skl1_inv4D)
      assume "{xny, xni, xnr, xgnx, xgny, xsk, xEnd} = {xny, xni, xnr, xgnx, xgny, xsk}"
      thus ?thesis by force
    qed
  then have HC:"signalsResp s (Commit A B \<langle>NonceF (Ra$ni), NonceF (Rb$nr),
                      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>) = 0"
    by auto
  from I5 HRun have "signalsResp s (Running A B \<langle>NonceF (Ra$ni), NonceF (Rb$nr),
                      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>) > 0"
    by (auto dest!: skl1_inv5D)
  with HC show "signalsResp s (Commit A B \<langle>NonceF (Ra$ni), NonceF (Rb$nr),
                      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>)
              < signalsResp s (Running A B \<langle>NonceF (Ra$ni), NonceF (Rb$nr),
                      Exp (Exp Gen (NonceF (Rb $ ny))) (NonceF (Ra $ nx))\<rangle>)"
    by auto
qed

(**************************************************************************************************)
subsection \<open>Refinement: injective agreement  (Init authenticates Resp)\<close>
(**************************************************************************************************)

text \<open>Mediator function.\<close>

definition
  med0sk1iai :: "skl1_obs \<Rightarrow> a0i_obs"
where
  "med0sk1iai t \<equiv> \<lparr>a0n_state.signals = signalsInit t\<rparr>"

text \<open>Relation between states.\<close>

definition
  R0sk1iai :: "(a0i_state * skl1_state) set"
where
  "R0sk1iai \<equiv> {(s,s').
    a0n_state.signals s = signalsInit s'
    }"

text \<open>Protocol-independent events.\<close>

text \<open>Protocol events.\<close>

lemma skl1_step1_refines_a0i_skip_i:
  "{R0sk1iai} Id, skl1_step1 Ra A B {>R0sk1iai}"
by (auto simp add: PO_rhoare_defs R0sk1iai_def skl1_step1_def)

lemma skl1_step2_refines_a0i_running_skip_i:
  "{R0sk1iai} a0i_running A B \<langle>Ni, NonceF (Rb$nr),Exp gnx (NonceF (Rb$ny))\<rangle> \<union> Id,
              skl1_step2 Rb A B Ni gnx {>R0sk1iai}"
by (auto simp add: PO_rhoare_defs R0sk1iai_def,
    simp_all add: skl1_step2_def a0i_running_def, auto)

lemma skl1_step4_refines_a0i_skip_i:
  "{R0sk1iai} Id, skl1_step4 Rb A B Ni gnx {>R0sk1iai}"
by (auto simp add: PO_rhoare_defs R0sk1iai_def, auto simp add: skl1_step4_def)

text \<open>refinement proof\<close>
lemmas skl1_trans_refines_a0i_trans_i =
  skl1_learn_refines_a0_ia_skip_i
  skl1_step1_refines_a0i_skip_i skl1_step2_refines_a0i_running_skip_i
  skl1_step3_refines_a0i_commit_skip_i skl1_step4_refines_a0i_skip_i

lemma skl1_refines_init_a0i_i [iff]:
  "init skl1 \<subseteq> R0sk1iai `` (init a0i)"
by (auto simp add: R0sk1iai_def a0i_defs skl1_defs)

lemma skl1_refines_trans_a0i_i [iff]:
  "{R0sk1iai \<inter> (UNIV \<times> (skl1_inv1 \<inter> skl1_inv2))} trans a0i, trans skl1 {> R0sk1iai}"
proof -
  let ?pre' = "R0sk1iai \<inter> (UNIV \<times> skl1_inv3)"
  show ?thesis (is "{?pre} ?t1, ?t2 {>?post}")
  proof (rule relhoare_conseq_left)
    show "?pre \<subseteq> ?pre'"
      using skl1_inv3_derived by blast
  next
    show "{?pre'} ?t1, ?t2 {> ?post}"
      apply (auto simp add: a0i_def skl1_def a0i_trans_def skl1_trans_def)
      prefer 2 using skl1_step2_refines_a0i_running_skip_i apply (simp add: PO_rhoare_defs, blast)
      prefer 2 using skl1_step3_refines_a0i_commit_skip_i apply (simp add: PO_rhoare_defs, blast)
      apply (blast intro!:skl1_trans_refines_a0i_trans_i)+
      done
  qed
qed

lemma obs_consistent_med01iai [iff]:
  "obs_consistent R0sk1iai med0sk1iai a0i skl1"
by (auto simp add: obs_consistent_def R0sk1iai_def med0sk1iai_def)

text \<open>refinement result\<close>
lemma skl1_refines_a0i_i [iff]:
  "refines
     (R0sk1iai \<inter> (reach a0i \<times> (skl1_inv1 \<inter> skl1_inv2)))
     med0sk1iai a0i skl1"
by (rule Refinement_using_invariants, auto)

lemma  skl1_implements_a0i_i [iff]: "implements med0sk1iai a0i skl1"
by (rule refinement_soundness) (fast)

(**************************************************************************************************)
subsection \<open>Derived invariants: injective agreement (@{term "Init"} authenticates @{term "Resp"})\<close>
(**************************************************************************************************)

lemma skl1_obs_iagreement_Init [iff]: "oreach skl1 \<subseteq> l1_iagreement_Init"
apply (rule external_invariant_translation
         [OF PO_a0i_obs_agreement _ skl1_implements_a0i_i])
apply (auto simp add: med0sk1iai_def l1_iagreement_Init_def a0i_agreement_def)
done

lemma skl1_iagreement_Init [iff]: "reach skl1 \<subseteq> l1_iagreement_Init"
by (rule external_to_internal_invariant [OF skl1_obs_iagreement_Init], auto)

(**************************************************************************************************)
subsection \<open>Refinement: injective agreement  (@{term "Resp"} authenticates @{term "Init"})\<close>
(**************************************************************************************************)

text \<open>Mediator function.\<close>
definition
  med0sk1iar :: "skl1_obs \<Rightarrow> a0i_obs"
where
  "med0sk1iar t \<equiv> \<lparr>a0n_state.signals = signalsResp t\<rparr>"

text \<open>Relation between states.\<close>
definition
  R0sk1iar :: "(a0i_state * skl1_state) set"
where
  "R0sk1iar \<equiv> {(s,s').
    a0n_state.signals s = signalsResp s'
    }"

text \<open>Protocol independent events.\<close>

lemma skl1_learn_refines_a0_ia_skip_r:
  "{R0sk1iar} Id, l1_learn m {>R0sk1iar}"
apply (auto simp add: PO_rhoare_defs R0sk1iar_def)
apply (simp add: l1_learn_def)
done

text \<open>Protocol events.\<close>

lemma skl1_step1_refines_a0i_skip_r:
  "{R0sk1iar} Id, skl1_step1 Ra A B {>R0sk1iar}"
by (auto simp add: PO_rhoare_defs R0sk1iar_def skl1_step1_def)

lemma skl1_step2_refines_a0i_skip_r:
  "{R0sk1iar} Id, skl1_step2 Rb A B Ni gnx {>R0sk1iar}"
by (auto simp add: PO_rhoare_defs R0sk1iar_def, auto simp add:skl1_step2_def)

lemma skl1_step3_refines_a0i_running_skip_r:
  "{R0sk1iar}
     a0i_running A B \<langle>NonceF (Ra$ni), Nr, Exp gny (NonceF (Ra$nx))\<rangle> \<union> Id,
     skl1_step3 Ra A B Nr gny
   {>R0sk1iar}"
by (auto simp add: PO_rhoare_defs R0sk1iar_def,
    simp_all add: skl1_step3_def a0i_running_def, auto)

lemma skl1_step4_refines_a0i_commit_skip_r:
  "{R0sk1iar \<inter> UNIV\<times>skl1_inv6}
      a0i_commit A B \<langle>Ni, NonceF (Rb$nr), Exp gnx (NonceF (Rb$ny))\<rangle> \<union> Id,
      skl1_step4 Rb A B Ni gnx
   {>R0sk1iar}"
apply (auto simp add: PO_rhoare_defs R0sk1iar_def)
apply (auto simp add: skl1_step4_def a0i_commit_def)
apply (auto dest!: skl1_inv6D [rotated 1])
done

text \<open>Refinement proof.\<close>

lemmas skl1_trans_refines_a0i_trans_r =
  skl1_learn_refines_a0_ia_skip_r
  skl1_step1_refines_a0i_skip_r skl1_step2_refines_a0i_skip_r
  skl1_step3_refines_a0i_running_skip_r skl1_step4_refines_a0i_commit_skip_r

lemma skl1_refines_init_a0i_r [iff]:
  "init skl1 \<subseteq> R0sk1iar `` (init a0i)"
by (auto simp add: R0sk1iar_def a0i_defs skl1_defs)

lemma skl1_refines_trans_a0i_r [iff]:
  "{R0sk1iar \<inter> (UNIV \<times> (skl1_inv4 \<inter> skl1_inv5))} trans a0i, trans skl1 {> R0sk1iar}"
proof -
  let ?pre' = "R0sk1iar \<inter> (UNIV \<times> skl1_inv6)"
  show ?thesis (is "{?pre} ?t1, ?t2 {>?post}")
  proof (rule relhoare_conseq_left)
    show "?pre \<subseteq> ?pre'"
      using skl1_inv6_derived by blast
  next
    show "{?pre'} ?t1, ?t2 {> ?post}"
      apply (auto simp add: a0i_def skl1_def a0i_trans_def skl1_trans_def)
      prefer 3 using skl1_step3_refines_a0i_running_skip_r apply (simp add: PO_rhoare_defs, blast)
      prefer 3 using skl1_step4_refines_a0i_commit_skip_r apply (simp add: PO_rhoare_defs, blast)
      apply (blast intro!:skl1_trans_refines_a0i_trans_r)+
      done
  qed
qed

lemma obs_consistent_med0sk1iar [iff]:
  "obs_consistent R0sk1iar med0sk1iar a0i skl1"
by (auto simp add: obs_consistent_def R0sk1iar_def med0sk1iar_def)

text \<open>Refinement result.\<close>

lemma skl1_refines_a0i_r [iff]:
  "refines
     (R0sk1iar \<inter> (reach a0i \<times> (skl1_inv4 \<inter> skl1_inv5)))
     med0sk1iar a0i skl1"
by (rule Refinement_using_invariants, auto)

lemma  skl1_implements_a0i_r [iff]: "implements med0sk1iar a0i skl1"
by (rule refinement_soundness) (fast)

(**************************************************************************************************)
subsection \<open>Derived invariants: injective agreement (@{term "Resp"} authenticates @{term "Init"})\<close>
(**************************************************************************************************)

lemma skl1_obs_iagreement_Resp [iff]: "oreach skl1 \<subseteq> l1_iagreement_Resp"
apply (rule external_invariant_translation
         [OF PO_a0i_obs_agreement _ skl1_implements_a0i_r])
apply (auto simp add: med0sk1iar_def l1_iagreement_Resp_def a0i_agreement_def)
done

lemma skl1_iagreement_Resp [iff]: "reach skl1 \<subseteq> l1_iagreement_Resp"
by (rule external_to_internal_invariant [OF skl1_obs_iagreement_Resp], auto)

end


(*  Title:      HOL/Auth/n_german_lemma_on_inv__6.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_on_inv__6 imports n_german_base
begin
section{*All lemmas on causal relation between inv__6 and some rule r*}
lemma n_SendInvAckVsinv__6:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__6  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__6:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__6  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P3 s"
    apply (cut_tac a1 a2 b1 c1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan3'') p__Inv4) ''Cmd'')) (Const InvAck)) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const E))))" in exI, auto) done
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))\<or>((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))" by auto
  moreover {
    assume c1: "((formEval (eqn (IVar (Ident ''ExGntd'')) (Const true)) s))"
    have "?P3 s"
    apply (cut_tac a1 a2 b1 c1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan3'') i) ''Cmd'')) (Const InvAck)) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const E))))" in exI, auto) done
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  moreover {
    assume c1: "((formEval (neg (eqn (IVar (Ident ''ExGntd'')) (Const true))) s))"
    have "?P2 s"
    proof(cut_tac a1 a2 b1 c1, auto) qed
    then have "invHoldForRule s f r (invariants N)" by auto
  }
  ultimately have "invHoldForRule s f r (invariants N)" by satx
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__6:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__6  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__6:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__6  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__6:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__6  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const false)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const GntE))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__6:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqESVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqES  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendGntSVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendGntS  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInvSVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInvS  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendInvEVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendInvE  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReq N i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqSVsinv__6:
  assumes a1: "\<exists> j. j\<le>N\<and>r=n_SendReqS  j" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_SendReqEIVsinv__6:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_SendReqEI  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__6  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


(*  Title:      HOL/MicroJava/J/Conform.thy
    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Conformity Relations for Type Soundness Proof\<close>

theory Conform imports State WellType Exceptions begin

type_synonym 'c env' = "'c prog \<times> (vname \<rightharpoonup> ty)"  \<comment> "same as \<open>env\<close> of \<open>WellType.thy\<close>"

definition hext :: "aheap => aheap => bool" ("_ \<le>| _" [51,51] 50) where
 "h\<le>|h' == \<forall>a C fs. h a = Some(C,fs) --> (\<exists>fs'. h' a = Some(C,fs'))"

definition conf :: "'c prog => aheap => val => ty => bool"
                                   ("_,_ \<turnstile> _ ::\<preceq> _"  [51,51,51,51] 50) where
 "G,h\<turnstile>v::\<preceq>T == \<exists>T'. typeof (map_option obj_ty o h) v = Some T' \<and> G\<turnstile>T'\<preceq>T"

definition lconf :: "'c prog => aheap => ('a \<rightharpoonup> val) => ('a \<rightharpoonup> ty) => bool"
                                   ("_,_ \<turnstile> _ [::\<preceq>] _" [51,51,51,51] 50) where
 "G,h\<turnstile>vs[::\<preceq>]Ts == \<forall>n T. Ts n = Some T --> (\<exists>v. vs n = Some v \<and> G,h\<turnstile>v::\<preceq>T)"

definition oconf :: "'c prog => aheap => obj => bool" ("_,_ \<turnstile> _ \<surd>" [51,51,51] 50) where
 "G,h\<turnstile>obj \<surd> == G,h\<turnstile>snd obj[::\<preceq>]map_of (fields (G,fst obj))"

definition hconf :: "'c prog => aheap => bool" ("_ \<turnstile>h _ \<surd>" [51,51] 50) where
 "G\<turnstile>h h \<surd>    == \<forall>a obj. h a = Some obj --> G,h\<turnstile>obj \<surd>"

definition xconf :: "aheap \<Rightarrow> val option \<Rightarrow> bool" where
  "xconf hp vo  == preallocated hp \<and> (\<forall> v. (vo = Some v) \<longrightarrow> (\<exists> xc. v = (Addr (XcptRef xc))))"

definition conforms :: "xstate => java_mb env' => bool" ("_ ::\<preceq> _" [51,51] 50) where
 "s::\<preceq>E == prg E\<turnstile>h heap (store s) \<surd> \<and>
            prg E,heap (store s)\<turnstile>locals (store s)[::\<preceq>]localT E \<and>
            xconf (heap (store s)) (abrupt s)"

subsection "hext"

lemma hextI:
" \<forall>a C fs . h  a = Some (C,fs) -->
      (\<exists>fs'. h' a = Some (C,fs')) ==> h\<le>|h'"
apply (unfold hext_def)
apply auto
done

lemma hext_objD: "[|h\<le>|h'; h a = Some (C,fs) |] ==> \<exists>fs'. h' a = Some (C,fs')"
apply (unfold hext_def)
apply (force)
done

lemma hext_refl [simp]: "h\<le>|h"
apply (rule hextI)
apply (fast)
done

lemma hext_new [simp]: "h a = None ==> h\<le>|h(a\<mapsto>x)"
apply (rule hextI)
apply auto
done

lemma hext_trans: "[|h\<le>|h'; h'\<le>|h''|] ==> h\<le>|h''"
apply (rule hextI)
apply (fast dest: hext_objD)
done

lemma hext_upd_obj: "h a = Some (C,fs) ==> h\<le>|h(a\<mapsto>(C,fs'))"
apply (rule hextI)
apply auto
done

subsection "conf"

lemma conf_Null [simp]: "G,h\<turnstile>Null::\<preceq>T = G\<turnstile>RefT NullT\<preceq>T"
apply (unfold conf_def)
apply (simp (no_asm))
done

lemma conf_litval [rule_format (no_asm), simp]:
  "typeof (\<lambda>v. None) v = Some T --> G,h\<turnstile>v::\<preceq>T"
apply (unfold conf_def)
apply (rule val.induct)
apply auto
done

lemma conf_AddrI: "[|h a = Some obj; G\<turnstile>obj_ty obj\<preceq>T|] ==> G,h\<turnstile>Addr a::\<preceq>T"
apply (unfold conf_def)
apply (simp)
done

lemma conf_obj_AddrI: "[|h a = Some (C,fs); G\<turnstile>C\<preceq>C D|] ==> G,h\<turnstile>Addr a::\<preceq> Class D"
apply (unfold conf_def)
apply (simp)
done

lemma defval_conf [rule_format (no_asm)]:
  "is_type G T --> G,h\<turnstile>default_val T::\<preceq>T"
apply (unfold conf_def)
apply (rule_tac y = "T" in ty.exhaust)
apply  (erule ssubst)
apply  (rename_tac prim_ty, rule_tac y = "prim_ty" in prim_ty.exhaust)
apply    (auto simp add: widen.null)
done

lemma conf_upd_obj:
"h a = Some (C,fs) ==> (G,h(a\<mapsto>(C,fs'))\<turnstile>x::\<preceq>T) = (G,h\<turnstile>x::\<preceq>T)"
apply (unfold conf_def)
apply (rule val.induct)
apply auto
done

lemma conf_widen [rule_format (no_asm)]:
  "wf_prog wf_mb G ==> G,h\<turnstile>x::\<preceq>T --> G\<turnstile>T\<preceq>T' --> G,h\<turnstile>x::\<preceq>T'"
apply (unfold conf_def)
apply (rule val.induct)
apply (auto intro: widen_trans)
done

lemma conf_hext [rule_format (no_asm)]: "h\<le>|h' ==> G,h\<turnstile>v::\<preceq>T --> G,h'\<turnstile>v::\<preceq>T"
apply (unfold conf_def)
apply (rule val.induct)
apply (auto dest: hext_objD)
done

lemma new_locD: "[|h a = None; G,h\<turnstile>Addr t::\<preceq>T|] ==> t\<noteq>a"
apply (unfold conf_def)
apply auto
done

lemma conf_RefTD [rule_format]:
 "G,h\<turnstile>a'::\<preceq>RefT T \<Longrightarrow> a' = Null \<or>
  (\<exists>a obj T'. a' = Addr a \<and>  h a = Some obj \<and>  obj_ty obj = T' \<and>  G\<turnstile>T'\<preceq>RefT T)"
unfolding conf_def by (induct a') auto

lemma conf_NullTD: "G,h\<turnstile>a'::\<preceq>RefT NullT ==> a' = Null"
apply (drule conf_RefTD)
apply auto
done

lemma non_npD: "[|a' \<noteq> Null; G,h\<turnstile>a'::\<preceq>RefT t|] ==>
  \<exists>a C fs. a' = Addr a \<and>  h a = Some (C,fs) \<and>  G\<turnstile>Class C\<preceq>RefT t"
apply (drule conf_RefTD)
apply auto
done

lemma non_np_objD: "!!G. [|a' \<noteq> Null; G,h\<turnstile>a'::\<preceq> Class C|] ==>
  (\<exists>a C' fs. a' = Addr a \<and>  h a = Some (C',fs) \<and>  G\<turnstile>C'\<preceq>C C)"
apply (fast dest: non_npD)
done

lemma non_np_objD' [rule_format (no_asm)]:
  "a' \<noteq> Null ==> wf_prog wf_mb G ==> G,h\<turnstile>a'::\<preceq>RefT t -->
  (\<exists>a C fs. a' = Addr a \<and>  h a = Some (C,fs) \<and>  G\<turnstile>Class C\<preceq>RefT t)"
apply(rule_tac y = "t" in ref_ty.exhaust)
 apply (fast dest: conf_NullTD)
apply (fast dest: non_np_objD)
done

lemma conf_list_gext_widen [rule_format (no_asm)]:
  "wf_prog wf_mb G ==> \<forall>Ts Ts'. list_all2 (conf G h) vs Ts -->
  list_all2 (\<lambda>T T'. G\<turnstile>T\<preceq>T') Ts Ts' -->  list_all2 (conf G h) vs Ts'"
apply(induct_tac "vs")
 apply(clarsimp)
apply(clarsimp)
apply(frule list_all2_lengthD [symmetric])
apply(simp (no_asm_use) add: length_Suc_conv)
apply(safe)
apply(frule list_all2_lengthD [symmetric])
apply(simp (no_asm_use) add: length_Suc_conv)
apply(clarify)
apply(fast elim: conf_widen)
done

subsection "lconf"

lemma lconfD: "[| G,h\<turnstile>vs[::\<preceq>]Ts; Ts n = Some T |] ==> G,h\<turnstile>(the (vs n))::\<preceq>T"
apply (unfold lconf_def)
apply (force)
done

lemma lconf_hext [elim]: "[| G,h\<turnstile>l[::\<preceq>]L; h\<le>|h' |] ==> G,h'\<turnstile>l[::\<preceq>]L"
apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done

lemma lconf_upd: "!!X. [| G,h\<turnstile>l[::\<preceq>]lT;
  G,h\<turnstile>v::\<preceq>T; lT va = Some T |] ==> G,h\<turnstile>l(va\<mapsto>v)[::\<preceq>]lT"
apply (unfold lconf_def)
apply auto
done

lemma lconf_init_vars_lemma [rule_format (no_asm)]:
  "\<forall>x. P x --> R (dv x) x ==> (\<forall>x. map_of fs f = Some x --> P x) -->
  (\<forall>T. map_of fs f = Some T -->
  (\<exists>v. map_of (map (\<lambda>(f,ft). (f, dv ft)) fs) f = Some v \<and>  R v T))"
apply( induct_tac "fs")
apply auto
done

lemma lconf_init_vars [intro!]:
"\<forall>n. \<forall>T. map_of fs n = Some T --> is_type G T ==> G,h\<turnstile>init_vars fs[::\<preceq>]map_of fs"
apply (unfold lconf_def init_vars_def)
apply auto
apply( rule lconf_init_vars_lemma)
apply(   erule_tac [3] asm_rl)
apply(  intro strip)
apply(  erule defval_conf)
apply auto
done

lemma lconf_ext: "[|G,s\<turnstile>l[::\<preceq>]L; G,s\<turnstile>v::\<preceq>T|] ==> G,s\<turnstile>l(vn\<mapsto>v)[::\<preceq>]L(vn\<mapsto>T)"
apply (unfold lconf_def)
apply auto
done

lemma lconf_ext_list [rule_format (no_asm)]:
  "G,h\<turnstile>l[::\<preceq>]L ==> \<forall>vs Ts. distinct vns --> length Ts = length vns -->
  list_all2 (\<lambda>v T. G,h\<turnstile>v::\<preceq>T) vs Ts --> G,h\<turnstile>l(vns[\<mapsto>]vs)[::\<preceq>]L(vns[\<mapsto>]Ts)"
apply (unfold lconf_def)
apply( induct_tac "vns")
apply(  clarsimp)
apply( clarsimp)
apply( frule list_all2_lengthD)
apply( auto simp add: length_Suc_conv)
done

lemma lconf_restr: "\<lbrakk>lT vn = None; G, h \<turnstile> l [::\<preceq>] lT(vn\<mapsto>T)\<rbrakk> \<Longrightarrow> G, h \<turnstile> l [::\<preceq>] lT"
apply (unfold lconf_def)
apply (intro strip)
apply (case_tac "n = vn")
apply auto
done

subsection "oconf"

lemma oconf_hext: "G,h\<turnstile>obj\<surd> ==> h\<le>|h' ==> G,h'\<turnstile>obj\<surd>"
apply (unfold oconf_def)
apply (fast)
done

lemma oconf_obj: "G,h\<turnstile>(C,fs)\<surd> =
  (\<forall>T f. map_of(fields (G,C)) f = Some T --> (\<exists>v. fs f = Some v \<and>  G,h\<turnstile>v::\<preceq>T))"
apply (unfold oconf_def lconf_def)
apply auto
done

lemmas oconf_objD = oconf_obj [THEN iffD1, THEN spec, THEN spec, THEN mp]

subsection "hconf"

lemma hconfD: "[|G\<turnstile>h h\<surd>; h a = Some obj|] ==> G,h\<turnstile>obj\<surd>"
apply (unfold hconf_def)
apply (fast)
done

lemma hconfI: "\<forall>a obj. h a=Some obj --> G,h\<turnstile>obj\<surd> ==> G\<turnstile>h h\<surd>"
apply (unfold hconf_def)
apply (fast)
done

subsection "xconf"

lemma xconf_raise_if: "xconf h x \<Longrightarrow> xconf h (raise_if b xcn x)"
by (simp add: xconf_def raise_if_def)

subsection "conforms"

lemma conforms_heapD: "(x, (h, l))::\<preceq>(G, lT) ==> G\<turnstile>h h\<surd>"
apply (unfold conforms_def)
apply (simp)
done

lemma conforms_localD: "(x, (h, l))::\<preceq>(G, lT) ==> G,h\<turnstile>l[::\<preceq>]lT"
apply (unfold conforms_def)
apply (simp)
done

lemma conforms_xcptD: "(x, (h, l))::\<preceq>(G, lT) ==> xconf h x"
apply (unfold conforms_def)
apply (simp)
done

lemma conformsI: "[|G\<turnstile>h h\<surd>; G,h\<turnstile>l[::\<preceq>]lT; xconf h x|] ==> (x, (h, l))::\<preceq>(G, lT)"
apply (unfold conforms_def)
apply auto
done

lemma conforms_restr: "\<lbrakk>lT vn = None; s ::\<preceq> (G, lT(vn\<mapsto>T)) \<rbrakk> \<Longrightarrow> s ::\<preceq> (G, lT)"
by (simp add: conforms_def, fast intro: lconf_restr)

lemma conforms_xcpt_change: "\<lbrakk> (x, (h,l))::\<preceq> (G, lT); xconf h x \<longrightarrow> xconf h x' \<rbrakk> \<Longrightarrow> (x', (h,l))::\<preceq> (G, lT)"
by (simp add: conforms_def)

lemma preallocated_hext: "\<lbrakk> preallocated h; h\<le>|h'\<rbrakk> \<Longrightarrow> preallocated h'"
by (simp add: preallocated_def hext_def)

lemma xconf_hext: "\<lbrakk> xconf h vo; h\<le>|h'\<rbrakk> \<Longrightarrow> xconf h' vo"
by (simp add: xconf_def preallocated_def hext_def)

lemma conforms_hext: "[|(x,(h,l))::\<preceq>(G,lT); h\<le>|h'; G\<turnstile>h h'\<surd> |]
  ==> (x,(h',l))::\<preceq>(G,lT)"
by (fast dest: conforms_localD conforms_xcptD elim!: conformsI xconf_hext)

lemma conforms_upd_obj:
  "[|(x,(h,l))::\<preceq>(G, lT); G,h(a\<mapsto>obj)\<turnstile>obj\<surd>; h\<le>|h(a\<mapsto>obj)|]
  ==> (x,(h(a\<mapsto>obj),l))::\<preceq>(G, lT)"
apply(rule conforms_hext)
apply  auto
apply(rule hconfI)
apply(drule conforms_heapD)
apply(auto elim: oconf_hext dest: hconfD)
done

lemma conforms_upd_local:
"[|(x,(h, l))::\<preceq>(G, lT); G,h\<turnstile>v::\<preceq>T; lT va = Some T|]
  ==> (x,(h, l(va\<mapsto>v)))::\<preceq>(G, lT)"
apply (unfold conforms_def)
apply( auto elim: lconf_upd)
done

end


(*

Copyright (c) 2017, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*<*)
theory Syntax
  imports Equivalence Resolution Model
begin
(*>*)

subsection {* Abstract Syntax for Nets *}
text_raw {* \label{sec:isasyntax} *}

text {* This is the abstract syntax, corresponding to the concrete sytax
        introduced in \autoref{sec:model}.  We do not yet have a parser, and
        thus models are constructed by hand. *}

text {* A contiguous block of addresses, expressed as a base-limit pair: *}

record block_spec =
  base    :: genaddr
  limit   :: genaddr
  require :: "property list"
  reject  :: "property list"

definition block :: "genaddr \<Rightarrow> genaddr \<Rightarrow> property list \<Rightarrow> property list \<Rightarrow> block_spec"
  where "block b l r f  = \<lparr> base = b, limit = l, require = r, reject = f \<rparr>"

definition blockn :: "genaddr \<Rightarrow> genaddr \<Rightarrow> block_spec"
  where "blockn b l  = \<lparr> base = b, limit = l, require = [], reject = [] \<rparr>"

text {* For each syntax item (nonterminal), we have a translation function into
        the abstract semantic model.  Together these define the parse() function
        of \autoref{sec:reductions}. *}

text {* An address contains a set of properties. When specifying a set of addresses
        that are translated or accepted we use the notion of required and rejected properties.
        An address that is element of the accept or translate set must fulfill the following
        predicate. *}

definition prop_pred :: "property set \<Rightarrow> property set \<Rightarrow> property set \<Rightarrow> bool"
  where "prop_pred incl excl props =  (excl \<inter> props = {}  \<and> incl \<subseteq> props)"

text {* When creating the block from it's spec we include a set of net properties which are the
        properties mentioned in the decoding net and therefore the properties we care about. *}

definition mk_block :: "property set \<Rightarrow> block_spec \<Rightarrow> addr set"
  where "mk_block netpropss s = {(a, p) | a p. (base s) \<le> a \<and> a \<le> (limit s)
                                   \<and> prop_pred (set (require s)) (set (reject s)) p
                                   \<and> p \<subseteq> netpropss }"

text {* We obtain the relevant properties of a block by the union of the reject and require lists *}

primrec mk_block_propset :: "block_spec list \<Rightarrow> property set"
  where "mk_block_propset [] = {}" |
        "mk_block_propset (m#mm) = (mk_block_propset mm) \<union> set (require m) \<union> set (reject m)"

text {* A single block mapping that maps the specified source block to the given
        destination node, beginning at the given base address and adds or strips some
        properties. *}

record map_spec =
  src_block :: block_spec
  dest_node :: nodeid
  dest_base :: genaddr
  propadd   :: "property list"
  propstrip :: "property list"

text {* Map a block without changing its base address: *}

definition block_map :: "block_spec \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> map_spec"
  where "block_map blk nd ba = \<lparr> src_block = blk, dest_node = nd, dest_base = ba,
                                 propadd = [], propstrip = [] \<rparr>"

definition block_map_p :: "block_spec \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> property list
                                        \<Rightarrow> property list \<Rightarrow> map_spec"
  where "block_map_p blk nd ba pa ps  = \<lparr> src_block = blk, dest_node = nd,
                                          dest_base = ba, propadd = pa,
                                          propstrip = ps \<rparr>"

definition direct_map :: "block_spec \<Rightarrow> nodeid \<Rightarrow> map_spec"
  where "direct_map blk nd = \<lparr> src_block = blk, dest_node = nd,
                              dest_base = (base blk),
                              propadd = [], propstrip = [] \<rparr>"

definition direct_map_p :: "block_spec \<Rightarrow> nodeid \<Rightarrow> property list
                                       \<Rightarrow> property list \<Rightarrow> map_spec"
  where "direct_map_p blk nd pa ps = \<lparr> src_block = blk, dest_node = nd,
                                      dest_base = (base blk),
                                      propadd =  pa, propstrip =  ps \<rparr>"

definition one_map :: "addr \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> map_spec"
  where "one_map src nd ba =  \<lparr> src_block = \<lparr> base = (fst src), limit = (fst src),
                                             require = [], reject = [] \<rparr>,
                               dest_node = nd, dest_base = ba,
                               propadd =[],propstrip = [] \<rparr>"

definition one_map_p :: "addr \<Rightarrow> nodeid \<Rightarrow> genaddr \<Rightarrow> property list
                              \<Rightarrow> property list \<Rightarrow> map_spec"
  where "one_map_p src nd ba pa ps =  \<lparr> src_block = \<lparr> base = (fst src),
                                                     limit = (fst src),
                                                     require = [],
                                                     reject = [] \<rparr>,
                                       dest_node = nd, dest_base = ba,
                                       propadd =  pa,propstrip =  ps \<rparr>"

definition mk_map :: "property set \<Rightarrow> map_spec \<Rightarrow> addr \<Rightarrow> name set"
  where "mk_map ps s =
    (\<lambda>a. if a \<in> mk_block ps (src_block s)
      then {
        (dest_node s, (dest_base s + (fst a - base (src_block s))),
                         (snd a) \<union> (set (propadd s)) - (set (propstrip s))) }
      else {})"

text {* we can obtain the relevant properties of the map by the union of the propadd, propetrip
        and source block properties *}

primrec mk_map_propset :: "map_spec list \<Rightarrow> property set"
  where "mk_map_propset [] = {}" |
        "mk_map_propset (m#mm) = (mk_map_propset mm) \<union> set (propadd m)
                                      \<union> set (propstrip m) \<union> mk_block_propset [src_block m]"

text {* A finitely-specified decoding node, with a list of blocks to accept
        locally, and a list of those to translate: *}

record node_spec =
  acc_blocks :: "block_spec list"
  map_blocks :: "map_spec list"
  overlay    :: "nodeid option"

definition empty_spec :: "node_spec"
  where "empty_spec = \<lparr> acc_blocks = [], map_blocks = [], overlay = None \<rparr>"

(*<*)
lemma acc_blocks_empty:
  "acc_blocks empty_spec = []"
  by(simp add:empty_spec_def)
(*>*)

text {* If an overlay node is specified, initialise the map by forwarding all
        addresses to that  node: *}

definition mk_overlay :: "nodeid option \<Rightarrow> node"
  where "mk_overlay ov = \<lparr>
          accept = {},
          translate = (case ov of None \<Rightarrow> \<lambda>_. {} | Some n \<Rightarrow> (\<lambda>a. {(n,a)})) \<rparr>"

(*<*)
lemma accept_mk_overlay:
  "accept (mk_overlay ov) = {}"
  by(simp add:mk_overlay_def)
(*>*)

primrec add_blocks :: "property set \<Rightarrow> block_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_blocks ps [] node = node" |
        "add_blocks ps (s#ss) node = accept_update (op \<union> (mk_block ps s))
                                                   (add_blocks ps ss node)"

(*<*)
lemma translate_add_blocks:
  "translate (add_blocks ps bs node) = translate node"
  by(induct bs, simp_all)

lemma add_blocks_overlay:
  "accept (add_blocks ps bs (mk_overlay ov)) =
   accept (add_blocks ps bs empty_node)"
  by(induct bs, simp_all add:empty_node_def accept_mk_overlay)
(*>*)

definition add_maps :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_maps ps ss node = translate_update
                                   (\<lambda>t a. \<Union>{mk_map ps s a |s. s\<in>(set ss) } \<union> t a)
                                    node"

primrec add_maps_rec :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "add_maps_rec ps [] node = node" |
        "add_maps_rec ps (s#ss) node = translate_update
                                          (\<lambda>t a. mk_map ps s a \<union> t a)
                                          (add_maps_rec ps ss node)"

definition remove_maps :: "property set \<Rightarrow> map_spec list \<Rightarrow> node \<Rightarrow> node"
  where "remove_maps ps ss node = translate_update
                                   (\<lambda>t a. t a - \<Union>{mk_map ps s a |s. s\<in>(set ss) })
                                    node"

lemma remove_maps_set_diff:
  "A - \<Union>{mk_map ps s a |s. s \<in> set ms \<or> s \<in> set ns}
    = A - \<Union>{mk_map ps s a |s. s \<in> set ns} - \<Union>{mk_map ps s a |s. s \<in> set ms}"
  by(auto)

lemma remove_maps_append :
  "remove_maps ps (ms @ ns) node = remove_maps ps ms (remove_maps ps ns node)"
  by(auto simp add:remove_maps_def o_def remove_maps_set_diff)

definition add_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "add_one_map ps m n = translate_update (\<lambda>t a. mk_map ps m a \<union> t a) n"

definition remove_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "remove_one_map ps m n = n \<lparr> translate := (\<lambda>a. translate n a - mk_map ps m a) \<rparr>"

definition update_one_map :: "property set \<Rightarrow> map_spec \<Rightarrow> map_spec \<Rightarrow> node \<Rightarrow> node"
  where "update_one_map ps m m' n = add_one_map ps m' (remove_one_map ps m n)"

lemma update_commute:
  assumes m_distinct: "\<And>a. translate node a \<inter> mk_map ps m a = {}"
      and n_contained: "\<And>a. mk_map ps n a \<subseteq> translate node a"
  shows "update_one_map ps m n (update_one_map ps n m node) = node"
proof -
  have "\<And>a. translate node a - mk_map ps n a \<subseteq> translate node a" by(auto)
  hence "\<And>a. (translate node a - mk_map ps n a) \<inter> mk_map ps m a
                    \<subseteq> translate node a \<inter> mk_map ps m a"
    by(auto)
  also note m_distinct
  finally have "\<And>a.(translate node a - mk_map ps n a) \<inter> mk_map ps m a = {}" by(auto)
  with m_distinct
  have "\<And>a. translate node a - mk_map ps n a - mk_map ps m a =
             translate node a - mk_map ps n a"
    by(simp add:Diff_triv)
  with n_contained show ?thesis
    by(simp add:update_one_map_def add_one_map_def remove_one_map_def o_def
                Un_Diff Un_absorb1)
qed

lemma mk_map_set_append :
  "mk_map ps a aa \<union> \<Union>{mk_map ps s aa |s. s \<in> set ss}
     = \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)}"
  by(auto)

lemma mk_map_set_commute :
  "mk_map ps a aa \<union> (\<Union>{mk_map ps s aa |s. s \<in> set ss}\<union> t aa)
     = \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa"
  by(auto)

lemma translate_update_append:
  "translate_update (\<lambda>t aa. \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa) node =
  translate_update (\<lambda>t aa. mk_map ps a aa \<union> (\<Union>{mk_map ps s aa |s. s \<in> set (ss)}) \<union> t aa) node"
  by(simp add:mk_map_set_append)

lemma translate_update_commute:
  "translate_update (\<lambda>t aa. \<Union>{mk_map ps s aa |s. s \<in> set (a # ss)} \<union> t aa) node =
  translate_update (\<lambda>t aa. mk_map ps a aa \<union> ((\<Union>{mk_map ps s aa |s. s \<in> set (ss)}) \<union> t aa)) node"
  by(subst mk_map_set_commute, auto)

lemma add_maps_recursive:
  "add_maps_rec ps ss node = add_maps ps ss node"
  apply(induct ss)
  apply(simp_all add:add_maps_def add_maps_rec_def o_def)
  apply(simp add:translate_update_commute[symmetric])
  done

(*<*)
lemma accept_add_maps:
  "accept (add_maps ps ms node) = accept node"
  by(simp add:add_maps_def)

lemma translate_update_chain :
  "translate_update (\<lambda>t a. A \<union> t a) (translate_update (\<lambda>t a. B \<union> t a) node) =
   translate_update (\<lambda>t a. A \<union> B \<union> t a) node"
  by(simp add:o_def Un_assoc)

lemma add_maps_set_union:
     "\<Union>{mk_map ps s a |s. s \<in> set ms \<or> s \<in> set ns} =
      \<Union>{mk_map ps s a |s. s \<in> set ms} \<union> \<Union>{mk_map ps s a |s. s \<in> set ns}"
  by(auto)

lemma add_maps_set_append :
      "\<Union>{mk_map ps s a |s. s \<in> set (ms @ ns)} =
       \<Union>{mk_map ps s a |s. s \<in> set ms} \<union> \<Union>{mk_map ps s a |s. s \<in> set ns}"
  by(auto)

lemma add_maps_append_direct:
   "add_maps ps ms (add_maps ps ns node) =
    translate_update (\<lambda>t a. \<Union>{mk_map ps s a |s. s\<in>(set (ms @ ns)) } \<union> t a) node"
  by(simp add:add_maps_def o_def Un_assoc[symmetric] add_maps_set_union)

lemma add_maps_append:
  "add_maps ps (ms @ ns) node = add_maps ps ms (add_maps ps ns node)"
  by(simp add:add_maps_def o_def  Un_assoc[symmetric] add_maps_set_union)

lemma add_maps_append2 :
  "add_maps ps (a' @ b' @ c' @ d') node = add_maps ps (a' @ b') (add_maps  ps(c' @ d') node)"
  by(simp add:add_maps_append)

lemma set_commute: "set [a, b] = set [b, a]"
  by(auto)

lemma add_maps_list_commute :
  shows   "add_maps ps [a, b] node = add_maps ps [b, a] node"
  by(simp only:add_maps_def set_commute)

lemma add_maps_commute:
  "add_maps ps (a @ b) node = add_maps ps (b @ a) node"
  by(simp only:add_maps_def add_maps_set_append Un_commute)

lemma add_maps_commute3:
  "add_maps ps (a @ b @ c) node = add_maps ps (b @ a @ c) node"
  apply(simp only:add_maps_def add_maps_set_append)
  apply(simp only:Un_assoc[symmetric])
  apply(simp only: Un_commute)
  done

lemma add_maps_append_commute:
   "add_maps ps a (add_maps ps b node) = add_maps ps b (add_maps ps a node)"
  by(simp add:add_maps_append[symmetric] add_maps_commute)

(*>*)

definition mk_node :: "property set \<Rightarrow> node_spec \<Rightarrow> node"
  where "mk_node ps s = add_maps ps (map_blocks s)
                         (add_blocks ps (acc_blocks s)
                         (mk_overlay (overlay s)))"

text {* the set of used properties in the node is the union of the accept list and
        translate list properties*}

definition mk_node_propset :: "node_spec \<Rightarrow> property set"
  where "mk_node_propset n = mk_map_propset (map_blocks n) \<union> mk_block_propset (acc_blocks n)"

(*<*)
lemma accept_mk_node:
  "accept (mk_node ps s) = accept (add_blocks ps (acc_blocks s) empty_node)"
  by(simp add:mk_node_def accept_add_maps add_blocks_overlay)

lemma maps_blocks_comm:
  "add_maps ps ms (add_blocks ps bs node) = add_blocks ps bs (add_maps ps ms node)"
proof(simp only: add_maps_recursive[symmetric], induct ms, simp_all)
  fix m ms
  assume IH: "add_maps_rec ps ms (add_blocks ps bs node)
                  = add_blocks ps bs (add_maps_rec ps ms node)"

  have tu_au_comm:
    "\<And>f g node. translate_update f (accept_update g node) =
                accept_update g (translate_update f node)"
    by(simp)

  show "translate_update (\<lambda>t a. mk_map ps m a \<union> t a)
                         (add_blocks ps bs (add_maps_rec ps ms node)) =
        add_blocks ps bs (translate_update (\<lambda>t a. mk_map ps m a \<union> t a)
                                        (add_maps_rec ps ms node))"
    by(induct bs, simp_all add:tu_au_comm)
qed

lemma translate_mk_node:
  "translate (mk_node ps s) = translate (add_maps ps (map_blocks s)
                                     (mk_overlay (overlay s)))"
  by(simp add:mk_node_def maps_blocks_comm translate_add_blocks)
(*>*)

type_synonym net_spec = "(nodeid \<times> node_spec) list"

definition "empty_net = (\<lambda>_. empty_node)"

primrec repeat_node :: "node_spec \<Rightarrow> nodeid \<Rightarrow> nat \<Rightarrow> net_spec"
  where "repeat_node node ba 0 = []" |
        "repeat_node node ba (Suc n) = (ba, node) # repeat_node node (Suc ba) n"

text {* we can obtain the relevant properties of the net by the union of all the nodes *}

primrec mk_net_propset :: "net_spec \<Rightarrow> property set"
  where "mk_net_propset [] = {}" |
        "mk_net_propset (s#ss) = (mk_net_propset ss) \<union> (mk_node_propset (snd s))"

(*
primrec mk_net_step :: "property set \<Rightarrow> net_spec \<Rightarrow> net"
  where "mk_net_step ps [] = empty_net" |
        "mk_net_step ps (s#ss) = (mk_net_step ps ss)(fst s := mk_node ps (snd s))"

definition mk_net :: "net_spec \<Rightarrow> net"
  where "mk_net ns = mk_net_step {0..<4} ns"
*)

primrec mk_net :: "net_spec \<Rightarrow> net"
  where "mk_net [] = empty_net" |
        "mk_net (s#ss) = (mk_net ss)(fst s := mk_node ALLPROPERTIES (snd s))"

(*<*)
lemma map_blocks_empty_spec:
  "map_blocks empty_spec = []"
  by(simp add:mk_overlay_def empty_spec_def)

lemma mk_net_empty:
  "mk_net [] nd = empty_node"
  by(simp add:mk_net_def empty_net_def)

subsubsection {* Finitness of property sets *}

text {* we show that the property sets we obtain from the syntax are finite *}

lemma mk_block_propset_finite :
"finite (mk_block_propset m)"
  apply(induct m)
  apply(simp_all add:mk_block_propset_def)
  done

lemma mk_map_propset_finite:
"finite (mk_map_propset m)"
  apply(induct m)
  apply(simp_all add:mk_map_propset_def)
  done

lemma mk_node_propset_finite:
"finite (mk_node_propset n)"
  by(simp add:mk_node_propset_def mk_map_propset_finite mk_block_propset_finite)

lemma mk_net_propset_finite:
"finite (mk_net_propset n)"
  apply(induct n)
  apply(simp_all add:mk_node_propset_finite mk_net_propset_def)
  done

subsubsection {* Correctness by Construction *}

definition wf_node :: "node \<Rightarrow> bool"
  where "wf_node node \<longleftrightarrow> finite (accept node) \<and> (\<forall>a. finite (translate node a))"

lemma wf_nodeI:
  "finite (accept node) \<Longrightarrow> (\<And>a. finite (translate node a)) \<Longrightarrow> wf_node node"
  by(simp add:wf_node_def)

lemma wf_node_wf_net:
  "(\<And>nd. wf_node (net nd)) \<Longrightarrow> wf_net net"
  unfolding wf_node_def wf_net_def
  by(auto simp:Image_def decodes_to_def decode_step_def)

lemma wf_empty_node:
  "wf_node empty_node"
  unfolding empty_node_def by(auto intro:wf_nodeI)

lemma wf_overlay:
  "wf_node (mk_overlay s)"
  unfolding mk_overlay_def by(cases s, simp_all add:wf_node_def)

lemma mk_block_finite:
  assumes psfini: "finite ps"
  shows "finite (mk_block ps s)"
proof -
  have sep: "{(a, p) | a p. (base s) \<le> a \<and> a \<le> (limit s)
               \<and> prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps } = {a.(base s) \<le> a \<and> a \<le> (limit s) } \<times>
                  {p. prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps}"
    by(auto)
  have fina: "finite {a.(base s) \<le> a \<and> a \<le> (limit s) }"
    by(auto)
  from psfini have finb: "finite {p. prop_pred (set (require s)) (set (reject s)) p
               \<and> p \<subseteq> ps}"
    by(auto)

  from finb fina sep show ?thesis
    by(auto simp: mk_block_def )
qed

lemma wf_add_blocks:
  assumes wf_base: "wf_node node"
      and psfini: "finite ps"
  shows "wf_node (add_blocks ps ss node)"
proof(induct ss, simp_all add:wf_base)
  fix s ss
  assume IH: "wf_node (add_blocks ps ss node)"
  hence "finite (accept (add_blocks ps ss node))" "\<And>s. finite (translate (add_blocks ps ss node) s)"
    by(auto simp:wf_node_def)
  moreover from psfini have "finite (mk_block ps s)"
    by(simp add: mk_block_finite)
  ultimately show "wf_node (accept_update (op \<union> (mk_block ps s)) (add_blocks ps ss node))"
    by(auto intro:wf_nodeI)
qed

lemma wf_add_maps:
  assumes wf_base: "wf_node node"
      and psfini: "finite ps"
  shows "wf_node (add_maps ps ss node)"
proof(simp only: add_maps_recursive[symmetric],induct ss, simp_all add:wf_base)
  fix s ss
  assume IH: "wf_node (add_maps_rec ps ss node)"
  hence "finite (accept (add_maps_rec ps ss node))" "\<And>a. finite (translate (add_maps_rec ps ss node) a)"
    by(auto simp:wf_node_def)
  moreover have "\<And>a. finite (mk_map ps s a)"
    unfolding mk_map_def by(simp)
  ultimately show "wf_node (translate_update (\<lambda>t a. mk_map ps s a \<union> t a) (add_maps_rec ps ss node))"
    by(auto intro:wf_nodeI)
qed

lemma wf_mk_node:
  "finite ps \<Longrightarrow> wf_node (mk_node ps s)"
  unfolding mk_node_def by(auto intro:wf_add_maps wf_add_blocks wf_overlay)

lemma wf_empty_net:
  "wf_net empty_net"
  unfolding empty_net_def by(auto intro:wf_node_wf_net wf_empty_node)
(*>*)

text {* Nets built from abstract syntax are correct by construction: *}

(*
lemma wf_mk_net_step :
  assumes psfini: "finite ps"
  shows "wf_net (mk_net_step ps ss)"
proof (rule wf_node_wf_net, induct ss)
  case Nil
  then show ?case by(auto simp: wf_empty_net empty_net_def wf_empty_node)
next
  case (Cons a ss)
  then show ?case
    by(simp add:mk_net_step_def wf_mk_node psfini)
qed

lemma wf_mk_net:
  "wf_net (mk_net ss)"
  by(simp add:mk_net_def wf_mk_net_step mk_net_propset_finite)
*)

lemma wf_mk_net:
  "wf_net (mk_net ss)"
  by(rule wf_node_wf_net, induct ss, simp_all add:empty_net_def
          wf_empty_node wf_mk_node ALLPROPERTIES_def)

subsubsection {* Finding Fresh Nodes *}

text {* These functions are guaranteed to return a node that's unused in the supplied
  specification. *}
definition ff_overlay :: "nodeid option \<Rightarrow> nodeid"
  where "ff_overlay s = (case s of Some nd \<Rightarrow> Suc nd | None \<Rightarrow> 0)"

(*<*)
lemma ff_overlay_ub:
  assumes "(nd',a') \<in> translate (mk_overlay ov) a"
  shows "nd' < ff_overlay ov"
  using assms by(cases ov, simp_all add:mk_overlay_def ff_overlay_def)
(*>*)

primrec ff_map :: "map_spec list \<Rightarrow> nodeid"
  where "ff_map [] = 0" |
        "ff_map (s#ss) = max (Suc (dest_node s)) (ff_map ss)"

(*<*)
lemma ff_add_blocks_ub:
  assumes "\<And>nd' a' a. (nd',a') \<in> translate node a \<Longrightarrow> nd' < x"
      and "(nd',a') \<in> translate (add_blocks ps bs node) a"
    shows "nd' < x"
  using assms by(simp add:translate_add_blocks)

lemma ff_add_maps_ub:
  assumes ff_node: "\<And>nd' a' a. (nd',a') \<in> translate node a \<Longrightarrow> nd' < x"
      and nda': "(nd',a') \<in> translate (add_maps ps ms node) a"
    shows "nd' < max x (ff_map ms)"
  using nda'
proof(induct ms, simp add:ff_node add_maps_recursive[symmetric])
  fix m ms
  assume IH: "(nd', a') \<in> translate (add_maps ps ms node) a \<Longrightarrow> nd' < max x (ff_map ms)"
     and step: "(nd', a') \<in> translate (add_maps ps (m # ms) node) a"

  from step have "(nd',a') \<in> mk_map ps m a \<or> (nd',a') \<in> translate (add_maps ps ms node) a"
    by(simp add:add_maps_recursive[symmetric])
  thus "nd' < max x (ff_map (m # ms))"
  proof
    assume "(nd', a') \<in> mk_map ps m a"
    hence "nd' < Suc (dest_node m)"
      by(cases "a \<in> mk_block ps (src_block m)", simp_all add:mk_map_def)
    thus ?thesis by(simp)
  next
    assume "(nd', a') \<in> translate (add_maps ps ms node) a"
    thus ?thesis by(simp only:add_maps_recursive[symmetric], auto dest:IH)
  qed
qed
(*>*)

definition ff_node :: "node_spec \<Rightarrow> nodeid"
  where "ff_node s = max (ff_overlay (overlay s)) (ff_map (map_blocks s))"

(*<*)
lemma ff_node_ub:
  assumes step: "(nd',a') \<in> translate (mk_node ps s) a"
  shows "nd' < ff_node s"
  unfolding ff_node_def using ff_overlay_ub
  by(auto simp:translate_add_blocks intro:ff_add_maps_ub[OF _ step[unfolded mk_node_def]])
(*>*)

primrec ff_net :: "net_spec \<Rightarrow> nodeid"
  where "ff_net [] = 0" |
        "ff_net (s#ss) = Max {ff_node (snd s), ff_net ss, Suc (fst s)}"

(*<*)
lemma ff_net_empty:
  "ff_net s \<le> nd \<Longrightarrow> mk_net s nd = empty_node"
  by(induct s, simp_all add:empty_net_def mk_net_empty)

lemma decodes_to_empty_net:
  "decodes_to empty_net = {}"
  by(simp add:decodes_to_def decode_step_def empty_net_def empty_node_def)

lemma ff_net_ub:
    shows "(x,y) \<in> decodes_to (mk_net s) \<Longrightarrow> fst x < ff_net s"
proof(induct s, simp add:decodes_to_empty_net)
  fix s ss
  assume IH: "(x, y) \<in> decodes_to (mk_net ss) \<Longrightarrow> fst x < ff_net ss"
     and dec: "(x, y) \<in> decodes_to (mk_net (s # ss))"

  show "fst x < ff_net (s # ss)"
  proof(cases)
    assume "fst y = fst s"
    with  dec have "x \<in> translate (mk_node ALLPROPERTIES (snd s)) (snd y)"
      by(cases x, cases y, simp add:decodes_to_def decode_step_def ALLPROPERTIES_def)
    hence "fst x < ff_node (snd s)"
      by(cases x, auto intro:ff_node_ub)
    thus ?thesis by(simp)
  next
    assume "fst y \<noteq> fst s"
    with dec have "(x, y) \<in> decodes_to (mk_net ss)"
      by(cases y, simp add:decodes_to_def decode_step_def mk_net_def)
    with IH show ?thesis by(simp)
  qed
qed

lemma ff_net_fresh:
  assumes ff: "ff_net s \<le> nd"
  shows "fresh_node (mk_net s) nd"
  unfolding fresh_node_def
proof(intro conjI allI impI)
  fix a
  from ff have "mk_net s nd = empty_node" by(rule ff_net_empty)
  thus "accept (mk_net s nd) = {}" "translate (mk_net s nd) a = {}"
    by(simp_all add:empty_node_def)
next
  fix x y
  assume "(x, y) \<in> decodes_to (mk_net s)"
  hence "fst x < ff_net s"
    by(rule ff_net_ub)
  also note ff
  finally show "fst x \<noteq> nd" by(simp)
qed

lemma ff_net_idbound:
  "nd \<in> set (map fst s) \<Longrightarrow> nd < ff_net s"
proof(induct s, simp_all)
  fix s::"(nodeid \<times> node_spec)" and ss
  assume IH: "nd \<in> fst ` set ss \<Longrightarrow> nd < ff_net ss"
  assume "nd = fst s \<or> nd \<in> fst ` set ss"
  thus "nd < max (ff_node (snd s)) (max (ff_net ss) (Suc (fst s)))"
  proof
    assume "nd = fst s" thus ?thesis by(auto)
  next
    assume "nd \<in> fst ` set ss"
    with IH have "nd < ff_net ss" by(blast)
    thus ?thesis by(auto)
  qed
qed
(*>*)

(*<*)
end
(*>*)