(*<*)
theory BenOr_Proofs
imports Heard_Of.Reduction
  Two_Step_Observing "../HO_Transition_System" BenOr_Defs
begin
(*>*)

subsection \<open>Proofs\<close>

type_synonym ben_or_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

consts
  val0 :: val
  val1 :: val

text \<open>Ben-Or works only on binary values.\<close>
axiomatization where
  val_exhaust: "v = val0 \<or> v = val1"
  and val_diff: "val0 \<noteq> val1"

context mono_quorum
begin

definition BenOr_Alg :: "(process, val pstate, val msg)CHOAlgorithm" where
  "BenOr_Alg = CHOAlgorithm.truncate BenOr_M"

definition BenOr_TS ::
  "(round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process HO) \<Rightarrow> (round \<Rightarrow> process) \<Rightarrow> ben_or_TS_state TS"
where
  "BenOr_TS HOs SHOs crds = CHO_to_TS BenOr_Alg HOs SHOs (K o crds)"

lemmas BenOr_TS_defs = BenOr_TS_def CHO_to_TS_def BenOr_Alg_def CHOinitConfig_def
  BenOr_initState_def

type_synonym rHO = "nat \<Rightarrow> process HO"

definition BenOr_trans_step
  where
  "BenOr_trans_step HOs SHOs nxt_f snd_f stp \<equiv> \<Union>r \<mu>.
    {((r, cfg), (Suc r, cfg'))|cfg cfg'. two_step r = stp  \<and> (\<forall>p.
      \<mu> p \<in> get_msgs (snd_f r) cfg (HOs r) (SHOs r) p
      \<and> nxt_f r p (cfg p) (\<mu> p) (cfg' p)
    )}"

lemma two_step_less_D:
  "0 < two_step r \<Longrightarrow> two_step r = Suc 0"
  by(auto simp add: two_step_def)

lemma BenOr_trans:
  "CSHO_trans_alt BenOr_sendMsg (\<lambda>r p st msgs crd st'. BenOr_nextState r p st msgs st') HOs SHOs crds =
  BenOr_trans_step HOs SHOs next0 send0 0
  \<union> BenOr_trans_step HOs SHOs  next1 send1 1
  "
proof
  show "CSHO_trans_alt BenOr_sendMsg (\<lambda>r p st msgs crd. BenOr_nextState r p st msgs) HOs SHOs crds
    \<subseteq> BenOr_trans_step HOs SHOs next0 send0 0 \<union> BenOr_trans_step HOs SHOs next1 send1 1"
  by(force simp add: CSHO_trans_alt_def BenOr_sendMsg_def BenOr_nextState_def BenOr_trans_step_def
    K_def dest!: two_step_less_D)
next
  show " BenOr_trans_step HOs SHOs next0 send0 0 \<union>
    BenOr_trans_step HOs SHOs next1 send1 1
    \<subseteq> CSHO_trans_alt BenOr_sendMsg
        (\<lambda>r p st msgs crd. BenOr_nextState r p st msgs) HOs SHOs crds"
  by(force simp add: CSHO_trans_alt_def BenOr_sendMsg_def BenOr_nextState_def BenOr_trans_step_def)
qed

definition "BenOr_A = CHOAlgorithm.truncate BenOr_M"

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

text \<open>Agreement for BenOr only holds if the communication predicates hold\<close>
context
  fixes
    HOs :: "nat \<Rightarrow> process \<Rightarrow> process set"
    and rho :: "nat \<Rightarrow> process \<Rightarrow> val pstate"
  assumes comm_global: "BenOr_commGlobal HOs"
  and per_rd: "\<forall>r. BenOr_commPerRd (HOs r)"
  and run: "HORun BenOr_A rho HOs"
begin
(******************************************************************************)

definition no_vote_diff where
  "no_vote_diff sc p \<equiv> vote (sc p) = None \<longrightarrow>
            (\<exists>q q'. x (sc q) \<noteq> x (sc q'))"

definition ref_rel :: "(tso_state \<times> ben_or_TS_state)set" where
  "ref_rel \<equiv> {(sa, (r, sc)).
    r = next_round sa
    \<and> (two_step r = 1 \<longrightarrow> r_votes sa = vote o sc)
    \<and> (two_step r = 1 \<longrightarrow> (\<forall>p. no_vote_diff sc p))
    \<and> (\<forall>p v. x (sc p) = v \<longrightarrow> (\<exists>q. last_obs sa q \<in> {None, Some v}))
    \<and> decisions sa = decide o sc
  }"

lemma HOs_intersect:
  "HOs r p \<inter> HOs r' q \<noteq> {}" using per_rd
  apply(simp add: BenOr_commPerRd_def)
  apply(blast dest: qintersect)
  done

lemma HOs_nonempty:
  "HOs r p \<noteq> {}"
  using HOs_intersect
  by blast

lemma vote_origin:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = 0"
  shows
    "vote (cfg' p) = Some v \<longleftrightarrow> (\<forall>q \<in> HOs r p. x (cfg q) = v)"
  using send[THEN spec, where x=p] step[THEN spec, where x=p] step_r HOs_nonempty
  by(auto simp add: next0_def get_msgs_benign send0_def msgRcvd_def o_def restrict_map_def)

lemma same_new_vote:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = 0"
  obtains v where "\<forall>p w. vote (cfg' p) = Some w \<longrightarrow> w = v"
proof(cases "\<exists>p v. vote (cfg' p) = Some v")
  case True
  assume asm: "\<And>v. \<forall>p w. vote (cfg' p) = Some w \<longrightarrow> w = v \<Longrightarrow> thesis"
  from True obtain p v where "vote (cfg' p) = Some v" by auto

  hence "\<forall>p w. vote (cfg' p) = Some w \<longrightarrow> w = v" (is "?LV(v)")
    using vote_origin[OF send step step_r] HOs_intersect
    by(force)

  from asm[OF this] show ?thesis .
qed(auto)

lemma no_x_change:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = 0"
  shows
    "x (cfg' p) = x (cfg p)"
  using send[THEN spec, where x=p] step[THEN spec, where x=p] step_r HOs_nonempty
  by(auto simp add: next0_def get_msgs_benign send0_def msgRcvd_def o_def restrict_map_def)

lemma no_vote:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = 0"
  shows
    "no_vote_diff cfg' p"
    unfolding no_vote_diff_def
proof
  assume
    "vote (cfg' p) = None"
  hence "(\<exists>q q'. x (cfg q) \<noteq> x (cfg q'))"
   using send[THEN spec, where x=p] step[THEN spec, where x=p] step_r HOs_nonempty
   apply(clarsimp simp add: next0_def get_msgs_benign send0_def msgRcvd_def o_def restrict_map_def)
   by metis
  thus "(\<exists>q q'. x (cfg' q) \<noteq> x (cfg' q'))"
    using no_x_change[OF send step step_r]
    by(simp)
qed

lemma step0_ref:
  "{ref_rel} \<Union>r S v. tso_round0 r S v,
    BenOr_trans_step HOs HOs next0 send0 0 {> ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs BenOr_trans_step_def all_conj_distrib)
  fix sa r cfg \<mu> cfg'
  assume
    R: "(sa, (r, cfg)) \<in> ref_rel"
    and step_r: "two_step r = 0"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) p"
    and step: "\<forall>p. next0 r p (cfg p) (\<mu> p) (cfg' p)"

  from R have next_r: "next_round sa = r"
    by(simp add: ref_rel_def)

  from HOs_nonempty send have "\<forall>p. \<exists>q. q \<in> msgRcvd (\<mu> p)"
    by(fastforce simp add: get_msgs_benign send0_def msgRcvd_def restrict_map_def)
  with step have same_dec: "decide o cfg' = decide o cfg"
    apply(simp add: next0_def o_def)
    by (metis pstate.select_convs(3) pstate.surjective pstate.update_convs(2))

  define S where "S = {p. \<exists>v. vote (cfg' p) = Some v}"
  from same_new_vote[OF send step step_r]
  obtain v where v: "\<forall>p \<in> S. vote (cfg' p) = Some v"
    by(simp add: S_def) (metis)
  hence vote_const_map: "vote o cfg' = const_map v S"
    by(auto simp add: S_def const_map_def restrict_map_def intro!: ext)

  define sa' where "sa' = sa\<lparr> next_round := Suc r, r_votes := const_map v S \<rparr>"

  have "\<forall>p. p \<in> S \<longrightarrow> opt_obs_safe (last_obs sa) v"
    using vote_origin[OF send step step_r] R per_rd[THEN spec, of r] v
    apply(clarsimp simp add: BenOr_commPerRd_def opt_obs_safe_def ref_rel_def)
    by metis

  hence "(sa, sa') \<in> tso_round0 r S v" using next_r step_r v R
    vote_origin[OF send step step_r]
    by(auto simp add: tso_round0_def sa'_def all_conj_distrib)

  moreover have "(sa', Suc r, cfg') \<in> ref_rel" using step send v R same_dec step_r next_r
    apply(auto simp add: ref_rel_def sa'_def  two_step_phase_Suc vote_const_map next0_def
      all_conj_distrib no_vote[OF send step step_r])
    by (metis pstate.select_convs(1) pstate.surjective pstate.update_convs(2))

  ultimately show
    "\<exists>sa'. (\<exists>r S v. (sa, sa') \<in> tso_round0 r S v) \<and> (sa', Suc r, cfg') \<in> ref_rel"
    by blast
qed

definition D where
  "D cfg cfg' \<equiv> {p. decide (cfg' p) \<noteq> decide (cfg p) }"

lemma decide_origin:
  assumes
  send: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) cfg (HOs r) (HOs r) p"
  and step: "\<forall>p. next1 r p (cfg p) (\<mu> p) (cfg' p)"
  and step_r: "two_step r = Suc 0"
  shows
    "D cfg cfg' \<subseteq> {p. \<exists>v. decide (cfg' p) = Some v \<and> (\<forall>q \<in> HOs r p. vote (cfg q) = Some v)}"
  using assms
  by(fastforce simp add: D_def next1_def get_msgs_benign send1_def msgRcvd_def o_def restrict_map_def
    x_update_def dec_update_def identicalVoteRcvd_def all_conj_distrib someVoteRcvd_def isVote_def)

lemma step1_ref:
  "{ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UNIV} \<Union>r d_f o_f. tso_round1 r d_f o_f,
    BenOr_trans_step HOs HOs next1 send1 (Suc 0) {> ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs BenOr_trans_step_def all_conj_distrib)
  fix sa r cfg \<mu> and cfg' :: "process \<Rightarrow> val pstate"
  assume
    R: "(sa, (r, cfg)) \<in> ref_rel"
    and step_r: "two_step r = Suc 0"
    and send: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) cfg (HOs r) (HOs r) p"
    and step: "\<forall>p. next1 r p (cfg p) (\<mu> p) (cfg' p)"
    and ainv: "sa \<in> TSO_inv1"
    and ainv2: "sa \<in> TSO_inv2"

  from R have next_r: "next_round sa = r"
    by(simp add: ref_rel_def)

  define S where "S = {p. \<exists>v. vote (cfg p) = Some v}"
  from R obtain v where v: "\<forall>p \<in> S. vote (cfg p) = Some v" using ainv step_r
    by(auto simp add: ref_rel_def TSO_inv1_def S_def)

  define Ob where "Ob = {p. x (cfg' p) = v}"
  define o_f where "o_f p = (if S \<in> Quorum then Some v else None)" for p :: process

  define dec_f where "dec_f p = (if p \<in> D cfg cfg' then decide (cfg' p) else None)" for p

  {
    fix p w
    assume "vote (cfg p) = Some w"
    hence "w = v" using v
      by(unfold S_def, auto)
  } note v'=this

  have d_guard: "d_guard dec_f (vote \<circ> cfg)" using per_rd[THEN spec, of r]
    by(fastforce simp add: d_guard_def locked_in_vf_def quorum_for_def dec_f_def
      BenOr_commPerRd_def dest!: decide_origin[OF send step step_r, THEN subsetD])

  have "dom (vote \<circ> cfg) \<in> Quorum \<longrightarrow> Ob = UNIV"
  proof(auto simp add: Ob_def)
    fix p
    assume Q: "dom (vote \<circ> cfg) \<in> Quorum" (is "?Q \<in> Quorum")
    hence "?Q \<inter> HOs r p \<noteq> {}"  using per_rd[THEN spec, of r]
      by(auto simp add: BenOr_commPerRd_def dest: qintersect)
    hence "someVoteRcvd (\<mu> p) \<noteq> {}" using send[THEN spec, of p]
      by(force simp add: someVoteRcvd_def get_msgs_benign msgRcvd_def restrict_map_def
        isVote_def send1_def)
    moreover have "\<forall>q \<in> someVoteRcvd (\<mu> p). \<exists>x'. \<mu> p q = Some (Vote (Some v))"
       using send[THEN spec, of p]
      by(auto simp add: someVoteRcvd_def get_msgs_benign msgRcvd_def restrict_map_def
        isVote_def send1_def dest: v')
    ultimately show "x (cfg' p) = v" using step[THEN spec, of p]
      by(auto simp add: next1_def x_update_def)
  qed
  note Ob_UNIV=this[rule_format]

  have obs_guard: "obs_guard o_f (vote \<circ> cfg)"
    apply(auto simp add: obs_guard_def o_f_def S_def dom_def
      dest: v' Ob_UNIV quorum_non_empty)
    apply (metis S_def all_not_in_conv  empty_not_quorum v)
    done

  define sa' where "sa' = sa\<lparr>
    next_round := Suc (next_round sa)
    , decisions := decisions sa ++ dec_f
    , last_obs := last_obs sa ++ o_f
    \<rparr>"

  \<comment> \<open>Abstract step\<close>
  have abs_step: "(sa, sa') \<in> tso_round1 r dec_f o_f"  using next_r step_r R d_guard obs_guard
    by(auto simp add: tso_round1_def sa'_def ref_rel_def)

  \<comment> \<open>Relation preserved\<close>
  have "\<forall>p. ((decide \<circ> cfg) ++ dec_f) p = decide (cfg' p)"
  proof
    fix p
    show "((decide \<circ> cfg) ++ dec_f) p = decide (cfg' p)" using step[THEN spec, of p]
      by(auto simp add: dec_f_def D_def next1_def dec_update_def map_add_def)
  qed
  note dec_rel=this[rule_format]

  have "\<forall>p. (\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (x (cfg' p)))"
  proof(intro allI impI, cases "S \<in> Quorum")
    fix p
    case True
    hence "x (cfg' p) = v" using Ob_UNIV
      by(auto simp add: S_def Ob_def dom_def)
    thus "(\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (x (cfg' p)))"
      using True
      by(auto simp add: o_f_def)
  next
    fix p
    case False
    hence empty: "o_f = Map.empty"
      by(auto simp add: o_f_def)
    from False have "S \<noteq> UNIV" using UNIV_quorum
      by auto
    then obtain q where q: "vote (cfg q) = None" using False
      by(auto simp add: o_f_def S_def)
    then obtain q1 q2 where
      "x (cfg q1) \<noteq> x (cfg q2)" using R step_r
      by(auto simp add: ref_rel_def no_vote_diff_def)
    then obtain q1' q2' where
      "x (cfg q1') = val0"
      "x (cfg q2') = val1"
      by (metis (poly_guards_query) val_exhaust)
    hence "\<forall>v. \<exists>q. opt_obsv_state.last_obs sa q \<in> {None, Some v}" using R step_r
      apply(auto simp add: ref_rel_def)
      by (metis (poly_guards_query) val_exhaust)
    (* note x = x_origin2[OF send step step_r refl, of p] *)
    thus "(\<exists>q. o_f q = None \<and> opt_obsv_state.last_obs sa q = None
        \<or> (opt_obsv_state.last_obs sa ++ o_f) q = Some (x (cfg' p)))" using empty
        by(auto)
  qed
  note obs_rel=this[rule_format]

  have post_rel:
    "(sa', Suc r, cfg') \<in> ref_rel" using step send next_r R step_r
    by(auto simp add: sa'_def ref_rel_def
      two_step_phase_Suc dec_rel obs_rel)

  from abs_step post_rel show
    "\<exists>sa'. (\<exists>r d_f o_f. (sa, sa') \<in> tso_round1 r d_f o_f) \<and> (sa', Suc r, cfg') \<in> ref_rel"
    by blast
qed

lemma BenOr_Refines_Two_Step_Obs:
  "PO_refines (ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UNIV)
    tso_TS (BenOr_TS HOs HOs crds)"
proof(rule refine_using_invariants)
  show "init (BenOr_TS HOs HOs crds) \<subseteq> ref_rel `` init tso_TS"
    by(auto simp add: BenOr_TS_defs BenOr_HOMachine_def CHOAlgorithm.truncate_def
      tso_TS_defs ref_rel_def tso_init_def Let_def o_def)
next
  show
    "{ref_rel \<inter> (TSO_inv1 \<inter> TSO_inv2) \<times> UNIV} TS.trans tso_TS,
      TS.trans (BenOr_TS HOs HOs crds) {> ref_rel}"
    apply(simp add: tso_TS_defs BenOr_TS_defs BenOr_HOMachine_def CHOAlgorithm.truncate_def)
    apply(auto simp add: CHO_trans_alt BenOr_trans intro!: step0_ref step1_ref)
    done
qed(auto intro!: TSO_inv1_inductive TSO_inv2_inductive)

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

text \<open>The full termination proof for Ben-Or is probabilistic, and depends on the state
of the processes, and a "favorable" coin toss, where "favorable" is relative to this state.
As this termination pre-condition is state-dependent, we cannot capture it in an HO
predicate.

Instead, we prove a variant of the argument, where we assume that there exists a
round where all the processes hear from the same set of other processes, and all toss the
same coin.
\<close>

  from r1 obtain r0 where r1_def: "r1 = Suc r0" and step_r0: "two_step r0 = 0"
    by (cases r1) (auto simp add: two_step_phase_Suc two_step_def mod_Suc)

  define cfg0 where "cfg0 = rho r0"
  define cfg1 where "cfg1 = rho r1"
  define r2 where "r2 = Suc r1"
  define cfg2 where "cfg2 = rho r2"
  define r3 where "r3 = Suc r2"
  define cfg3 where "cfg3 = rho r3"
  define cfg4 where "cfg4 = rho (Suc r3)"

  have step_r2: "two_step r2 = 0" using r1
    by(auto simp add: r2_def two_step_phase_Suc)

  from
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r0"]
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r1"]
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r2"]
    run[simplified HORun_def SHORun_def, THEN CSHORun_step, THEN spec, where x="r3"]
    obtain \<mu>0 \<mu>1 \<mu>2 \<mu>3 where
    send0: "\<forall>p. \<mu>0 p \<in> get_msgs (send0 r0) cfg0 (HOs r0) (HOs r0) p"
    and step0: "\<forall>p. next0 r0 p (cfg0 p) (\<mu>0 p) (cfg1 p)"
    and send1: "\<forall>p. \<mu>1 p \<in> get_msgs (send1 r1) cfg1 (HOs r1) (HOs r1) p"
    and step1: "\<forall>p. next1 r1 p (cfg1 p) (\<mu>1 p) (cfg2 p)"
    and send2: "\<forall>p. \<mu>2 p \<in> get_msgs (send0 r2) cfg2 (HOs r2) (HOs r2) p"
    and step2: "\<forall>p. next0 r2 p (cfg2 p) (\<mu>2 p) (cfg3 p)"
    and send3: "\<forall>p. \<mu>3 p \<in> get_msgs (send1 r3) cfg3 (HOs r3) (HOs r3) p"
    and step3: "\<forall>p. next1 r3 p (cfg3 p) (\<mu>3 p) (cfg4 p)"
    by(auto simp add: BenOr_A_def BenOr_HOMachine_def
      two_step_phase_Suc BenOr_nextState_def BenOr_sendMsg_def all_conj_distrib
      CHOAlgorithm.truncate_def step_r0 r1_def r2_def r3_def
      cfg0_def cfg1_def cfg2_def cfg3_def cfg4_def
      )

  let ?v = "x (cfg2 p)"
  from per_rd r1 have xs: "\<forall>q. x (cfg2 q) = ?v"
  proof(cases "\<exists>q w. q \<in> HOs r1 p \<and> vote (cfg1 q) = Some w")
    case True
    then obtain q w where q_w: "q \<in> HOs r1 p \<and> vote (cfg1 q) = Some w"
      by auto
    then have "\<forall>q'. vote (cfg1 q') \<in> {None, Some w}" using  same_new_vote[OF send0 step0 step_r0]
      by (metis insert_iff not_None_eq)
    hence "\<forall>q'. x (cfg2 q') = w"  using step1 send1 q_w
      apply(auto simp add: next1_def all_conj_distrib dec_update_def x_update_def
        get_msgs_benign send1_def isVote_def msgRcvd_def identicalVoteRcvd_def
        someVoteRcvd_def restrict_map_def)
      by (metis (erased, hide_lams) option.distinct(2) option.sel r1(1))
    thus ?thesis
      by auto
  next
    case False
    hence "\<forall>q'. x (cfg2 q') = coin r1 q'" using r1 step1 send1
      apply(auto simp add: next1_def all_conj_distrib dec_update_def x_update_def
        get_msgs_benign send1_def isVote_def msgRcvd_def identicalVoteRcvd_def
        someVoteRcvd_def restrict_map_def)
      by (metis False)
    thus ?thesis using r1
      by(metis)
  qed

  hence "\<forall>q. vote (cfg3 q) = Some ?v"
    by(simp add: vote_origin[OF send2 step2 step_r2])

  hence "decide (cfg4 p) = Some ?v" using send3[THEN spec, of p] step3[THEN spec, of p] HOs_nonempty
    by(auto simp add: next1_def send1_def get_msgs_benign dec_update_def
      restrict_map_def identicalVoteRcvd_def msgRcvd_def isVote_def)

  thus ?thesis
    by(auto simp add: cfg4_def)
qed

end (* HO predicate context *)

end (* mono_quorum context *)

end (* theory *)


theory DeadCodeRemoval2Correct
imports Launchbury LaunchburyAbstractTransformation DeadCodeRemoval2
begin

definition rdcH :: "var set \<Rightarrow> heap \<Rightarrow> heap"
  where "rdcH S \<Gamma> = restrictA (-S) (clearjunk (map_ran (\<lambda> _ e . remove_dead_code e) \<Gamma>))"

inductive dc_rel :: "(heap \<times> exp) \<Rightarrow> var list \<Rightarrow> (heap \<times> exp) \<Rightarrow>  bool" ("_ \<triangleright>\<^bsub>_\<^esub> _" [50,50,50] 50 )
  where "S \<subseteq> domA \<Gamma> \<union> set L \<Longrightarrow> S \<inter> fv (rdcH S \<Gamma>, remove_dead_code e, L) = {} \<Longrightarrow> (\<Gamma>, e) \<triangleright>\<^bsub>L\<^esub> (rdcH S \<Gamma>, remove_dead_code e)"

lemma delete_map_ran[simp]: "delete x (map_ran f \<Gamma>) = map_ran f (delete x \<Gamma>)"
  by (induction \<Gamma>) auto

lemma map_of_rdcH: "map_of (rdcH S \<Gamma>) x = (if x \<in> S then None else map_option remove_dead_code (map_of \<Gamma> x))"
  apply (induction \<Gamma> rule: clearjunk.induct)
  apply (auto simp add: rdcH_def map_of_clearjunk  split: if_splits)
  by (metis delete_map_ran map_of_delete)

lemma delete_rdcH[simp]: "delete x (rdcH S \<Gamma>) = rdcH S (delete x \<Gamma>)"
  by (induction \<Gamma> rule:clearjunk.induct)
     (auto simp add: rdcH_def  delete_twist split: if_splits)

lemma restrictA_UNIV[simp]: "restrictA UNIV \<Gamma> = \<Gamma>"
  by (induction \<Gamma>) auto

lemma restrictA_delete[simp]: "restrictA S (delete x \<Gamma>) = restrictA (S - {x}) \<Gamma>"
  by (induction \<Gamma>) auto

lemma clearjunk_append: "clearjunk (\<Gamma>1 @ \<Gamma>2) = clearjunk \<Gamma>1 @ clearjunk (restrictA (-domA \<Gamma>1) \<Gamma>2)"
  by (induction \<Gamma>1 arbitrary: \<Gamma>2 rule:clearjunk.induct) (auto simp add: Compl_insert)

lemma restrictA_clearjunk: "restrictA S (clearjunk \<Gamma>) = clearjunk (restrictA S \<Gamma>)"
  by (induction \<Gamma>  rule:clearjunk.induct) (auto simp add: Compl_insert)

lemma rdcH_append[simp]: "domA as \<inter> domA \<Gamma> = {} \<Longrightarrow> rdcH S (as @ \<Gamma>) = rdcH S as @ rdcH S \<Gamma>"
  unfolding rdcH_def apply (simp add: clearjunk_append restrictA_clearjunk map_ran_append restrictA_append)
  apply (rule arg_cong) back
  apply (rule restrictA_cong)
  apply auto
  done

lemma restrict_is_nil[simp]: "restrictA S \<Gamma> = [] \<longleftrightarrow> S \<inter> domA \<Gamma> = {}"
  by (induction \<Gamma>) auto

lemma rdcH_nil[simp]: "rdcH S [] = []"
  by (auto simp add: rdcH_def)

lemma rdcH_is_nil: "domA \<Gamma> \<subseteq> S \<Longrightarrow> rdcH S \<Gamma> = []"
  by (auto simp add: rdcH_def)

lemma rdcH_cong_set: "S \<inter> domA \<Gamma> = S' \<inter> domA \<Gamma> \<Longrightarrow> rdcH S \<Gamma> = rdcH S' \<Gamma>"
  unfolding rdcH_def by (rule restrictA_cong) auto

interpretation rel_lambda_cong dc_rel
  by default (auto elim!: dc_rel.cases simp del: exp_assn.eq_iff(4))
interpretation rel_app_cong dc_rel
  by default (auto elim: dc_rel.cases)
interpretation rel_var_cong dc_rel
  by default (auto elim: dc_rel.cases)

lemma rdcH_eqvt[eqvt]: "\<pi> \<bullet> (rdcH S \<Gamma>) = rdcH (\<pi> \<bullet> S) (\<pi> \<bullet> \<Gamma>)"
  unfolding rdcH_def by perm_simp rule

lemma rdch_fresh[intro]: "a \<sharp> \<Gamma> \<Longrightarrow> a \<sharp> rdcH S \<Gamma>"
  by (induction \<Gamma> rule: clearjunk.induct)
     (auto simp add:  rdcH_def fresh_Nil fresh_Pair fresh_Cons  eqvt_fresh_cong1[OF remove_dead_code.eqvt] fresh_delete)

lemma rdch_fv_subset: "fv (rdcH S \<Gamma>) \<subseteq> fv \<Gamma>"
  using rdch_fresh unfolding fresh_def fv_def by auto

lemma rdch_Cons[simp]:
  "x \<notin> S \<Longrightarrow> rdcH S ((x, z) # \<Gamma>) = (x, remove_dead_code z) # rdcH S (delete x \<Gamma>)"
  unfolding rdcH_def
  by (auto simp add: clearjunk_restrict[symmetric] delete_map_ran[symmetric] simp del: delete_map_ran)

interpretation reds_rel_fresh dc_rel
  by default (auto elim!: dc_rel.cases intro: eqvt_fresh_cong1[OF remove_dead_code.eqvt])

interpretation rel_lambda_case dc_rel by default

lemma Lam_eq_same_var[simp]: "Lam [y]. e = Lam [y]. e' \<longleftrightarrow>  e = e'"
  by auto (metis fresh_PairD(2) obtain_fresh)

interpretation rel_app_case dc_rel
proof
  fix \<Gamma> e x L \<Gamma>' e''
  assume "(\<Gamma>, App e x) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', App e'' x)"
  thus "(\<Gamma>, e) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', e'')"
    by (fastforce elim!: dc_rel.cases intro!: dc_rel.intros)
next
  fix \<Gamma> y body x L \<Gamma>' body'
  assume "(\<Gamma>, Lam [y]. body) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', Lam [y]. body')"
  thus "(\<Gamma>, body[y::=x]) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', body'[y::=x])"
    apply (auto elim!: dc_rel.cases intro!: dc_rel.intros dest: set_mp  simp del: exp_assn.eq_iff(4) simp add: subst_remove_dead_code disjoint_iff_not_equal fv_subst_eq split: if_splits)
    apply (auto simp add: subst_remove_dead_code[symmetric] fv_subst_eq  split: if_splits)
    done
qed

interpretation rel_var_case dc_rel
proof
  case (goal1 \<Gamma> x L \<Gamma>' e thesis)
  show thesis
  proof (rule goal1)

    from goal1(1)
    obtain S where "\<Gamma>' = rdcH S \<Gamma>"
      and "S \<subseteq> domA \<Gamma> \<union> set L" and "S \<inter> fv (rdcH S \<Gamma>, Var x, L) = {}" by (auto elim!: dc_rel.cases)
    hence "x \<notin> S" by auto

    from `map_of \<Gamma> x = Some e` and `\<Gamma>' = _` and `x \<notin> S`
    show "map_of \<Gamma>' x = Some (remove_dead_code e)" by (auto simp add: map_of_rdcH)

    have *: "\<And> S . fv (rdcH S (delete x \<Gamma>)) \<subseteq> fv (rdcH S \<Gamma>)" by (metis delete_rdcH fv_delete_subset)

    from `map_of \<Gamma>' x = Some (remove_dead_code e)`
    have **: "fv (remove_dead_code e) \<subseteq> fv \<Gamma>'" by (metis domA_from_set map_of_fv_subset map_of_is_SomeD option.sel)

    from goal1(1)
    show "(delete x \<Gamma>, e) \<triangleright>\<^bsub>x # L\<^esub> (delete x \<Gamma>', remove_dead_code e)"
      by (fastforce elim!: dc_rel.cases intro!: dc_rel.intros dest: set_mp[OF *]  set_mp[OF **]  simp add: disjoint_iff_not_equal)
  qed
next
  fix \<Gamma> z x L \<Gamma>' z'
  assume "(\<Gamma>, z) \<triangleright>\<^bsub>x # L\<^esub> (\<Gamma>', z')"
  then obtain S where "\<Gamma>' = rdcH S \<Gamma>" and "z' = remove_dead_code z"
      and "S \<subseteq> insert x (domA \<Gamma> \<union> set L)" and "S \<inter> fv (rdcH S \<Gamma>, remove_dead_code z, x # L) = {}" by (auto elim!: dc_rel.cases)

  from this(4)
  have "x \<notin> S" by auto
  moreover
  assume "x \<notin> domA \<Gamma>"
  ultimately
  have [simp]: "rdcH S ((x, z) # \<Gamma>) = (x,remove_dead_code z) # rdcH S \<Gamma>" by simp

  have  "((x, z) # \<Gamma>, z) \<triangleright>\<^bsub>L\<^esub> (rdcH S ((x, z) # \<Gamma>), remove_dead_code z)"
    apply (rule dc_rel.intros) using `S \<subseteq>  _` `S \<inter> _ = _`  by auto
  thus "((x, z) # \<Gamma>, z) \<triangleright>\<^bsub>L\<^esub> ((x, z') # \<Gamma>', z')"
    unfolding `\<Gamma>' = _` `z' = _` by auto
qed

locale let_removed =
  fixes \<Gamma> as body
  assumes "domA as \<inter> fv body = {} "

lemma map_fst_map_ran[simp]: "map fst (map_ran f l) = map fst l" by (induction l) auto

lemma permute_list_id: "supp p \<subseteq> set xs \<Longrightarrow>  p \<bullet> xs = xs \<Longrightarrow> p = 0"
proof (induction xs)
  case Nil
  hence "supp p = {}" by auto
  thus "p = 0" by (metis empty_subsetI supp_perm_singleton)
next
  case (Cons x xs)
  hence "p \<bullet> x = x" by auto
  hence "x \<notin> supp p" by (metis fresh_def fresh_perm)
  with Cons show "p = 0" by auto
qed

lemma Abs_lst_same[simp]: "[xs]lst. (y::'a::fs) = [xs]lst. y' \<longleftrightarrow> y = y'"
  apply rule
  prefer 2
  apply simp
  unfolding Abs_eq_iff2
  apply (erule exE)
  apply auto
  unfolding alpha_lst.simps
  apply (subgoal_tac "p = 0")
  apply auto[1]
  apply (auto simp add: permute_list_id)
  done

lemma Let_eq_same_var[simp]:
  assumes "map fst as = map fst as'"
  shows "Terms.Let as e = Terms.Let as' e' \<longleftrightarrow> (as = as' \<and> e = e')"
proof-
  from assms have  "map (\<lambda>x. atom (fst x)) as = map (\<lambda>x. atom (fst x)) as'"
    by (induction as as' rule: list_induct2') auto
  thus ?thesis by auto
qed

lemma disjoint_mono: "A \<inter> B = {} \<Longrightarrow>  A' \<subseteq> A \<Longrightarrow> B' \<subseteq> B \<Longrightarrow> A' \<inter> B' = {}" by auto

lemma disjoint_Un1: "(A \<union> B) \<inter> C = {} \<longleftrightarrow> A \<inter> C = {} \<and> B \<inter> C = {} " by auto
lemma disjoint_Un2: "C \<inter> (A \<union> B) = {} \<longleftrightarrow> C \<inter> A = {} \<and> C \<inter> B = {} " by auto

theorem DeadCodeRemovalCorrect:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  assumes "(\<Gamma>, e) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', e')"
   shows  "\<exists> \<Delta>' z'. (\<Delta>, z) \<triangleright>\<^bsub>L\<^esub> (\<Delta>', z') \<and> \<Gamma>' : e' \<Down>\<^bsub>L\<^esub> \<Delta>' : z'"
  using assms
proof(nominal_induct arbitrary: \<Gamma>' e' rule:reds.strong_induct)
case (Lambda \<Gamma> x e L) thus ?case by (rule lambda_case)
next
case (Application y \<Gamma> e x L \<Delta> \<Theta> z body) thus ?case by (rule app_case)
next
case (Variable \<Gamma> x e L \<Delta> z \<Gamma>' var) thus ?case by (rule var_case)
next
case (Let as \<Gamma> L body \<Delta> z \<Gamma>' let')
  let "Terms.Let ?as' ?body'" = "Terms.Let (restrict_reachable (map_ran (\<lambda>_. remove_dead_code) as) (remove_dead_code body)) (remove_dead_code body)"

  from `(\<Gamma>, Terms.Let as body) \<triangleright>\<^bsub>L\<^esub> (\<Gamma>', let')`
  obtain S where "\<Gamma>' = rdcH S \<Gamma>" and "let' = SmartLet ?as' ?body'"
  and "S \<subseteq> domA \<Gamma> \<union> set L" and S: "S \<inter> fv (rdcH S \<Gamma>, SmartLet ?as' ?body', L) = {}"  by (auto elim!: dc_rel.cases)

  let "?S'" = "domA as - reachable (map_ran (\<lambda>_. remove_dead_code) as) ?body'"

  from  `S \<subseteq> _` and fresh_distinct[OF Let(1)] and fresh_distinct_list[OF Let(2)]
  have "S \<inter> domA as = {}" by auto
  hence [simp]: "(rdcH (?S' \<union> S) as) = ?as'"
    unfolding restrict_reachable_def rdcH_def
    by -(rule restrictA_cong,  auto)

  have [simp]: "(rdcH (?S' \<union> S) \<Gamma>) = (rdcH S \<Gamma>)"
    using fresh_distinct[OF Let(1)]
    by (auto intro: rdcH_cong_set simp add: fresh_star_at_base)

  have "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (rdcH (?S' \<union> S) (as @ \<Gamma>), ?body')"
  proof (rule dc_rel.intros)
    show "(?S' \<union> S) \<subseteq> domA (as @ \<Gamma>) \<union> set L" using `S \<subseteq> domA \<Gamma> \<union> set L` by auto

    have "?S' \<inter> fv ?as' = {}"
      using fv_heap_reachable by auto
    moreover
    have "?S' \<inter> fv \<Gamma> = {}"
      using Let(1) by (auto simp add: fresh_star_def fresh_def fv_def)
    hence "?S' \<inter> fv (rdcH S \<Gamma>) = {}"
      by (rule disjoint_mono[OF _ subset_refl rdch_fv_subset])
    moreover
    have "?S' \<inter> fv (?body') = {}"
      using fv_e_reachable by auto
    moreover
    have "?S' \<inter> fv L = {}"
      using fresh_distinct_list[OF Let(2)] by auto
    moreover
    have "S \<inter> fv ?as' = {}"
      using S `S \<inter> domA as = {}` by auto
    moreover
    have "S \<inter> fv (rdcH S \<Gamma>) = {}"
      using S by auto
    moreover
    have "S \<inter> fv (?body') = {}"
      using S `S \<inter> domA as = {}` by auto
    moreover
    have "S \<inter> fv L = {}"
      using S by auto
    ultimately
    show "(?S' \<union> S) \<inter> fv (rdcH (?S' \<union> S) (as @ \<Gamma>), ?body', L) = {}" using fresh_distinct[OF Let(1)] by auto
  qed
  hence "(as @ \<Gamma>, body) \<triangleright>\<^bsub>L\<^esub> (?as' @ \<Gamma>', ?body')" unfolding `\<Gamma>'=_` using fresh_distinct[OF Let(1)] by simp
  from Let(4)[OF this]
  obtain \<Delta>' z' where "(\<Delta>, z) \<triangleright>\<^bsub>L\<^esub> (\<Delta>', z')" and "?as' @ \<Gamma>' : ?body' \<Down>\<^bsub>L\<^esub> \<Delta>' : z'" by auto
  from reds_SmartLet[OF _ this(2)]
  have "\<Gamma>' : let' \<Down>\<^bsub>L\<^esub> \<Delta>' : z'" unfolding `\<Gamma>'=_`  `let' = _`
    using Let(1,2) by (auto simp add: fresh_star_def fresh_Pair)
  with `(\<Delta>, z) \<triangleright>\<^bsub>L\<^esub> (\<Delta>', z')`
  show ?case  by auto
qed

corollary
  assumes "[] : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
   shows  "\<exists> \<Delta>' z'. [] : remove_dead_code e \<Down>\<^bsub>L\<^esub> \<Delta>' : z'"
proof-
  have "([], e) \<triangleright>\<^bsub>L\<^esub> (rdcH {} [], remove_dead_code e)" by (rule dc_rel.intros) auto
  hence "([], e) \<triangleright>\<^bsub>L\<^esub> ([], remove_dead_code e)" by simp
  from DeadCodeRemovalCorrect[OF assms this]
  show ?thesis by auto
qed

end


(*  Title:      HOL/HOLCF/IOA/NTP/Impl.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

section \<open>The implementation\<close>

theory Impl
imports Sender Receiver Abschannel
begin

type_synonym 'm impl_state
  = "'m sender_state * 'm receiver_state * 'm packet multiset * bool multiset"
  (*  sender_state   *  receiver_state   *    srch_state      * rsch_state *)

definition
  impl_ioa :: "('m action, 'm impl_state)ioa" where
  impl_def: "impl_ioa == (sender_ioa \<parallel> receiver_ioa \<parallel> srch_ioa \<parallel> rsch_ioa)"

definition sen :: "'m impl_state => 'm sender_state" where "sen = fst"
definition rec :: "'m impl_state => 'm receiver_state" where "rec = fst \<circ> snd"
definition srch :: "'m impl_state => 'm packet multiset" where "srch = fst \<circ> snd \<circ> snd"
definition rsch :: "'m impl_state => bool multiset" where "rsch = snd \<circ> snd \<circ> snd"

definition
  hdr_sum :: "'m packet multiset => bool => nat" where
  "hdr_sum M b == countm M (%pkt. hdr(pkt) = b)"

(* Lemma 5.1 *)
definition
  "inv1(s) \<equiv>
     (\<forall>b. count (rsent(rec s)) b = count (srcvd(sen s)) b + count (rsch s) b)
   \<and> (\<forall>b. count (ssent(sen s)) b
          = hdr_sum (rrcvd(rec s)) b + hdr_sum (srch s) b)"

(* Lemma 5.2 *)
definition
  "inv2(s) ==
  (rbit(rec(s)) = sbit(sen(s)) &
   ssending(sen(s)) &
   count (rsent(rec s)) (~sbit(sen s)) <= count (ssent(sen s)) (~sbit(sen s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)))
   |
  (rbit(rec(s)) = (~sbit(sen(s))) &
   rsending(rec(s)) &
   count (ssent(sen s)) (~sbit(sen s)) <= count (rsent(rec s)) (sbit(sen s)) &
   count (rsent(rec s)) (sbit(sen s)) <= count (ssent(sen s)) (sbit(sen s)))"

(* Lemma 5.3 *)
definition
  "inv3(s) \<equiv>
   rbit(rec(s)) = sbit(sen(s))
   \<longrightarrow> (\<forall>m. sq(sen(s))=[] | m \<noteq> hd(sq(sen(s)))
        \<longrightarrow>  count (rrcvd(rec s)) (sbit(sen(s)),m)
             + count (srch s) (sbit(sen(s)),m)
            \<le> count (rsent(rec s)) (~sbit(sen s)))"

(* Lemma 5.4 *)
definition "inv4(s) == rbit(rec(s)) = (~sbit(sen(s))) --> sq(sen(s)) ~= []"

subsection \<open>Invariants\<close>

declare le_SucI [simp]

lemmas impl_ioas =
  impl_def sender_ioa_def receiver_ioa_def srch_ioa_thm [THEN eq_reflection]
  rsch_ioa_thm [THEN eq_reflection]

lemmas "transitions" =
  sender_trans_def receiver_trans_def srch_trans_def rsch_trans_def

lemmas [simp] =
  ioa_triple_proj starts_of_par trans_of_par4 in_sender_asig
  in_receiver_asig in_srch_asig in_rsch_asig

declare let_weak_cong [cong]

lemma [simp]:
  "a\<in>actions(sender_asig)
  \<or> a\<in>actions(receiver_asig)
  \<or> a\<in>actions(srch_asig)
  \<or> a\<in>actions(rsch_asig)"
  by (induct a) simp_all

declare split_paired_All [simp del]

(* Three Simp_sets in different sizes
----------------------------------------------

1) simpset() does not unfold the transition relations
2) ss unfolds transition relations
3) renname_ss unfolds transitions and the abstract channel *)

ML \<open>
val ss = simpset_of (\<^context> addsimps @{thms "transitions"});
val rename_ss = simpset_of (put_simpset ss \<^context> addsimps @{thms unfold_renaming});

fun tac ctxt =
  asm_simp_tac (put_simpset ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm if_split})
fun tac_ren ctxt =
  asm_simp_tac (put_simpset rename_ss ctxt
    |> Simplifier.add_cong @{thm conj_cong} |> Splitter.add_split @{thm if_split})
\<close>

subsubsection \<open>Invariant 1\<close>

lemma raw_inv1: "invariant impl_ioa inv1"

apply (unfold impl_ioas)
apply (rule invariantI)
apply (simp add: inv1_def hdr_sum_def srcvd_def ssent_def rsent_def rrcvd_def)

apply (simp (no_asm) del: trans_of_par4 add: imp_conjR inv1_def)

txt \<open>Split proof in two\<close>
apply (rule conjI)

(* First half *)
apply (simp add: Impl.inv1_def split del: if_split)
apply (induct_tac a)

apply (tactic "EVERY1[tac \<^context>, tac \<^context>, tac \<^context>, tac \<^context>]")
apply (tactic "tac \<^context> 1")
apply (tactic "tac_ren \<^context> 1")

txt \<open>5 + 1\<close>

apply (tactic "tac \<^context> 1")
apply (tactic "tac_ren \<^context> 1")

txt \<open>4 + 1\<close>
apply (tactic \<open>EVERY1[tac \<^context>, tac \<^context>, tac \<^context>, tac \<^context>]\<close>)

txt \<open>Now the other half\<close>
apply (simp add: Impl.inv1_def split del: if_split)
apply (induct_tac a)
apply (tactic "EVERY1 [tac \<^context>, tac \<^context>]")

txt \<open>detour 1\<close>
apply (tactic "tac \<^context> 1")
apply (tactic "tac_ren \<^context> 1")
apply (rule impI)
apply (erule conjE)+
apply (simp (no_asm_simp) add: hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  split: if_split)
txt \<open>detour 2\<close>
apply (tactic "tac \<^context> 1")
apply (tactic "tac_ren \<^context> 1")
apply (rule impI)
apply (erule conjE)+
apply (simp add: Impl.hdr_sum_def Multiset.count_def Multiset.countm_nonempty_def
  Multiset.delm_nonempty_def split: if_split)
apply (rule allI)
apply (rule conjI)
apply (rule impI)
apply hypsubst
apply (rule pred_suc [THEN iffD1])
apply (drule less_le_trans)
apply (cut_tac eq_packet_imp_eq_hdr [unfolded Packet.hdr_def, THEN countm_props])
apply assumption
apply assumption

apply (rule countm_done_delm [THEN mp, symmetric])
apply (rule refl)
apply (simp (no_asm_simp) add: Multiset.count_def)

apply (rule impI)
apply (simp add: neg_flip)
apply hypsubst
apply (rule countm_spurious_delm)
apply (simp (no_asm))

apply (tactic "EVERY1 [tac \<^context>, tac \<^context>, tac \<^context>,
  tac \<^context>, tac \<^context>, tac \<^context>]")

done

subsubsection \<open>INVARIANT 2\<close>

lemma raw_inv2: "invariant impl_ioa inv2"

  apply (rule invariantI1)
  txt \<open>Base case\<close>
  apply (simp add: inv2_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  txt \<open>10 cases. First 4 are simple, since state doesn't change\<close>

  ML_prf \<open>val tac2 = asm_full_simp_tac (put_simpset ss \<^context> addsimps [@{thm inv2_def}])\<close>

  txt \<open>10 - 7\<close>
  apply (tactic "EVERY1 [tac2,tac2,tac2,tac2]")
  txt \<open>6\<close>
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)

  txt \<open>6 - 5\<close>
  apply (tactic "EVERY1 [tac2,tac2]")

  txt \<open>4\<close>
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)
  apply (tactic "tac2 1")

  txt \<open>3\<close>
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv1_def}]
    (@{thm raw_inv1} RS @{thm invariantE})] 1\<close>)

  apply (tactic "tac2 1")
  apply (tactic \<open>fold_goals_tac \<^context> [rewrite_rule \<^context> [@{thm Packet.hdr_def}]
    (@{thm Impl.hdr_sum_def})]\<close>)
  apply arith

  txt \<open>2\<close>
  apply (tactic "tac2 1")
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct1] 1\<close>)
  apply (intro strip)
  apply (erule conjE)+
  apply simp

  txt \<open>1\<close>
  apply (tactic "tac2 1")
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv1_def}]
                               (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1\<close>)
  apply (intro strip)
  apply (erule conjE)+
  apply (tactic \<open>fold_goals_tac \<^context>
    [rewrite_rule \<^context> [@{thm Packet.hdr_def}] (@{thm Impl.hdr_sum_def})]\<close>)
  apply simp

  done

subsubsection \<open>INVARIANT 3\<close>

lemma raw_inv3: "invariant impl_ioa inv3"

  apply (rule invariantI)
  txt \<open>Base case\<close>
  apply (simp add: Impl.inv3_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  ML_prf \<open>val tac3 = asm_full_simp_tac (put_simpset ss \<^context> addsimps [@{thm inv3_def}])\<close>

  txt \<open>10 - 8\<close>

  apply (tactic "EVERY1[tac3,tac3,tac3]")

  apply (tactic "tac_ren \<^context> 1")
  apply (intro strip, (erule conjE)+)
  apply hypsubst
  apply (erule exE)
  apply simp

  txt \<open>7\<close>
  apply (tactic "tac3 1")
  apply (tactic "tac_ren \<^context> 1")
  apply force

  txt \<open>6 - 3\<close>

  apply (tactic "EVERY1[tac3,tac3,tac3,tac3]")

  txt \<open>2\<close>
  apply (tactic "asm_full_simp_tac (put_simpset ss \<^context>) 1")
  apply (simp (no_asm) add: inv3_def)
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp
  apply (erule conjE)+
  apply (rule_tac j = "count (ssent (sen s)) (~sbit (sen s))" and
    k = "count (rsent (rec s)) (sbit (sen s))" in le_trans)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm inv1_def}]
                                (@{thm raw_inv1} RS @{thm invariantE}) RS conjunct2] 1\<close>)
  apply (simp add: hdr_sum_def Multiset.count_def)
  apply (rule add_le_mono)
  apply (rule countm_props)
  apply (simp (no_asm))
  apply (rule countm_props)
  apply (simp (no_asm))
  apply assumption

  txt \<open>1\<close>
  apply (tactic "tac3 1")
  apply (intro strip, (erule conjE)+)
  apply (rule imp_disjL [THEN iffD1])
  apply (rule impI)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv2_def}]
    (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp
  done

subsubsection \<open>INVARIANT 4\<close>

lemma raw_inv4: "invariant impl_ioa inv4"

  apply (rule invariantI)
  txt \<open>Base case\<close>
  apply (simp add: Impl.inv4_def receiver_projections sender_projections impl_ioas)

  apply (simp (no_asm_simp) add: impl_ioas split del: if_split)
  apply (induct_tac "a")

  ML_prf \<open>val tac4 =  asm_full_simp_tac (put_simpset ss \<^context> addsimps [@{thm inv4_def}])\<close>

  txt \<open>10 - 2\<close>

  apply (tactic "EVERY1[tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4,tac4]")

  txt \<open>2 b\<close>

  apply (intro strip, (erule conjE)+)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply simp

  txt \<open>1\<close>
  apply (tactic "tac4 1")
  apply (intro strip, (erule conjE)+)
  apply (rule ccontr)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv2_def}]
                               (@{thm raw_inv2} RS @{thm invariantE})] 1\<close>)
  apply (tactic \<open>forward_tac \<^context> [rewrite_rule \<^context> [@{thm Impl.inv3_def}]
                               (@{thm raw_inv3} RS @{thm invariantE})] 1\<close>)
  apply simp
  apply (rename_tac m, erule_tac x = "m" in allE)
  apply simp
  done

text \<open>rebind them\<close>

lemmas inv1 = raw_inv1 [THEN invariantE, unfolded inv1_def]
  and inv2 = raw_inv2 [THEN invariantE, unfolded inv2_def]
  and inv3 = raw_inv3 [THEN invariantE, unfolded inv3_def]
  and inv4 = raw_inv4 [THEN invariantE, unfolded inv4_def]

end


(* derivations on arbitrary states indexed with natural numbers to differentiate the states *)
theory IndexedDerivations
imports
  HOL_ext
  Hints
  Protocol
  ExecMessage
begin

chapter{* Security Proofs *}

section{* Networked Transition Systems *}

types 's nts = "'s \<times> ('s \<times> execmsg option \<times> 's \<times> execmsg option) set"

section{* Standard Execution Model *}

inductive_set
  dy    :: "'s nts \<Rightarrow> ('s list \<times> execmsg set) set"
  for P :: "'s nts"
where
  init : "([fst P], {}) \<in> dy P"
| proto:
  "\<lbrakk> (tr@[s], M) \<in> dy P;
     Option.set inp \<subseteq> M;
     (s, inp, s', out) \<in> snd P
   \<rbrakk> \<Longrightarrow>
     (tr@[s,s'], M \<union> Option.set out) \<in> dy P"
| infer:
  "\<lbrakk> (tr, M) \<in> dy P;
     m \<in> infer M
   \<rbrakk> \<Longrightarrow>
     (tr, insert m M) \<in> dy P"

section{* Derivations *}

datatype 's node = Init | State "nat \<times> 's" | Msg execmsg

types 's derivation = "('s node \<times> 's node) set"

fun analz :: "execmsg set \<Rightarrow> 's node set \<Rightarrow> execmsg \<Rightarrow> 's derivation"
where
  "analz M N (Tup x y) =
    (if (Tup x y \<in> M)
        then {}
        else N \<times> {Msg (Tup x y)} \<union> analz M N x \<union> analz M N y
    )"
| "analz M N (Enc m k) =
    (if (Enc m k \<in> M)
       then {}
       else
         N \<times> {Msg (Enc m k)} \<union>
         (if (inv k \<in> M)
            then analz M {Msg (Enc m k), Msg (inv k)} m
            else {}
         )
    )"
| "analz M N m =
    (if m \<in> M then {} else N \<times> {Msg m})"

definition knows :: "'s derivation \<Rightarrow> execmsg set"
where "knows D \<equiv> {m. Msg m \<in> Range D}"

definition "states" :: "'s derivation \<Rightarrow> (nat \<times> 's) set"
where "states D \<equiv> {s. State s \<in> Range D}"

inductive_set
  derivs :: "'s nts \<Rightarrow> 's derivation set"
  for P      :: "'s nts"
where
  init: "{(Init, State (0,fst P))} \<in> derivs P"

| proto:
  "\<lbrakk> D \<in> derivs P;
     Option.set inp \<subseteq> knows D;
     (i, s) \<in> states D;
     \<forall> (i',s') \<in> states D. i' \<le> i;
     (s, inp, s', out) \<in> snd P
   \<rbrakk> \<Longrightarrow>
     (insert (State (i,s),State (Suc i,s')) D \<union>
       ((Msg ` Option.set inp) \<times>  {State (Suc i, s')}) \<union>
       UNION (Option.set out) (analz (knows D) {State (Suc i, s')})
     ) \<in> derivs P"

| hash:
  "\<lbrakk> D \<in> derivs P;
     m \<in> knows D;
     Hash m \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     insert (Msg m, Msg (Hash m)) D \<in> derivs P"

| tuple:
  "\<lbrakk> D \<in> derivs P;
     x \<in> knows D;
     y \<in> knows D;
     Tup x y \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     {Msg x, Msg y} \<times> {Msg (Tup x y)} \<union> D \<in> derivs P"

| encr:
  "\<lbrakk> D \<in> derivs P;
     m \<in> knows D;
     k \<in> knows D;
     Enc m k \<notin> knows D
   \<rbrakk> \<Longrightarrow>
     {Msg m, Msg k} \<times> {Msg (Enc m k)} \<union> D \<in> derivs P"

subsection{* All derivations are orders on nodes *}

locale derivation =
  fixes P :: "'s nts"
  and   D :: "'s derivation"
  assumes derivable: "D \<in> derivs P"
begin

text{* A local variant of the induction rule of @{term "reachable"}. *}
lemmas derivs_induct = derivs.induct
  [ OF derivable
  , rule_format
  , consumes 0
  , case_names init proto hash tuple encr
  ]

lemma analz_irr:
  "N \<subseteq> range State \<union> { Msg m' | m'. size m' > size m} \<Longrightarrow>
   (x,x) \<notin> analz M N m"
apply(induct m arbitrary: N)
apply(simp_all)
apply(case_tac x, simp, simp, simp)
apply(clarsimp)
apply(force)
apply(case_tac x, simp)
apply(clarsimp)
oops

lemma derivation_irr: "(x,x) \<notin> D"
proof(induct rule: derivs_induct)
  case init thus ?case by simp
next
  case (proto D inp i s s' out) thus ?case
    apply (clarsimp simp: image_def)
    apply (rule conjI)
    apply (case_tac x)
    apply (simp, simp, simp)
    apply (case_tac out)
    apply(simp)
    apply(simp)

  apply(induct t, auto)
  apply(case_tac x, auto)
  apply(case_tac a, auto)
  apply(case_tac a, auto)
  done

lemma predOrd_distinct'_trans:
  "\<lbrakk> predOrd t x y; predOrd t y z; distinct' t \<rbrakk>
   \<Longrightarrow> predOrd t x z"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

lemma predOrd_distinct'_asymD:
  "\<lbrakk> predOrd t x y; distinct' t \<rbrakk> \<Longrightarrow> \<not> predOrd t y x"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

lemma

(*
definition sound :: "'s derivation \<Rightarrow> bool"
where "sound dr = (case dr of (tr, D) \<Rightarrow>
        (acyclic ({ (State s, State s') | s s'. listOrd tr s s' } \<union> D) \<and>
         (\<forall> m \<in> knows D. (\<exists> s. (State s, Msg m) \<in> D\<^sup>+))))"

definition derivs :: "'s nts \<Rightarrow> 's derivation set"
where "derivs P \<equiv>
        { (tr, drop_msgs M D)
        | tr D M.
          (tr, D) \<in> derivs P \<and> sound (tr, drop_msgs M D)
        }"
*)

section{* Relating the two models *}

lemma dy_conv_derivs:
  "{ (tr, M)       | tr M M'. M \<subseteq> M' \<and> (tr, M) \<in> dy P     } =
   { (tr, knows D) | tr D.             (tr, D) \<in> derivs P }"
  oops

(* MOVE *)
lemma acyclic_empty [iff]: "acyclic {}"
  by (simp add: acyclic_def)

lemma knows_empty [iff]: "knows {} = {}"
  by (auto simp: knows_def)

(*
lemma in_derivsE [elim!]:
  "\<lbrakk> (tr, D) \<in> derivs P;
     \<And> M D'. \<lbrakk> (tr, D') \<in> derivs P;
                D = D' - (Msg ` M) \<times> UNIV - UNIV \<times> (Msg ` M);
                sound (tr, D)
              \<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  by(auto simp: derivs_def)

lemma knows_cases: "\<lbrakk> (tr, D) \<in> derivs P; m \<in> knows D \<rbrakk> \<Longrightarrow> R"
  apply(clarsimp)
  apply(drule derivs.cases)
  apply(simp_all)
  oops
*)

lemma knows_union [simp]: "knows (M \<union> N) = knows M \<union> knows N"
  by (auto simp: knows_def)

lemma knows_insert_Msg [simp]: "knows (insert (x, Msg m) D) = insert m (knows D)"
  by(auto simp: knows_def)

lemma knows_insert_State [simp]: "knows (insert (x, State s) D) = knows D"
  by(auto simp: knows_def)

lemma in_knows_times: "M \<noteq> {} \<Longrightarrow> (m \<in> knows (M \<times> N)) = (Msg m \<in> N)"
  by (auto simp: knows_def Range_iff)

lemma dy_imp_derivs:
  "(tr, M) \<in> dy P \<Longrightarrow>
   \<exists> D. (tr, D) \<in> derivs P \<and> M \<subseteq> knows D
  "
proof(induct rule: dy.induct)
  case init thus ?case by(auto intro!: derivs.init)
next
  case (proto tr s M inp s' out) thus ?case
    apply(clarsimp)
    apply(rule exI, rule conjI)
    apply(rule_tac inp=inp in derivs.proto)
    apply(assumption)
    apply(blast)
    apply(assumption)
    apply(rule conjI)
    apply(fastsimp)
    apply(clarsimp)
    apply(rule classical)
    apply(case_tac x)
    apply(simp_all)
    done
next
  case (infer tr M m)
  then obtain D where the_deriv: "(tr, D) \<in> derivs P" "M \<subseteq> knows D"
    by auto
  have " \<lbrakk> m \<in> infer M; M \<subseteq> knows D; (tr, D) \<in> derivs P \<rbrakk> \<Longrightarrow>
         \<exists>D'. (tr, D' \<union> D) \<in> derivs P \<and> m \<in> knows (D \<union> D') \<and>
              (\<forall> x \<in> M. m \<notin> knows D')"
  proof(induct arbitrary: D rule: infer.induct)
    case Inj thus ?case
      apply -
      apply(rule_tac x="{}" in exI)
      apply(auto)
      done
  next
    case (Tup x y) thus ?case
      apply(clarsimp)
      apply(rule exI, rule conjI)
      apply(rule derivs.tuple[of tr D _ x y], assumption+)
      oops

section{* Properties of the derivations *}

fun add_index :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list"
where
  "add_index i []     = []"
| "add_index i (x#xs) = (i,x) # add_index (Suc i) xs"

definition deps :: "'s derivation \<Rightarrow> 's derivations"
where "deps dr \<equiv> case dr of (tr, D) \<Rightarrow>
         D \<union> { (x,y) | x y. listOrd (add_index 0 tr) (State x) (State y)}"

section{* Executing Protocol Scripts *}

types threadpool = "tid \<rightharpoonup> (rolestep list \<times> rolestep list)"

types state = "threadpool \<times> store"

definition proto2nts :: "proto \<Rightarrow> state option nts"
where "proto2nts P =
  ( None
  , ({ ( None, None, Some (th, st), None)
     | th st.
       (\<forall> i done todo. th i = Some (done,todo) \<longrightarrow>
                                done = [] \<and> todo \<in> P) \<and>
       (\<forall> a i. st (AVar a, i) \<in> Compromised \<union> Uncompromised)
     }
     \<union>
     { (s, None, s, Some m)
     | s m.
       m \<in> IK0
     }
     \<union>
     (\<Union> R \<in> P.
       { ( Some (th, st)
         , Some (inst st i pt)
         , Some (th(i\<mapsto> (done @ [Recv l pt], todo)), st)
         , None
         )
       | th st i l pt done todo.
         th i = Some (done, Recv l pt # todo)
       }
     )
     \<union>
     (\<Union> R \<in> P.
       { ( Some (th, st)
         , None
         , Some (th(i\<mapsto> (done @ [Send l pt], todo)), st)
         , Some (inst st i pt)
         )
       | th st i l pt done todo.
         th i = Some (done, Send l pt # todo)
       }
     )
    )
  )
"

(* OOOOOOOOOOOOOOOOOOOOLDDDDDDDDDDDDDDDDDDDDDDDD *)

term "undefined"
thm the_def
thm
thm undefined_def

types explicit_trace = "rawevent list"
types execstep = "tid \<times> rolestep"

fun knows :: "explicit_trace \<Rightarrow> execmsg set"
where
  "knows [] = {}"
| "knows (Learns M # t) = M \<union> knows t"
| "knows (Step estep # t) = knows t"

fun steps :: "explicit_trace \<Rightarrow> execstep set"
where
  "steps [] = {}"
| "steps (Learns M # t) = steps t"
| "steps (Step estep # t) = insert estep (steps t)"

types state = "explicit_trace \<times> threadpool \<times> store"

inductive_set
  reachable :: "proto \<Rightarrow> state set"
  for P     :: "proto"
where
  init:  "\<lbrakk> \<forall> i done todo. r i = Some (done,todo) \<longrightarrow>
                             done = [] \<and> todo \<in> P;
            \<forall> a i. s (AVar a, i) \<in> Compromised \<union> Uncompromised
          \<rbrakk>
          \<Longrightarrow> ([Learns IK0], r, s) \<in> reachable P"

| send:  "\<lbrakk> (t, r, s) \<in> reachable P;
            r i = Some (done, Send l pt # todo);
            m = inst s i pt
          \<rbrakk>
          \<Longrightarrow> (t @ [Step (i, Send l pt),
                    Learns (pairParts m - knows t)]
              , r(i \<mapsto> (done @ [Send l pt], todo))
              , s) \<in> reachable P"

| recv:  "\<lbrakk> (t, r, s) \<in> reachable P;
            r i = Some (done, Recv l pt # todo);
            inst s i pt \<in> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Step (i, Recv l pt)]
              , r(i \<mapsto> (done @ [Recv l pt], todo))
              , s) \<in> reachable P"

| hash:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows t;
            Hash m \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Hash m}], r, s) \<in> reachable P"

| tuple: "\<lbrakk> (t, r, s) \<in> reachable P;
            x \<in> knows t;
            y \<in> knows t;
            Tup x y \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Tup x y}], r, s) \<in> reachable P"

| encr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows t;
            k \<in> knows t;
            Enc m k \<notin> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns {Enc m k}], r, s) \<in> reachable P"

| decr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            Enc m k \<in> knows t;
            inv k \<in> knows t
          \<rbrakk>
          \<Longrightarrow> (t @ [Learns (pairParts m - knows t)], r, s) \<in> reachable P"

locale reachable_state =  wf_proto +
  fixes t :: explicit_trace
  and   r :: threadpool
  and   s :: store
  assumes reachable [simp,intro!]: "(t,r,s) \<in> reachable P"
begin
  text{* A local variant of the induction rule of @{term "reachable"}. *}
  lemmas reachable_induct = reachable.induct
    [ OF reachable
    , rule_format
    , consumes 0
    , case_names init send recv hash tuple encr decr
    ]
end

text{* An extension of the reachable state locale denoting
       an individual thread and its state. *}

locale reachable_thread = reachable_state +
  fixes i      :: "tid"
    and "done" :: "rolestep list"
    and todo   :: "rolestep list"
  assumes thread_exists: "r i = Some (done, todo)"
begin

  text{* The thread state is built such that @{term "done @ todo"} is
         always a role of @{term P}. *}

  lemma role_in_P:
    "done @ todo \<in> P"
  using thread_exists
  proof (induct arbitrary: i "done" todo rule: reachable_induct)
  qed (fastsimp split: if_splits)+

end

text{* Importing all lemmas of the wellformed role locale for
the term @{term "done @ todo"}. *}
sublocale reachable_thread \<subseteq> wf_role "done @ todo"
  by (rule wf_roles[OF role_in_P])

subsection{* Basic Properties *}

lemma knowsI: "\<lbrakk> Learns M \<in> set t; m \<in> M \<rbrakk> \<Longrightarrow> m \<in> knows t"
  by(induct t rule: knows.induct, auto)

lemma knowsD: "m \<in> knows t \<Longrightarrow> \<exists> M. Learns M \<in> set t \<and> m \<in> M"
  by(induct t rule: steps.induct, auto)

lemma knows_append [simp]:
  "knows (xs@ys) = knows xs \<union> knows ys"
  by(induct xs rule: knows.induct, auto)

lemma stepsI: "Step estep \<in> set t \<Longrightarrow> estep \<in> steps t"
  by(induct t rule: steps.induct, auto)

lemma stepsD: "estep \<in> steps t \<Longrightarrow> Step estep \<in> set t"
  by(induct t rule: steps.induct, auto)

lemma Step_in_set_conv [simp]:
  "(Step estep \<in> set t) = (estep \<in> steps t)"
  by(auto intro!: stepsI stepsD)

lemma steps_append [simp]:
  "steps (t@t') = steps t \<union> steps t'"
  by(induct t rule: steps.induct, auto)

subsection{* Thread Execution *}

lemma (in reachable_state) step_in_dom:
  "(i, step) \<in> steps t \<Longrightarrow> i \<in> dom r"
proof (induct rule: reachable_induct) qed auto

context reachable_thread
begin

lemma in_dom_r [iff]: "i \<in> dom r"
  by (auto intro!: thread_exists)

lemma distinct_done [iff]: "distinct done"
using distinct by auto

lemma distinct_todo [iff]: "distinct todo"
using distinct by auto

lemma in_steps_eq_in_done:
  "((i, step) \<in> steps t) = (step \<in> set done)"
proof -
  have
    "((i, step) \<in> steps t) =
    (\<exists> done todo. r i = Some (done, todo) \<and> step \<in> set done)"
  proof(induct arbitrary: i "done" todo rule: reachable_induct)
    case (init r s i) thus ?case by fastsimp
  qed auto
  thus ?thesis using thread_exists by auto
qed

lemmas steps_in_done [elim!] = iffD1[OF in_steps_eq_in_done, rule_format]
lemmas done_in_steps [elim!] = iffD2[OF in_steps_eq_in_done, rule_format]

lemma todo_notin_stepsD:
  "step \<in> set todo \<Longrightarrow> (i, step) \<notin> steps t"
using distinct by(auto dest!: steps_in_done)

lemmas todo_notin_stepsE = notE[OF todo_notin_stepsD, rule_format]

lemma listOrd_done_imp_listOrd_trace:
  "listOrd done prev step \<Longrightarrow>
   listOrd t (Step (i, prev)) (Step (i, step))"
using thread_exists
proof(induct arbitrary: i "done" todo rule: reachable_induct)
  case (init r s i "done" todo) thus ?case
    by fastsimp
next
  case (send t r s i "done" l msg todo m i' done' todo')
  then interpret this_thread:
    reachable_thread P t r s i "done" "Send l msg # todo"
    by unfold_locales auto
  from send show ?case
    by(auto split: if_splits)
next
  case (recv t r s i "done" l msg todo i' done' todo')
  then interpret this_thread:
    reachable_thread P t r s i "done" "Recv l msg # todo"
    by unfold_locales auto
  from recv show ?case
    by(auto split: if_splits)
qed auto

lemma listOrd_role_imp_listOrd_trace:
  "\<lbrakk> (i, step) \<in> steps t; listOrd (done @ todo) prev step \<rbrakk>
  \<Longrightarrow> listOrd t (Step (i, prev)) (Step (i, step))"
using distinct
by (fastsimp dest: in_set_listOrd2 listOrd_done_imp_listOrd_trace)

end

subsection{* Variable Substitutions *}

context reachable_state
begin

lemma inst_AVar_cases:
  "s (AVar v, i) \<in> Uncompromised \<or> s (AVar v, i) \<in> Compromised"
  by (induct rule: reachable_induct) (fastsimp+)

lemma inst_AVar_in_IK0:
 "s (AVar v, i) \<in> IK0"
using inst_AVar_cases[of v i]
by (auto simp: IK0_def Uncompromised_def Compromised_def)

lemma knows_IK0: "m \<in> IK0 \<Longrightarrow> m \<in> knows t"
  by(induct rule: reachable_induct, auto)

lemma inst_AVar_in_knows [iff]:
  "s (AVar a, i) \<in> knows t"
  by (rule knows_IK0[OF inst_AVar_in_IK0])

end (* reachable_state *)

(* TODO: Move *)
lemma MVar_in_FV_conv_FMV [iff]:
  "(MVar v \<in> FV pt) = (v \<in> FMV pt)"
  by(induct pt, auto, case_tac varid, auto)

context reachable_state
begin

lemma send_step_FV:
  assumes thread_exists: "r i = Some (done, Send l msg # todo)"
  and FV: "MVar n \<in> FV msg"
  shows "\<exists> l' msg'. (i, Recv l' msg') \<in> steps t \<and>  MVar n \<in> FV msg'"
proof -
  interpret this_thread: reachable_thread P t r s i "done" "Send l msg # todo"
    using thread_exists by unfold_locales auto
  let ?role = "done @ Send l msg # todo"
  have "Send l msg \<in> set ?role" by simp
  then obtain l' msg'
    where "listOrd ?role (Recv l' msg') (Send l msg)"
    and "MVar n \<in> FV msg'"
    using FV by(fast dest!: this_thread.Send_FV)
  thus ?thesis using this_thread.distinct
    by(auto dest: in_set_listOrd1 in_set_listOrd2)
qed

end

subsubsection{* The Effect of a Step on the Intruder Knowledge *}

context reachable_state
begin

lemma SendD:
  "(i, Send lbl pt) \<in> steps t \<Longrightarrow>
   inst s i pt \<in> knows t"
proof(induct rule: reachable_induct)
qed auto

end

subsection{* Almost Distinct Traces *}

fun distinct' :: "explicit_trace \<Rightarrow> bool"
where
  "distinct' [] = True"
| "distinct' (Learns M # t) =
     ((\<forall> m \<in> M. m \<notin> knows t) \<and> distinct' t)"
| "distinct' (Step estep # t) =
     ((estep \<notin> steps t) \<and> distinct' t)"

lemma distinct'_append [simp]:
  "distinct' (t@t') =
   (distinct' t \<and> distinct' t' \<and>
    (knows t \<inter> knows t' = {}) \<and> (steps t \<inter> steps t' = {}))"
proof (induct t rule: distinct'.induct)
qed (auto intro!: knowsI)

lemma distinct'_singleton [iff]: "distinct' [x]"
by (cases x) auto

lemma (in reachable_state) distinct'_trace [iff]:
  "distinct' t"
proof(induct rule: reachable_induct)
  case (recv t r s i "done" l msg todo)
  then interpret this_thread:
    reachable_thread P t r s i "done" "Recv l msg # todo"
    by unfold_locales auto
  show ?case using `distinct' t` and this_thread.distinct
    by(auto dest!: this_thread.steps_in_done)
next
  case (send t r s i "done" l msg todo m)
  then interpret this_thread:
    reachable_thread P t r s i "done" "Send l msg # todo"
    by unfold_locales auto
  show ?case using `distinct' t` and this_thread.distinct
    by(auto dest!: this_thread.steps_in_done)
qed auto

subsection{* Happens-Before Order *}

datatype event = St "tid \<times> rolestep" | Ln execmsg

fun predOrd :: "explicit_trace \<Rightarrow> event \<Rightarrow> event \<Rightarrow> bool"
where
  "predOrd []             x y = False"
| "predOrd (Learns M # xs) x y =
     ((x \<in> Ln ` M \<and> (y \<in> Ln ` knows xs \<or> y \<in> St ` steps xs)) \<or>
      predOrd xs x y)"
| "predOrd (Step estep # xs) x y =
     ((x = St estep \<and> (y \<in> Ln ` knows xs \<or> y \<in> St ` steps xs)) \<or>
      predOrd xs x y)"

definition predEqOrd :: "explicit_trace \<Rightarrow> event \<Rightarrow> event \<Rightarrow> bool"
where "predEqOrd t x y = ((x = y) \<or> predOrd t x y)"

lemma predOrd_singleton [simp]: "\<not> predOrd [a] x y"
by (cases a) auto

lemma in_knows_predOrd1: "predOrd t (Ln x) y \<Longrightarrow> x \<in> knows t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_knows_predOrd2: "predOrd t x (Ln y) \<Longrightarrow> y \<in> knows t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_steps_predOrd1: "predOrd t (St x) y \<Longrightarrow> x \<in> steps t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemma in_steps_predOrd2: "predOrd t x (St y) \<Longrightarrow> y \<in> steps t"
proof (induct t)
  case (Cons e t) thus ?case by (cases e) auto
qed auto

lemmas event_predOrdI =
  in_knows_predOrd1 in_knows_predOrd2
  in_steps_predOrd1 in_steps_predOrd2

lemma in_set_predOrd1:
  "predOrd t x y \<Longrightarrow> x \<in> Ln ` knows t \<or> x \<in> St ` steps t"
by (induct t x y rule: predOrd.induct) auto

lemma in_set_predOrd2:
  "predOrd t x y \<Longrightarrow> y \<in> Ln ` knows t \<or> y \<in> St ` steps t"
by (induct t x y rule: predOrd.induct) auto

lemma listOrd_imp_predOrd:
  "listOrd t (Step e) (Step e') \<Longrightarrow> predOrd t (St e) (St e')"
by (induct t rule: steps.induct) (auto dest!: stepsI)

lemma predOrd_append [simp]:
  "predOrd (xs@ys) x y =
   (predOrd xs x y \<or> predOrd ys x y \<or>
   ((x \<in> Ln ` knows xs \<or> x \<in> St ` steps xs) \<and>
    (y \<in> Ln ` knows ys \<or> y \<in> St ` steps ys)))"
  apply(induct xs x y rule: predOrd.induct)
  apply(simp_all)
  apply(blast+)
  done

lemma predOrd_distinct'_irr [simp]:
  "distinct' t \<Longrightarrow> \<not>predOrd t x x"
  apply(induct t, auto)
  apply(case_tac x, auto)
  apply(case_tac a, auto)
  apply(case_tac a, auto)
  done

lemma predOrd_distinct'_trans:
  "\<lbrakk> predOrd t x y; predOrd t y z; distinct' t \<rbrakk>
   \<Longrightarrow> predOrd t x z"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

lemma predOrd_distinct'_asymD:
  "\<lbrakk> predOrd t x y; distinct' t \<rbrakk> \<Longrightarrow> \<not> predOrd t y x"
  apply(induct t x y rule: predOrd.induct)
  apply(auto dest: in_set_predOrd1 in_set_predOrd2)
  done

sublocale reachable_state \<subseteq> beforeOrd: order "predEqOrd t" "predOrd t"
  apply(unfold_locales)
  apply(auto simp: predEqOrd_def
          dest: predOrd_distinct'_asymD
         intro: predOrd_distinct'_trans)
  done

abbreviation (in reachable_state)
  "pred'"   (infixl "\<prec>" 50) where "pred' \<equiv> predOrd t"

abbreviation (in reachable_state)
  "predEq'" (infixl "\<preceq>" 50) where "predEq' \<equiv>  predEqOrd t"

lemma predOrd_conv:
  "predOrd xs x y =
  (\<exists> ys zs. xs = ys @ zs \<and>
            (x \<in> Ln ` knows ys \<or> x \<in> St ` steps ys) \<and>
            (y \<in> Ln ` knows zs \<or> y \<in> St ` steps zs))"
  (is "?pred xs = (\<exists> ys zs. ?decomp xs ys zs)")
proof -
  { assume "?pred xs"
    hence "\<exists> ys zs. ?decomp xs ys zs"
    proof (induct xs)
      case Nil thus ?case by simp
    next
      case (Cons e xs) thus ?case
      proof(cases e)
	case (Step st) thus ?thesis
	proof(cases "x = St st")
	  case True hence "?decomp (e#xs) [e] xs"
	    using Step Cons by auto
	  thus ?thesis by blast
	next
	  case False
	  hence "predOrd xs x y"
	    using Step Cons by auto
	  then obtain ys zs where "?decomp xs ys zs"
	    using Cons by auto
	  hence "?decomp (e#xs) (e#ys) zs"
	    using Step Cons by auto
	  thus ?thesis by blast
	qed
      next
	case (Learns M) thus ?thesis
	proof(cases "\<exists> m \<in> M. x = Ln m")
	  case True
	  then obtain m where "m \<in> M" and "x = Ln m"
	    by auto
	  hence "?decomp (e#xs) [e] xs"
	    using Learns Cons by auto
	  thus ?thesis by blast
	next
	  case False
	  hence "predOrd xs x y"
	    using Learns Cons by auto
	  then obtain ys zs where "?decomp xs ys zs"
	    using Cons by auto
	  hence "?decomp (e#xs) (e#ys) zs"
	    using Learns Cons by auto
	  thus ?thesis by blast
	qed
      qed
    qed
  }
  moreover
  { assume "\<exists> ys zs. ?decomp xs ys zs"
    hence "?pred xs"
    proof (induct xs)
      case Nil thus ?case by simp
    next
      case (Cons e xs)
      then obtain ys zs where decomp1: "?decomp (e#xs) ys zs"
	by blast
      hence "ys = [] \<and> e # xs = zs \<or> (\<exists>ys'. e # ys' = ys \<and> xs = ys' @ zs)"
	(is "?nil \<or> ?non_nil")
	by (simp add: Cons_eq_append_conv)
      moreover
      { assume ?nil hence ?case using decomp1 by auto }
      moreover
      { assume ?non_nil
	then obtain ys' where decomp2: "ys = e # ys'" and "xs = ys' @ zs"
	  by auto
	hence ?case
	proof(cases e)
	  case (Step st) thus ?thesis
	  proof(cases "x = St st")
	    case True thus ?thesis
	      using Step decomp1 decomp2 by auto
	  next
	    case False
	    hence "?decomp xs ys' zs"
	      using Step decomp1 decomp2 by auto
	    hence "predOrd xs x y"
	      using Cons by auto
	    thus ?thesis
	      using Step by auto
	  qed
	next
	  case (Learns M) thus ?thesis
	  proof(cases "\<exists> m \<in> M. x = Ln m")
	    case True thus ?thesis
	      using Learns decomp1 decomp2 by auto
	  next
	    case False
	    hence "?decomp xs ys' zs"
	      using Learns decomp1 decomp2 by auto
	    hence "predOrd xs x y"
	      using Cons by auto
	    thus ?thesis
	      using Learns by auto
	  qed
	qed
      }
      ultimately show ?case by fast
    qed
  }
  ultimately show ?thesis by fast
qed

subsection{* Input Terms *}

context reachable_state
begin

lemma knows_pairParts_closed:
  "m \<in> knows t \<Longrightarrow> pairParts m \<subseteq> knows t"
proof(induct arbitrary: m rule: reachable_induct)
  case init thus ?case by(auto simp: IK0_def)
next
  case send thus ?case by(auto dest: pairParts_idemD)
next
  case decr thus ?case by(auto dest: pairParts_idemD)
next
  case tuple thus ?case by fastsimp
qed auto

lemmas knows_pairParts_closedD =
  subsetD[OF knows_pairParts_closed, rule_format]

lemmas rev_knows_pairParts_closedD =
  rev_subsetD[OF _ knows_pairParts_closed, rule_format]

lemma pairParts_before:
  "\<lbrakk> predOrd t (Ln m) y; m' \<in> pairParts m \<rbrakk> \<Longrightarrow>
   predOrd t (Ln m') y"
proof(induct rule: reachable_induct)
  case (hash t r s msg)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from hash show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (encr t r s msg key)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from encr show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (tuple t r s msg1 msg2)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from tuple show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (decr t r s msg key)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from decr show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (send t r s i "done" l msg todo msg)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from send show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (recv t r s i "done" l msg todo)
  then interpret s1: reachable_state P t r s
    by unfold_locales
  from recv show ?case
    by (fastsimp dest: s1.rev_knows_pairParts_closedD)
next
  case (init r s) thus ?case by simp
qed

lemma Ln_before_inp:
  "(i, Recv l pt) \<in> steps t \<Longrightarrow>
   Ln (inst s i pt) \<prec> St (i, Recv l pt)"
proof(induct arbitrary: i l pt rule: reachable_induct)
qed auto

lemmas knows_inp = in_knows_predOrd1[OF Ln_before_inp, rule_format]

text{* Three of the lemmas for the reasoning technique. *}
lemmas Input = Ln_before_inp

lemma split_before:
  "Ln (Tup m m') \<prec> y \<Longrightarrow> Ln m \<prec> y \<and> Ln m' \<prec> y"
  by (fastsimp intro: pairParts_before)

lemma split_knows:
  "Tup m m' \<in> knows t \<Longrightarrow> m \<in> knows t \<and> m' \<in> knows t"
  by (fastsimp intro: knows_pairParts_closedD)

end

subsection{* Case Distinction on Learning Messages *}

text{* Note that the hints are logically equal to true. Thus they have no logical
  content. However they are placed here to track the individual cases when
  computing the decryption chains for a concrete message and protocol.
*}
fun decrChain :: "string \<Rightarrow> explicit_trace \<Rightarrow> event set \<Rightarrow> execmsg \<Rightarrow> execmsg \<Rightarrow> bool"
where
  "decrChain path t from (Enc msg key) m =
   ( ( m = Enc msg key \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
       hint ''decrChainPath'' path
     ) \<or>
     ( (\<forall> f \<in> from. predOrd t f (Ln (Enc msg key))) \<and>
       decrChain (path@''E'') t {Ln (Enc msg key), Ln (inv key)} msg m  )
   )"
| "decrChain path t from (Tup x y) m =
   ( ( m = Tup x y \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
       hint ''decrChainPath'' path
     ) \<or>
     decrChain (path@''L'') t from x m \<or>
     decrChain (path@''R'') t from y m
   )"
| "decrChain path t from msg m =
   ( m = msg \<and> (\<forall> f \<in> from. predOrd t f (Ln m)) \<and>
     hint ''decrChainPath'' path
   )"

lemma decrChain_append:
  "decrChain path t from msg m \<Longrightarrow> decrChain path (t@t') from msg m"
  by (induct path t "from" msg m rule: decrChain.induct) auto

lemma decrChain_unpair:
  "\<lbrakk> m' \<in> pairParts m; m' \<in> M;
     \<forall> f \<in> from. f \<in> Ln ` knows t \<or> f \<in> St ` steps t
   \<rbrakk> \<Longrightarrow> decrChain path (t@[Learns M]) from m m'"
by (induct m arbitrary: path M) (auto simp: remove_hints)

lemma decrChain_decrypt:
  "\<lbrakk> decrChain path t from msg (Enc m k);
     Enc m k \<in> knows t; inv k \<in> knows t;
     m' \<in> pairParts m; m' \<notin> knows t \<rbrakk> \<Longrightarrow>
   decrChain path' (t @ [Learns (pairParts m - knows t)]) from msg m'"
proof(induct msg arbitrary: path path' "from")
  case (Enc msg key)
  hence from_before [simp]:
    "\<forall>f\<in>from. predOrd t f (Ln (Enc msg key))" by auto
  have "m = msg \<and> k = key \<or>
    decrChain (path@''E'') t {Ln (Enc msg key), Ln (Message.inv key)} msg (Enc m k)"
    (is "?here \<or> ?nested")
    using Enc by auto
  moreover
  { assume "?here"
    hence "?case"
    proof(cases "m' = Enc m k")
      case True thus ?thesis
	using `?here` Enc by fastsimp
    next
      case False thus ?thesis
	using `?here` Enc
	by(auto intro!: decrChain_unpair)
    qed
  }
  moreover
  { assume "?nested"
    hence "?case" using Enc
      by (fastsimp dest!: Enc(2))
  }
  ultimately show ?case by fast
qed auto

lemma (in reachable_state) knows_cases_raw:
  assumes knows: "m' \<in> knows t"
  shows
   "(m' \<in> IK0) \<or>
    (\<exists> m.   m' = Hash m   \<and> Ln m \<prec> Ln (Hash m)) \<or>
    (\<exists> m k. m' = Enc  m k \<and> Ln m \<prec> Ln (Enc m k) \<and> Ln k \<prec> Ln (Enc m k)) \<or>
    (\<exists> x y. m' = Tup  x y \<and> Ln x \<prec> Ln (Tup x y) \<and> Ln y \<prec> Ln (Tup x y)) \<or>
    (\<exists> i done todo. r i = Some (done, todo) \<and>
       (\<exists> l pt.
          Send l pt \<in> set done \<and>
          decrChain [] t {St (i, Send l pt)} (inst s i pt) m'
       )
    )"
  (is "?cases m' t r s")
proof -
  --{* Prove cases transfer lemma for trace extension *}
  { fix m' t t' r s
    let ?thesis = "?cases m' (t@t') r s"
    assume "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
    moreover
    { assume "?ik0"  hence "?thesis" by blast }    moreover
    { assume "?hash" hence "?thesis" by fastsimp } moreover
    { assume "?enc"  hence "?thesis" by fastsimp } moreover
    { assume "?tup"  hence "?thesis" by fastsimp } moreover
    { assume "?chain t r s"
      hence "?chain (t@t') r s"
	by (fastsimp intro!: decrChain_append)
      hence "?thesis" by blast
    }
    ultimately have ?thesis by fast
  }
  note cases_appendI_trace = this

  --{* Prove actual thesis *}
  from knows show ?thesis
  proof (induct arbitrary: m' rule: reachable_induct)
    case init thus ?case by simp
  next
    case (hash t r s m)
    let ?t' = "t @ [Learns {Hash m}]"
    note IH = hash(2)
    have "m' \<in> knows t \<or> m' = Hash m" (is "?old \<or> ?new")
      using hash by fastsimp
    moreover
    { assume "?new" hence ?case
	using `m \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fastsimp intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (encr t r s m k)
    let ?t' = "t @ [Learns {Enc m k}]"
    note IH = encr(2)
    have "m' \<in> knows t \<or> m' = Enc m k" (is "?old \<or> ?new")
      using encr by fastsimp
    moreover
    { assume "?new" hence ?case
	using `m \<in> knows t` and `k \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (tuple t r s x y)
    let ?t' = "t @ [Learns {Tup x y}]"
    note IH = tuple(2)
    have "m' \<in> knows t \<or> m' = Tup x y" (is "?old \<or> ?new")
      using tuple by fastsimp
    moreover
    { assume "?new" hence ?case
	using `x \<in> knows t` and `y \<in> knows t` by fastsimp
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast
  next
    case (recv t r s i "done" l pt todo)
    hence "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
      by clarsimp
    moreover
    { assume "?ik0"  hence "?case" by blast    } moreover
    { assume "?hash" hence "?case" by fastsimp } moreover
    { assume "?enc"  hence "?case" by fastsimp } moreover
    { assume "?tup"  hence "?case" by fastsimp } moreover
    { let ?t' = "t@[Step (i, Recv l pt)]"
      and ?r' = "r(i \<mapsto> (done @ [Recv l pt], todo))"
      assume "?chain t r s" then
      obtain i' done' todo' l' pt'
	where thread': "r i' = Some (done', todo')"
	and send: "Send l' pt' \<in> set done'"
	and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') m'"
	by auto
      then interpret th1: reachable_thread P t r s i' done' todo'
	using recv by unfold_locales auto
      moreover
      obtain done'' todo''
	where "Send l' pt' \<in> set done''"
	and "?r' i' = Some (done'', todo'')"
	using `r i = Some (done, Recv l pt # todo)` thread' send
	by (cases "i = i'") (fastsimp+)
      ultimately
      have "?chain ?t' ?r' s"
	using chain
	apply-
	apply(rule exI)+
	apply(rule conjI, assumption)
	by(fastsimp intro!: decrChain_append)+
      hence "?case" by auto
    }
    ultimately show ?case by fast
  next
    case (send t r s i "done" l pt todo m)
    then interpret th1:
      reachable_thread P t r s i "done" "Send l pt # todo"
      by unfold_locales
    let ?r' = "r(i \<mapsto> (done @ [Send l pt], todo))"
    let ?m  = "inst s i pt"
    let ?t' = "(t @ [Step (i, Send l pt)]) @ [Learns (pairParts ?m - knows t)]"
    have "m' \<in> knows t \<or> m' \<in> pairParts m \<and> m' \<notin> knows t" (is "?old \<or> ?new")
      using send by fastsimp
    moreover
    { assume "?new"
      hence "m' \<in> pairParts (inst s i pt)" and "m' \<notin> knows t"
	using `m = inst s i pt` by auto
      hence "decrChain [] ?t' {St (i, Send l pt)} ?m m'"
	by (fastsimp intro!: decrChain_unpair)
      moreover
      have "?r' i = Some (done @ [Send l pt], todo)"
	using th1.thread_exists by auto
      ultimately
      have ?case using `m = inst s i pt`
	apply-
	apply(rule disjI2)+
	apply(rule exI)+
	apply(rule conjI, assumption)
	apply(auto)
	done
    }
    moreover
    { assume "?old"
      hence "?cases m' t r s" (is "?ik0 \<or> ?hash \<or> ?enc \<or> ?tup \<or> ?chain t r s")
	using send by clarsimp
      moreover
      { assume "?ik0"  hence "?case" by blast    } moreover
      { assume "?hash" hence "?case" by fastsimp } moreover
      { assume "?enc"  hence "?case" by fastsimp } moreover
      { assume "?tup"  hence "?case" by fastsimp } moreover
      { assume "?chain t r s" then
	obtain i' done' todo' l' pt'
	  where thread': "r i' = Some (done', todo')"
	  and send: "Send l' pt' \<in> set done'"
	  and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') m'"
	  by auto
	obtain done'' todo''
	  where "Send l' pt' \<in> set done''"
	  and "(r(i \<mapsto> (done @ [Send l pt], todo))) i' = Some (done'', todo'')"
	  using `r i = Some (done, Send l pt # todo)` thread' send
	  by (cases "i = i'") (fastsimp+)
	hence "?chain ?t' ?r' s"
	  using chain
	  apply-
	  apply(rule exI)+
	  apply(rule conjI, assumption)
	  by(fastsimp intro!: decrChain_append)+
	hence "?case" using `m = inst s i pt` by auto
      }
      ultimately have ?case by fast
    }
    ultimately show ?case by fast
  next
    case (decr t r s m k)
    then interpret s1: reachable_state P t r s
      by unfold_locales
    let ?t' = "t @ [Learns (pairParts m - knows t)]"
    note IH = decr(2)
    have "m' \<in> knows t \<or> m' \<in> pairParts m \<and> m' \<notin> knows t" (is "?old \<or> ?new")
      using decr by fastsimp
    moreover
    { assume "?new"
      hence "m' \<in> pairParts m" and "m' \<notin> knows t" by auto
      have
	"predOrd t (Ln m) (Ln (Enc m k)) \<and> predOrd t (Ln k) (Ln (Enc m k)) \<or>
        (\<exists>i done todo. r i = Some (done, todo) \<and>
          (\<exists>l pt. Send l pt \<in> set done \<and>
                  decrChain [] t {St (i, Send l pt)} (inst s i pt) (Enc m k)))"
	(is "?fake_enc \<or> ?chain t (Enc m k)")
	using IH[OF `Enc m k \<in> knows t`] by auto
      moreover
      { assume "?fake_enc"
	hence "?case" using `?new`
	  by (auto dest!: in_knows_predOrd1 s1.rev_knows_pairParts_closedD)
      }
      moreover
      { assume "?chain t (Enc m k)" then
	obtain i' done' todo' l' pt'
	  where thread': "r i' = Some (done', todo')"
	  and send: "Send l' pt' \<in> set done'"
	  and chain: "decrChain [] t {St (i', Send l' pt')} (inst s i' pt') (Enc m k)"
	  by auto
	moreover
	hence "decrChain [] ?t' {St (i', Send l' pt')} (inst s i' pt') m'"
	  using `?new` `Enc m k \<in> knows t` `inv k \<in> knows t`
	  by (fastsimp intro!: decrChain_decrypt)
	ultimately
	have "?chain ?t' m'" by fastsimp
	hence "?case" by blast
      }
      ultimately have ?case by fast
    }
    moreover
    { assume "?old"
      hence ?case by (fast intro!: IH cases_appendI_trace)
    }
    ultimately show ?case by fast thm decr
  qed
qed

end


theory ConditionalMode

imports  Complex_Main FaultModellingTypes

begin

datatype_new ('a, 'b) ConditionalValue =
  CVC (V: 'b)
  | CVIF 'a "('a, 'b) ConditionalValue" "('a, 'b) ConditionalValue"

datatype_new ('FMode, 'vv) OperationalMode =
  NominalMode real
  | FailureMode "'FMode"
  | VarMode (var: 'vv)

type_synonym ('a, 'FMode, 'vv) ConditionalMode =
  "('a, ('FMode, 'vv) OperationalMode) ConditionalValue"

notation (output) NominalMode ("N\<langle>_\<rangle>" 40)
notation (output) FailureMode ("F\<langle>_\<rangle>" 41)
notation (output) VarMode ("_" 41)
notation (output) CVC  ("\<guillemotleft>_\<guillemotright>" 50)
notation (output) CVIF ("_ \<surd> _ \<oslash> _" 80)

primrec val_ConditionalValue :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow> 'b" where
"val_ConditionalValue _ (CVC b) = b" |
"val_ConditionalValue s (CVIF a t1 t2) =
  (if s a then val_ConditionalValue s t1 else val_ConditionalValue s t2)"

type_synonym 'a ConditionalValueEnv = "('a * bool) list"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a ConditionalValueEnv \<Rightarrow> bool" where
"agree s env = (\<forall>x b. map_of env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil: "agree s []"
by(simp add: agree_def)

lemma agree_Cons: "distinct(map fst env) \<Longrightarrow> x \<notin> set(map fst env)
  \<Longrightarrow> agree s ((x,b) # env) = ((if b then s x else \<not> s x) \<and> agree s env)"
by(auto simp: agree_def image_iff)

lemma agreeDT:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,True) \<in> set env \<Longrightarrow> s x"
by(simp add: agree_def)

lemma agreeDF:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,False) \<in> set env \<Longrightarrow> \<not> s x"
by(simp add: agree_def)

definition mkIF :: "'a \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow>
  ('a, 'b) ConditionalValue" where
"mkIF x t1 t2 = (if t1 = t2 then t1 else CVIF x t1 t2)"

fun reduce :: "'a ConditionalValueEnv \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow>
  ('a, 'b) ConditionalValue" where
"reduce env (CVIF x t1 t2) = (case map_of env x of
     None \<Rightarrow> mkIF x (reduce ((x,True)#env) t1) (reduce ((x,False)#env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))" |
"reduce _ t = t"

primrec normif :: "'a ConditionalValueEnv \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow>
  ('a, 'b) ConditionalValue \<Rightarrow> ('a, 'b) ConditionalValue \<Rightarrow> ('a, 'b) ConditionalValue" where
"normif env (CVC b) t1 t2 = CVC b" |
"normif env (CVIF x t1 t2) t3 t4 =
  (case map_of env x of
     None \<Rightarrow> mkIF x (normif ((x,True) # env) t1 t3 t4) (normif ((x,False) # env) t2 t3 t4) |
     Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

lemma val_mkIF: "val_ConditionalValue s (mkIF x t1 t2) = val_ConditionalValue s (CVIF x t1 t2)"
apply (auto simp: mkIF_def Let_def)
done

theorem val_reduce: "agree s env \<Longrightarrow> distinct(map fst env) \<Longrightarrow>
  val_ConditionalValue s (reduce env t) = val_ConditionalValue s t"
apply(induct t arbitrary: s env)
apply(auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def
  dest: agreeDT agreeDF split: option.splits)
done

fun reduced :: "('a, 'b) ConditionalValue \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (CVIF x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono: "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"
apply(induction t arbitrary: X Y)
by auto (metis insert_mono)+

lemma reduced_mkIF: "x \<notin> X \<Longrightarrow>
  reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
by(auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "distinct(map fst env) \<Longrightarrow> reduced (reduce env t) (fst ` set env)"
proof(induction t arbitrary: env)
  case (CVIF x t1 t2)
  thus ?case using CVIF.IH(1)[of "(x, True) # env"] CVIF.IH(2)[of "(x, False) # env"]
    by(auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
qed auto

lemma reduced_normif:
  "distinct(map fst env) \<Longrightarrow> reduced (normif env t t1 t2) (fst ` set env)"
proof(induction t arbitrary: t1 t2 env)
  case (CVIF x s1 s2)
  thus ?case using CVIF.IH(1)[of "(x, True) # env"] CVIF.IH(2)[of "(x, False) # env"]
    by(auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
qed (auto simp: reduced_reduce)

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow>
  val_ConditionalValue s1 t = val_ConditionalValue s2 t"
by(induction t arbitrary: X) auto

(*
datatype 'a ConditionalValuePredicateEvaluation =
  CVPTrue | CVPFalse | CVPVar 'a | CVPNotVar 'a
  | CVPAnd "'a ConditionalValuePredicateEvaluation" "'a ConditionalValuePredicateEvaluation"
*)

end


(*  Title:      HOL/Bali/Type.thy
    Author:     David von Oheimb
*)

subsection {* Java types *}

theory Type imports Name begin

text {*
simplifications:
\begin{itemize}
\item only the most important primitive types
\item the null type is regarded as reference type
\end{itemize}
*}

datatype prim_ty        --{* primitive type, cf. 4.2 *}
        = Void          --{* result type of void methods *}
        | Boolean
        | Integer

datatype ref_ty         --{* reference type, cf. 4.3 *}
        = NullT         --{* null type, cf. 4.1 *}
        | IfaceT qtname --{* interface type *}
        | ClassT qtname --{* class type *}
        | ArrayT ty     --{* array type *}

and ty                  --{* any type, cf. 4.1 *}
        = PrimT prim_ty --{* primitive type *}
        | RefT  ref_ty  --{* reference type *}

abbreviation "NT == RefT NullT"
abbreviation "Iface I == RefT (IfaceT I)"
abbreviation "Class C == RefT (ClassT C)"
abbreviation Array :: "ty \<Rightarrow> ty"  ("_.[]" [90] 90)
  where "T.[] == RefT (ArrayT T)"

definition
  the_Class :: "ty \<Rightarrow> qtname"
  where "the_Class T = (SOME C. T = Class C)" (** primrec not possible here **)

lemma the_Class_eq [simp]: "the_Class (Class C)= C"
by (auto simp add: the_Class_def)

end