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

  Project: Development of Security Protocols by Refinement

  Module:  Auth_simple/m1_auth.thy (Isabelle/HOL 2016-1)
  ID:      $Id: m1_auth.thy 134925 2017-05-24 17:53:14Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  One-Way authentication protocols
  Refinement 1: Direct memory access protocol

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

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

chapter \<open>Unidirectional Authentication Protocols\<close>

text \<open>In this chapter, we derive some simple unilateral authentication
protocols. We have a single abstract model at Level 1. We then refine this model
into two channel protocols (Level 2), one using authentic channels and one using
confidential channels. We then refine these in turn into cryptographic protocols
(Level 3) respectively using signatures and public-key encryption.
\<close>

section \<open>Refinement 1: Abstract Protocol\<close>

theory m1_auth imports "../Refinement/Runs" "../Refinement/a0i_agree"
begin

(* declare option.split_asm [split] *)
declare domIff [simp, iff del]

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

text \<open>We introduce protocol runs.\<close>

record m1_state =
  runs :: runs_t

type_synonym
  m1_obs = m1_state

definition
  m1_init :: "m1_state set" where
  "m1_init \<equiv> { \<lparr>
     runs = Map.empty
  \<rparr> }"

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

definition   \<comment> \<open>refines @{term skip}\<close>
  m1_step1 :: "[rid_t, agent, agent, nonce] \<Rightarrow> (m1_state \<times> m1_state) set"
where
  "m1_step1 Ra A B Na \<equiv> {(s, s1).

     \<comment> \<open>guards\<close>
     Ra \<notin> dom (runs s) \<and>              \<comment> \<open>new initiator run\<close>
     Na = Ra$0 \<and>                      \<comment> \<open>generated nonce\<close>

     \<comment> \<open>actions\<close>
     s1 = s\<lparr>
       runs := (runs s)(
         Ra \<mapsto> (Init, [A, B], [])
       )
     \<rparr>
  }"

definition   \<comment> \<open>refines @{term a0i_running}\<close>
  m1_step2 :: "[rid_t, agent, agent, nonce, nonce] \<Rightarrow> (m1_state \<times> m1_state) set"
where
  "m1_step2 Rb A B Na Nb \<equiv> {(s, s1).  \<comment> \<open>\<open>Ni\<close> is completely arbitrary\<close>

     \<comment> \<open>guards\<close>
     Rb \<notin> dom (runs s) \<and>              \<comment> \<open>new responder run\<close>
     Nb = Rb$0 \<and>                      \<comment> \<open>generated nonce\<close>

     \<comment> \<open>actions\<close>
     s1 = s\<lparr>
       runs := (runs s)(Rb \<mapsto> (Resp, [A, B], [aNon Na]))
     \<rparr>
  }"

definition   \<comment> \<open>refines @{term a0i_commit}\<close>
  m1_step3 ::
    "[rid_t, agent, agent, nonce, nonce] \<Rightarrow> (m1_state \<times> m1_state) set"
where
  "m1_step3 Ra A B Na Nb \<equiv> {(s, s1).

     \<comment> \<open>guards\<close>
     runs s Ra = Some (Init, [A, B], []) \<and>
     Na = Ra$0 \<and>

     \<comment> \<open>authentication guard:\<close>
     (A \<notin> bad \<and> B \<notin> bad \<longrightarrow> (\<exists>Rb.
        Nb = Rb$0 \<and> runs s Rb = Some (Resp, [A, B], [aNon Na]))) \<and>

     \<comment> \<open>actions\<close>
     s1 = s\<lparr>
       runs := (runs s)(Ra \<mapsto> (Init, [A, B], [aNon Nb]))
     \<rparr>
  }"

text \<open>Transition system.\<close>

definition
  m1_trans :: "(m1_state \<times> m1_state) set" where
  "m1_trans \<equiv> (\<Union> A B Ra Rb Na Nb.
     m1_step1 Ra A B Na    \<union>
     m1_step2 Rb A B Na Nb \<union>
     m1_step3 Ra A B Na Nb \<union>
     Id
  )"

definition
  m1 :: "(m1_state, m1_obs) spec" where
  "m1 \<equiv> \<lparr>
    init = m1_init,
    trans = m1_trans,
    obs = id
  \<rparr>"

lemmas m1_defs =
  m1_def m1_init_def m1_trans_def
  m1_step1_def m1_step2_def m1_step3_def

(******************************************************************************)
subsection \<open>Simulation relation\<close>
(******************************************************************************)

text \<open>We define two auxiliary functions to reconstruct the signals of the
initial model from completed initiator and responder runs of the current one.\<close>

type_synonym
  irsig = "nonce \<times> nonce"

fun
  runs2sigs :: "runs_t \<Rightarrow> irsig signal \<Rightarrow> nat"
where
  "runs2sigs runz (Commit [A, B] (Ra$0, Nb)) =
    (if runz Ra = Some (Init, [A, B], [aNon Nb]) then 1 else 0)"

| "runs2sigs runz (Running [A, B] (Na, Rb$0)) =
    (if runz Rb = Some (Resp, [A, B], [aNon Na]) then 1 else 0)"

| "runs2sigs runz _ = 0"

text \<open>Simulation relation and mediator function. We map completed initiator
and responder runs to commit and running signals, respectively.\<close>

definition
  med10 :: "m1_obs \<Rightarrow> irsig a0i_obs" where
  "med10 o1 \<equiv> \<lparr> signals = runs2sigs (runs o1), corrupted = {} \<rparr>"

definition
  R01 :: "(irsig a0i_state \<times> m1_state) set" where
  "R01 \<equiv> {(s, t). signals s = runs2sigs (runs t) \<and> corrupted s = {} }"

lemmas R01_defs = R01_def med10_def

subsubsection \<open>Lemmas about the auxiliary functions\<close>
(******************************************************************************)

text \<open>Basic lemmas\<close>

lemma runs2sigs_empty [simp]:
  "runz = Map.empty \<Longrightarrow> runs2sigs runz = (\<lambda>x. 0)"
by (rule ext, erule rev_mp)
   (rule runs2sigs.induct, auto)

text \<open>Update lemmas\<close>

lemma runs2sigs_upd_init_none [simp]:
  "\<lbrakk> Ra \<notin> dom runz \<rbrakk>
  \<Longrightarrow> runs2sigs (runz(Ra \<mapsto> (Init, [A, B], []))) = runs2sigs runz"
by (rule ext, erule rev_mp)
   (rule runs2sigs.induct, auto dest: dom_lemmas)

lemma runs2sigs_upd_init_some [simp]:
  "\<lbrakk> runz Ra = Some (Init, [A, B], []) \<rbrakk>
  \<Longrightarrow> runs2sigs (runz(Ra \<mapsto> (Init, [A, B], [aNon Nb]))) =
     (runs2sigs runz)(Commit [A, B] (Ra$0, Nb) := 1)"
by (rule ext, erule rev_mp)
   (rule runs2sigs.induct, auto)

lemma runs2sigs_upd_resp [simp]:
  "\<lbrakk> Rb \<notin> dom runz \<rbrakk>
  \<Longrightarrow> runs2sigs (runz(Rb \<mapsto> (Resp, [A, B], [aNon Na]))) =
     (runs2sigs runz)(Running [A, B] (Na, Rb$0) := 1)"
by (rule ext, (erule rev_mp)+)
   (rule runs2sigs.induct, auto dest: dom_lemmas)

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

lemma PO_m1_step1_refines_skip:
  "{R01}
     Id, (m1_step1 Ra A B Na)
   {> R01}"
by (auto simp add: PO_rhoare_def R01_defs a0i_defs m1_defs)

lemma PO_m1_step2_refines_a0i_running:
  "{R01}
     (a0i_running [A, B] (Na, Nb)), (m1_step2 Rb A B Na Nb)
   {> R01}"
by (auto simp add: PO_rhoare_defs R01_defs a0i_defs m1_defs dest: dom_lemmas)

lemma PO_m1_step3_refines_a0i_commit:
  "{R01}
     (a0i_commit [A, B] (Na, Nb)), (m1_step3 Ra A B Na Nb)
   {> R01}"
by (auto simp add: PO_rhoare_defs R01_defs a0i_defs m1_defs)

lemmas PO_m1_trans_refines_a0i_trans =
  PO_m1_step1_refines_skip PO_m1_step2_refines_a0i_running
  PO_m1_step3_refines_a0i_commit

text \<open>All together now...\<close>

lemma PO_m1_refines_init_a0i [iff]:
  "init m1 \<subseteq> R01``(init a0i)"
by (auto simp add: R01_defs a0i_defs m1_defs)

lemma PO_m1_refines_trans_a0i [iff]:
  "{R01}
     (trans a0i), (trans m1)
   {> R01}"
by (auto simp add: m1_def m1_trans_def a0i_def a0i_trans_def
         intro!: PO_m1_trans_refines_a0i_trans)

lemma PO_obs_consistent [iff]:
  "obs_consistent R01 med10 a0i m1"
by (auto simp add: obs_consistent_def R01_defs a0i_def m1_def)

lemma PO_m1_refines_a0i:
  "refines R01 med10 a0i m1"
by (rule Refinement_basic) (auto)

end


(*  Title:       variants/a_norreqid/Aodv_Loop_Freedom.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Lift and transfer invariants to show loop freedom"

theory A_Aodv_Loop_Freedom
imports AWN.OClosed_Transfer AWN.Qmsg_Lifting A_Global_Invariants A_Loop_Freedom
begin

text \<open>lift to parallel processes with queues\<close>

lemma par_step_no_change_on_send_or_receive:
    fixes \<sigma> s a \<sigma>' s'
  assumes "((\<sigma>, s), a, (\<sigma>', s')) \<in> oparp_sos i (oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i) (seqp_sos \<Gamma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G)"
      and "a \<noteq> \<tau>"
    shows "\<sigma>' i = \<sigma> i"
  using assms by (rule qmsg_no_change_on_send_or_receive)

lemma par_nhop_quality_increases:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile> (otherwith ((=)) {i} (orecvmsg (\<lambda>\<sigma> m.
                                    msg_fresh \<sigma> m \<and> msg_zhops m)),
                                  other quality_increases {i} \<rightarrow>)
                        global (\<lambda>\<sigma>. \<forall>dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
    proof (rule lift_into_qmsg [OF seq_nhop_quality_increases])
    show "opaodv i \<Turnstile>\<^sub>A (otherwith ((=)) {i}
                         (orecvmsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
                        other quality_increases {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
    proof (rule ostep_invariant_weakenE [OF oquality_increases], simp_all)
      fix t :: "(((nat \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp), msg seq_action) transition"
      assume "onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<sigma>, _), _, (\<sigma>', _)). \<forall>j. quality_increases (\<sigma> j) (\<sigma>' j)) t"
      thus "quality_increases (fst (fst t) i) (fst (snd (snd t)) i)"
        by (cases t) (clarsimp dest!: onllD, metis aodv_ex_label)
    next
      fix \<sigma> \<sigma>' a
      assume "otherwith ((=)) {i}
                (orecvmsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)) \<sigma> \<sigma>' a"
      thus "otherwith quality_increases {i} (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma> \<sigma>' a"
        by - (erule weaken_otherwith, auto)
    qed
  qed auto

lemma par_rreq_rrep_sn_quality_increases:
  "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
  proof -
    have "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF olocal_quality_increases])
         (auto dest!: onllD seqllD elim!: aodv_ex_labelE)
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                   globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

lemma par_rreq_rrep_nsqn_fresh_any_step:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                   other (\<lambda>_ _. True) {i} \<rightarrow>)
                                  globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
  proof -
    have "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
    proof (rule ostep_invariant_weakenE [OF rreq_rrep_nsqn_fresh_any_step_invariant])
      fix t
      assume "onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>((\<sigma>, _), a, _). anycast (msg_fresh \<sigma>) a) t"
      thus "globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a) t"
        by (cases t) (clarsimp dest!: onllD, metis aodv_ex_label)
    qed auto
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. (orecvmsg (\<lambda>_. rreq_rrep_sn)) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                    globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (msg_fresh \<sigma>) a)"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

lemma par_anycast_msg_zhops:
  shows "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                  globala (\<lambda>(_, a, _). anycast msg_zhops a)"
  proof -
    from anycast_msg_zhops initiali_aodv oaodv_trans aodv_trans
      have "opaodv i \<Turnstile>\<^sub>A (act TT, other (\<lambda>_ _. True) {i} \<rightarrow>)
                         seqll i (onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a))"
        by (rule open_seq_step_invariant)
    hence "opaodv i \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(_, a, _). anycast msg_zhops a)"
    proof (rule ostep_invariant_weakenE)
      fix t :: "(((nat \<Rightarrow> state) \<times> (state, msg, pseqp, pseqp label) seqp), msg seq_action) transition"
      assume "seqll i (onll \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V (\<lambda>(_, a, _). anycast msg_zhops a)) t"
      thus "globala (\<lambda>(_, a, _). anycast msg_zhops a) t"
        by (cases t) (clarsimp dest!: seqllD onllD, metis aodv_ex_label)
    qed simp_all
    hence "opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                                     globala (\<lambda>(_, a, _). anycast msg_zhops a)"
      by (rule lift_step_into_qmsg_statelessassm) simp_all
    thus ?thesis by rule auto
  qed

subsection \<open>Lift to nodes\<close>

lemma node_step_no_change_on_send_or_receive:
  assumes "((\<sigma>, NodeS i P R), a, (\<sigma>', NodeS i' P' R')) \<in> onode_sos
                                      (oparp_sos i (oseqp_sos \<Gamma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i) (seqp_sos \<Gamma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G))"
      and "a \<noteq> \<tau>"
    shows "\<sigma>' i = \<sigma> i"
  using assms
  by (cases a) (auto elim!: par_step_no_change_on_send_or_receive)

lemma node_nhop_quality_increases:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>
           (otherwith ((=)) {i}
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
              other quality_increases {i}
            \<rightarrow>) global (\<lambda>\<sigma>. \<forall>dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                  in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                     \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  by (rule node_lift [OF par_nhop_quality_increases]) auto

lemma node_quality_increases:
  "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                         other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). quality_increases (\<sigma> i) (\<sigma>' i))"
  by (rule node_lift_step_statelessassm [OF par_rreq_rrep_sn_quality_increases]) simp

lemma node_rreq_rrep_nsqn_fresh_any_step:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A
          (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (msg_fresh \<sigma>) a)"
  by (rule node_lift_anycast_statelessassm [OF par_rreq_rrep_nsqn_fresh_any_step])

lemma node_anycast_msg_zhops:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R \<rangle>\<^sub>o \<Turnstile>\<^sub>A
          (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(_, a, _). castmsg msg_zhops a)"
  by (rule node_lift_anycast_statelessassm [OF par_anycast_msg_zhops])

lemma node_silent_change_only:
  shows "\<langle> i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i \<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_ _. True) \<sigma>,
                                               other (\<lambda>_ _. True) {i} \<rightarrow>)
          globala (\<lambda>(\<sigma>, a, \<sigma>'). a \<noteq> \<tau> \<longrightarrow> \<sigma>' i = \<sigma> i)"
  proof (rule ostep_invariantI, simp (no_asm), rule impI)
    fix \<sigma> \<zeta> a \<sigma>' \<zeta>'
    assume or: "(\<sigma>, \<zeta>) \<in> oreachable (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o)
                                    (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_ _. True) \<sigma>)
                                    (other (\<lambda>_ _. True) {i})"
      and tr: "((\<sigma>, \<zeta>), a, (\<sigma>', \<zeta>')) \<in> trans (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<^sub>i\<rangle>\<^sub>o)"
      and "a \<noteq> \<tau>\<^sub>n"
    from or obtain p R where "\<zeta> = NodeS i p R"
      by - (drule node_net_state, metis)
    with tr have "((\<sigma>, NodeS i p R), a, (\<sigma>', \<zeta>'))
                     \<in> onode_sos (oparp_sos i (trans (opaodv i)) (trans qmsg))"
      by simp
    thus "\<sigma>' i = \<sigma> i" using \<open>a \<noteq> \<tau>\<^sub>n\<close>
      by (cases rule: onode_sos.cases)
         (auto elim: qmsg_no_change_on_send_or_receive)
  qed

subsection \<open>Lift to partial networks\<close>

lemma arrive_rreq_rrep_nsqn_fresh_inc_sn [simp]:
  assumes "oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> P \<sigma> m) \<sigma> m"
    shows "oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma> m"
  using assms by (cases m) auto

lemma opnet_nhop_quality_increases:
  shows "opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p \<Turnstile>
           (otherwith ((=)) (net_tree_ips p)
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)),
               other quality_increases (net_tree_ips p) \<rightarrow>)
              global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips p. \<forall>dip.
                          let nhip = the (nhop (rt (\<sigma> i)) dip)
                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  proof (rule pnet_lift [OF node_nhop_quality_increases])
    fix i R
    have "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>,
                                              other (\<lambda>_ _. True) {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
            castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a)"
    proof (rule ostep_invariantI, simp (no_asm))
      fix \<sigma> s a \<sigma>' s'
      assume or: "(\<sigma>, s) \<in> oreachable (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o)
                                      (\<lambda>\<sigma> _. oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma>)
                                      (other (\<lambda>_ _. True) {i})"
         and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o)"
         and am: "oarrivemsg (\<lambda>_. rreq_rrep_sn) \<sigma> a"
      from or tr am have "castmsg (msg_fresh \<sigma>) a"
        by (auto dest!: ostep_invariantD [OF node_rreq_rrep_nsqn_fresh_any_step])
      moreover from or tr am have "castmsg (msg_zhops) a"
        by (auto dest!: ostep_invariantD [OF node_anycast_msg_zhops])
      ultimately show "castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a"
        by (case_tac a) auto
    qed
    thus "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, _).
               castmsg (\<lambda>m. msg_fresh \<sigma> m \<and> msg_zhops m) a)"
      by rule auto
  next
    fix i R
    show "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
               a \<noteq> \<tau> \<and> (\<forall>d. a \<noteq> i:deliver(d)) \<longrightarrow> \<sigma> i = \<sigma>' i)"
      by (rule ostep_invariant_weakenE [OF node_silent_change_only]) auto
  next
    fix i R
    show "\<langle>i : opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg : R\<rangle>\<^sub>o \<Turnstile>\<^sub>A
            (\<lambda>\<sigma> _. oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma>,
             other quality_increases {i} \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>').
               a = \<tau> \<or> (\<exists>d. a = i:deliver(d)) \<longrightarrow> quality_increases (\<sigma> i) (\<sigma>' i))"
      by (rule ostep_invariant_weakenE [OF node_quality_increases]) auto
  qed simp_all

subsection \<open>Lift to closed networks\<close>

lemma onet_nhop_quality_increases:
  shows "oclosed (opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p)
           \<Turnstile> (\<lambda>_ _ _. True, other quality_increases (net_tree_ips p) \<rightarrow>)
              global (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips p. \<forall>dip.
                          let nhip = the (nhop (rt (\<sigma> i)) dip)
                          in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                             \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
  (is "_ \<Turnstile> (_, ?U \<rightarrow>) ?inv")
  proof (rule inclosed_closed)
    from opnet_nhop_quality_increases
      show "opnet (\<lambda>i. opaodv i \<langle>\<langle>\<^bsub>i\<^esub> qmsg) p
               \<Turnstile> (otherwith ((=)) (net_tree_ips p) inoclosed, ?U \<rightarrow>) ?inv"
    proof (rule oinvariant_weakenE)
      fix \<sigma> \<sigma>' :: "ip \<Rightarrow> state" and a :: "msg node_action"
      assume "otherwith ((=)) (net_tree_ips p) inoclosed \<sigma> \<sigma>' a"
      thus "otherwith ((=)) (net_tree_ips p)
              (oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m)) \<sigma> \<sigma>' a"
      proof (rule otherwithEI)
        fix \<sigma> :: "ip \<Rightarrow> state" and a :: "msg node_action"
        assume "inoclosed \<sigma> a"
        thus "oarrivemsg (\<lambda>\<sigma> m. msg_fresh \<sigma> m \<and> msg_zhops m) \<sigma> a"
        proof (cases a)
          fix ii ni ms
          assume "a = ii\<not>ni:arrive(ms)"
          moreover with \<open>inoclosed \<sigma> a\<close> obtain d di where "ms = newpkt(d, di)"
            by (cases ms) auto
          ultimately show ?thesis by simp
        qed simp_all
      qed
    qed
  qed

subsection \<open>Transfer into the standard model\<close>

interpretation aodv_openproc: openproc paodv opaodv id
  rewrites "aodv_openproc.initmissing = initmissing"
  proof -
    show "openproc paodv opaodv id"
    proof unfold_locales
      fix i :: ip
      have "{(\<sigma>, \<zeta>). (\<sigma> i, \<zeta>) \<in> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V i \<and> (\<forall>j. j \<noteq> i \<longrightarrow> \<sigma> j \<in> fst ` \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V j)} \<subseteq> \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'"
        unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V'_def
        proof (rule equalityD1)
          show "\<And>f p. {(\<sigma>, \<zeta>). (\<sigma> i, \<zeta>) \<in> {(f i, p)} \<and> (\<forall>j. j \<noteq> i
                      \<longrightarrow> \<sigma> j \<in> fst ` {(f j, p)})} = {(f, p)}"
            by (rule set_eqI) auto
        qed
      thus "{ (\<sigma>, \<zeta>) |\<sigma> \<zeta> s. s \<in> init (paodv i)
                             \<and> (\<sigma> i, \<zeta>) = id s
                             \<and> (\<forall>j. j\<noteq>i \<longrightarrow> \<sigma> j \<in> (fst o id) ` init (paodv j)) } \<subseteq> init (opaodv i)"
        by simp
    next
      show "\<forall>j. init (paodv j) \<noteq> {}"
        unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def by simp
    next
      fix i s a s' \<sigma> \<sigma>'
      assume "\<sigma> i = fst (id s)"
         and "\<sigma>' i = fst (id s')"
         and "(s, a, s') \<in> trans (paodv i)"
      then obtain q q' where "s = (\<sigma> i, q)"
                         and "s' = (\<sigma>' i, q')"
                         and "((\<sigma> i, q), a, (\<sigma>' i, q')) \<in> trans (paodv i)"
         by (cases s, cases s') auto
      from this(3) have "((\<sigma>, q), a, (\<sigma>', q')) \<in> trans (opaodv i)"
        by simp (rule open_seqp_action [OF aodv_wf])

      with \<open>s = (\<sigma> i, q)\<close> and \<open>s' = (\<sigma>' i, q')\<close>
        show "((\<sigma>, snd (id s)), a, (\<sigma>', snd (id s'))) \<in> trans (opaodv i)"
          by simp
    qed
    then interpret opn: openproc paodv opaodv id .
    have [simp]: "\<And>i. (SOME x. x \<in> (fst o id) ` init (paodv i)) = aodv_init i"
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def by simp
    hence "\<And>i. openproc.initmissing paodv id i = initmissing i"
      unfolding opn.initmissing_def opn.someinit_def initmissing_def
      by (auto split: option.split)
    thus "openproc.initmissing paodv id = initmissing" ..
  qed

interpretation aodv_openproc_par_qmsg: openproc_parq paodv opaodv id qmsg
  rewrites "aodv_openproc_par_qmsg.netglobal = netglobal"
    and "aodv_openproc_par_qmsg.initmissing = initmissing"
  proof -
    show "openproc_parq paodv opaodv id qmsg"
      by (unfold_locales) simp
    then interpret opq: openproc_parq paodv opaodv id qmsg .

    have im: "\<And>\<sigma>. openproc.initmissing (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) \<sigma>
                                                                                = initmissing \<sigma>"
      unfolding opq.initmissing_def opq.someinit_def initmissing_def
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G_def by (clarsimp cong: option.case_cong)
    thus "openproc.initmissing (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) = initmissing"
      by (rule ext)
    have "\<And>P \<sigma>. openproc.netglobal (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) P \<sigma>
                                                                                = netglobal P \<sigma>"
      unfolding opq.netglobal_def netglobal_def opq.initmissing_def initmissing_def opq.someinit_def
      unfolding \<sigma>\<^sub>A\<^sub>O\<^sub>D\<^sub>V_def \<sigma>\<^sub>Q\<^sub>M\<^sub>S\<^sub>G_def
      by (clarsimp cong: option.case_cong
                   simp del: One_nat_def
                   simp add: fst_initmissing_netgmap_default_aodv_init_netlift
                                                  [symmetric, unfolded initmissing_def])
    thus "openproc.netglobal (\<lambda>i. paodv i \<langle>\<langle> qmsg) (\<lambda>(p, q). (fst (id p), snd (id p), q)) = netglobal"
      by auto
  qed

lemma net_nhop_quality_increases:
  assumes "wf_net_tree n"
  shows "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal
                           (\<lambda>\<sigma>. \<forall>i dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                                        in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                            \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
        (is "_ \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i. ?inv \<sigma> i)")
  proof -
    from \<open>wf_net_tree n\<close>
      have proto: "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>i\<in>net_tree_ips n. \<forall>dip.
                                            let nhip = the (nhop (rt (\<sigma> i)) dip)
                                            in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                                                \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip)))"
        by (rule aodv_openproc_par_qmsg.close_opnet [OF _ onet_nhop_quality_increases])
    show ?thesis
    unfolding invariant_def opnet_sos.opnet_tau1
    proof (rule, simp only: aodv_openproc_par_qmsg.netglobalsimp
                            fst_initmissing_netgmap_pair_fst, rule allI)
      fix \<sigma> i
      assume sr: "\<sigma> \<in> reachable (closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n)) TT"
      hence "\<forall>i\<in>net_tree_ips n. ?inv (fst (initmissing (netgmap fst \<sigma>))) i"
        by - (drule invariantD [OF proto],
              simp only: aodv_openproc_par_qmsg.netglobalsimp
                         fst_initmissing_netgmap_pair_fst)
      thus "?inv (fst (initmissing (netgmap fst \<sigma>))) i"
      proof (cases "i\<in>net_tree_ips n")
        assume "i\<notin>net_tree_ips n"
        from sr have "\<sigma> \<in> reachable (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) TT" ..
        hence "net_ips \<sigma> = net_tree_ips n" ..
        with \<open>i\<notin>net_tree_ips n\<close> have "i\<notin>net_ips \<sigma>" by simp
        hence "(fst (initmissing (netgmap fst \<sigma>))) i = aodv_init i"
          by simp
        thus ?thesis by simp
      qed metis
    qed
  qed

subsection \<open>Loop freedom of AODV\<close>

theorem aodv_loop_freedom:
  assumes "wf_net_tree n"
  shows "closed (pnet (\<lambda>i. paodv i \<langle>\<langle> qmsg) n) \<TTurnstile> netglobal (\<lambda>\<sigma>. \<forall>dip. irrefl ((rt_graph \<sigma> dip)\<^sup>+))"
  using assms by (rule aodv_openproc_par_qmsg.netglobal_weakenE
                          [OF net_nhop_quality_increases inv_to_loop_freedom])

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory KBPsAuto
imports
  Extra
  KBPs
begin
(*>*)

section\<open>Automata Synthesis\<close>

text\<open>

\label{sec:kbps-automata-synthesis}

Our attention now shifts to showing how we can synthesise standard
automata that \emph{implement} a JKBP under certain conditions. We
proceed by defining \emph{incremental views} following
\cite{Ron:1996}, which provide the interface between the system and
these automata. The algorithm itself is presented in
\S\ref{sec:kbps-alg}.

\<close>

subsection\<open>Incremental views\<close>

text\<open>

\label{sec:kbps-environments}

Intuitively an agent instantaneously observes the system state, and so
must maintain her view of the system \emph{incrementally}: her new
view must be a function of her current view and some new
observation. We allow this observation to be an arbitrary projection
@{term "envObs a"} of the system state for each agent @{term "a"}:

\<close>

locale Environment =
  PreEnvironment jkbp envInit envAction envTrans envVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
+ fixes envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"

text\<open>

An incremental view therefore consists of two functions with these
types:

\<close>

type_synonym ('a, 'obs, 'tv) InitialIncrJointView = "'a \<Rightarrow> 'obs \<Rightarrow> 'tv"
type_synonym ('a, 'obs,  'tv) IncrJointView = "'a \<Rightarrow> 'obs \<Rightarrow> 'tv \<Rightarrow> 'tv"

text\<open>

These functions are required to commute with their corresponding
trace-based joint view in the obvious way:

\<close>

locale IncrEnvironment =
  Environment jkbp envInit envAction envTrans envVal envObs
+ PreEnvironmentJView jkbp envInit envAction envTrans envVal jview
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
+ fixes jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
  fixes jviewIncr :: "('a, 'obs, 'tv) IncrJointView"
  assumes jviewInit: "\<forall>a s. jviewInit a (envObs a s) = jview a (tInit s)"
  assumes jviewIncr: "\<forall>a t s. jview a (t \<leadsto> s)
                             = jviewIncr a (envObs a s) (jview a t)"

text\<open>

Armed with these definitions, the following sections show that there
are automata that implement a JKBP in a given environment.

\<close>

subsection\<open>Automata\<close>

text\<open>

Our implementations of JKBPs take the form of deterministic Moore
automata, where transitions are labelled by observation and states
with the action to be performed. We will use the term \emph{protocols}
interchangeably with automata, following the KBP literature, and adopt
\emph{joint protocols} for the assignment of one such to each agent:

\<close>

record ('obs, 'aAct, 'ps) Protocol =
  pInit :: "'obs \<Rightarrow> 'ps"
  pTrans :: "'obs \<Rightarrow> 'ps \<Rightarrow> 'ps"
  pAct :: "'ps \<Rightarrow> 'aAct list"

type_synonym ('a, 'obs, 'aAct, 'ps) JointProtocol
    = "'a \<Rightarrow> ('obs, 'aAct, 'ps) Protocol"

context IncrEnvironment
begin

text\<open>

To ease composition with the system we adopt the function @{term
"pInit"} which maps the initial observation to an initial automaton
state.

\citet{Ron:1996} shows that even non-deterministic JKBPs can be
implemented with deterministic transition functions; intuitively all
relevant uncertainty the agent has about the system must be encoded
into each automaton state, so there is no benefit to doing this
non-deterministically. In contrast we model the non-deterministic
choice of action by making @{term "pAct"} a relation.

Running a protocol on a trace is entirely standard, as is running a
joint protocol, and determining their actions:

\<close>

fun runJP :: "('a, 'obs, 'aAct, 'ps) JointProtocol
           \<Rightarrow> 's Trace \<Rightarrow> 'a \<Rightarrow> 'ps"
where
  "runJP jp (tInit s) a = pInit (jp a) (envObs a s)"
| "runJP jp (t \<leadsto> s) a = pTrans (jp a) (envObs a s) (runJP jp t a)"

abbreviation actJP :: "('a, 'obs, 'aAct, 'ps) JointProtocol
                    \<Rightarrow> 's Trace \<Rightarrow> 'a \<Rightarrow> 'aAct list" where
  "actJP jp \<equiv> \<lambda>t a. pAct (jp a) (runJP jp t a)"

text \<open>

Similarly to \S\ref{sec:kbps-canonical-kripke} we will reason about
the set of traces generated by a joint protocol in a fixed
environment:

\<close>

inductive_set
  jpTraces :: "('a, 'obs, 'aAct, 'ps) JointProtocol \<Rightarrow> 's Trace set"
    for jp :: "('a, 'obs, 'aAct, 'ps) JointProtocol"
where
  "s \<in> set envInit \<Longrightarrow> tInit s \<in> jpTraces jp"
| "\<lbrakk> t \<in> jpTraces jp; eact \<in> set (envAction (tLast t));
     \<And>a. aact a \<in> set (actJP jp t a); s = envTrans eact aact (tLast t) \<rbrakk>
     \<Longrightarrow> t \<leadsto> s \<in> jpTraces jp"
(*<*)

declare jpTraces.intros[intro]

lemma jpTraces_init_inv[dest]:
  "tInit s \<in> jpTraces jp \<Longrightarrow> s \<in> set envInit"
  by (cases rule: jpTraces.cases) auto

lemma jpTraces_step_inv[dest]:
  "t \<leadsto> s \<in> jpTraces jp
    \<Longrightarrow> t \<in> jpTraces jp
     \<and> (\<exists>eact \<in> set (envAction (tLast t)).
        (\<exists>aact. (\<forall>a. aact a \<in> set (actJP jp t a))
          \<and> s = envTrans eact aact (tLast t)))"
  by (cases rule: jpTraces.cases) auto

lemma jpTraces_init_length_inv:
  "t \<in> jpTraces jp \<Longrightarrow> (tLength t = 0) \<longleftrightarrow> (\<exists>s. s \<in> set envInit \<and> t = tInit s)"
  by (induct t) (auto elim: jpTraces.cases)

lemma jpTraces_step_length_inv_aux:
  "t \<in> { t \<in> jpTraces jp . tLength t = Suc n }
    \<Longrightarrow> \<exists>t' s. t = t' \<leadsto> s
            \<and> t' \<in> jpTraces jp
            \<and> tLength t' = n
            \<and> (\<exists>eact \<in> set (envAction (tLast t')).
               (\<exists>aact. (\<forall>a. aact a \<in> set (actJP jp t' a))
                 \<and> s = envTrans eact aact (tLast t')))"
  by (induct t arbitrary: n) auto

lemma jpTraces_step_length_inv:
  "{ t \<in> jpTraces jp . tLength t = Suc n }
 = { t \<leadsto> s |eact aact t s. t \<in> { t \<in> jpTraces jp . tLength t = n }
              \<and> eact \<in> set (envAction (tLast t))
              \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
              \<and> s = envTrans eact aact (tLast t) }"
  apply (rule set_eqI)
  apply rule
   apply (drule jpTraces_step_length_inv_aux)
   apply auto
  done
(*>*)

end (* context IncrEnvironment *)

subsection\<open>The Implementation Relation\<close>

text\<open>

\label{sec:kbps-implementation}

With this machinery in hand, we now relate automata with JKBPs. We say
a joint protocol @{term "jp"} \emph{implements} a JKBP when they
perform the same actions on the canonical of traces. Note that the
behaviour of @{term "jp"} on other traces is arbitrary.

\<close>

context IncrEnvironment
begin

definition
  implements :: "('a, 'obs, 'aAct, 'ps) JointProtocol \<Rightarrow> bool"
where
  "implements jp \<equiv> (\<forall>t \<in> jkbpC. set \<circ> actJP jp t = set \<circ> jAction MC t)"

text\<open>

Clearly there are environments where the canonical trace set @{term
"jkbpC"} can be generated by actions that differ from those prescribed
by the JKBP. We can show that the \emph{implements} relation is a
stronger requirement than the mere trace-inclusion required by the
\emph{represents} relation of \S\ref{sec:kbps-canonical-kripke}.

\<close>
(*<*)

lemma implementsI[intro]:
  "(\<And>t. t \<in> jkbpC \<Longrightarrow> set \<circ> actJP jp t = set \<circ> jAction MC t)
  \<Longrightarrow> implements jp"
  unfolding implements_def by simp

lemma implementsE[elim]:
  assumes impl: "implements jp"
      and tC: "t \<in> jkbpC"
     shows "set \<circ> actJP jp t = set \<circ> jAction MC t"
  using assms unfolding implements_def by simp

lemma implements_actJP_jAction:
   assumes impl: "implements jp"
       and tCn: "t \<in> jkbpCn n"
  shows "set (actJP jp t a) = set (jAction (MCn n) t a)" (is "?lhs = ?rhs")
proof -
  from tCn have tC: "t \<in> jkbpC" by blast
  hence "?lhs = (set \<circ> jAction MC t) a"
    using implementsE[OF impl, symmetric] by auto
  also have "... = set (jAction (MCn n) t a)"
    by (simp add: jkbpC_jkbpCn_jAction_eq[OF tCn])
  finally show ?thesis .
qed

(*>*)
lemma implements_represents:
  assumes impl: "implements jp"
  shows "represents (jpTraces jp)"
(*<*)
proof -
  { fix n
    have "{ t \<in> jpTraces jp . tLength t = n }
        = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0 thus ?case
        by (auto dest: jpTraces_init_length_inv iff: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> jpTraces jp . tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

      have "{t \<in> jpTraces jp. tLength t = Suc n}
          = {t \<leadsto> s |eact aact t s. t \<in> jkbpCn n
                      \<and> eact \<in> set (envAction (tLast t))
                      \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
                      \<and> s = envTrans eact aact (tLast t) }"
        using indhyp by (simp add: jpTraces_step_length_inv)
      also have "... = jkbpCn (Suc n)"
        apply (auto iff: Let_def)
        apply (auto iff: implements_actJP_jAction[OF impl, symmetric])
        done
      finally show ?case by (auto iff: jkbpC_traces_of_length)
    qed }
  hence R: "jpTraces jp = jkbpC" by auto
  from R jkbpC_represents
  show "represents (jpTraces jp)" by simp
qed

lemma implements_ind_jkbpC:
  assumes acts: "\<And>a n t.
                  \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
                  \<Longrightarrow> actJP jp t a = jAction MC t a"
  shows "implements jp"
proof -
  let ?T = "jpTraces jp"

  from acts have acts':
      "\<And>n t. \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
          \<Longrightarrow> actJP jp t = jAction (MCn n) t"
    by (simp only: jkbpC_jkbpCn_jAction_eq)

  from acts have acts':
      "\<And>n t. \<lbrakk> {t \<in> jpTraces jp. tLength t = n} = jkbpCn n; t \<in> jkbpCn n \<rbrakk>
          \<Longrightarrow> actJP jp t = jAction (MCn n) t"
    apply -
    apply (rule ext)
    apply simp
    using jkbpC_jkbpCn_jAction_eq
    apply simp
    done

  { fix n
    have "{ t \<in> ?T . tLength t = n } = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0 thus ?case
        by (auto dest: jpTraces_init_length_inv iff: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> ?T. tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

      have "{t \<in> jpTraces jp. tLength t = Suc n}
          = {t \<leadsto> s |eact aact t s. t \<in> jkbpCn n
                      \<and> eact \<in> set (envAction (tLast t))
                      \<and> (\<forall>a. aact a \<in> set (actJP jp t a))
                      \<and> s = envTrans eact aact (tLast t) }"
        using indhyp by (simp add: jpTraces_step_length_inv)
      also have "... = jkbpCn (Suc n)"
        apply (auto iff: Let_def)
         apply (drule acts'[OF indhyp, symmetric])
         apply auto[1]
        apply (drule acts'[OF indhyp, symmetric])
        apply auto[1]
        done
      finally show ?case
        apply (auto iff: jkbpC_traces_of_length)
        done
    qed
    hence "\<forall>t\<in>jkbpCn n. actJP jp t = jAction (MCn n) t"
      apply clarsimp
      apply (rule acts')
       apply (auto iff: jkbpC_traces_of_length)
      done
    hence "\<forall>t\<in>jkbpCn n. actJP jp t = jAction MC t"
      apply clarsimp
      by ( rule sync_jview_jAction_eq[where n="n"]
         , auto iff: jkbpC_traces_of_length)
  }
  thus ?thesis
    unfolding implements_def jkbpC_def
    apply clarsimp
    done
qed

(*>*)
text\<open>

The proof is by a straightfoward induction over the lengths of traces
generated by the joint protocol.

Our final piece of technical machinery allows us to refine automata
definitions: we say that two joint protocols are \emph{behaviourally
equivalent} if the actions they propose coincide for each canonical
trace. The implementation relation is preserved by this relation.

\<close>

definition
  behaviourally_equiv :: "('a, 'obs, 'aAct, 'ps) JointProtocol
                        \<Rightarrow> ('a, 'obs, 'aAct, 'ps') JointProtocol
                        \<Rightarrow> bool"
where
  "behaviourally_equiv jp jp' \<equiv> \<forall>t \<in> jkbpC. set \<circ> actJP jp t = set \<circ> actJP jp' t"

(*<*)
lemma behaviourally_equivI[intro]:
  "(\<And>t. t \<in> jkbpC \<Longrightarrow> set \<circ> actJP jp t = set \<circ> actJP jp' t)
    \<Longrightarrow> behaviourally_equiv jp jp'"
  unfolding behaviourally_equiv_def by simp
(*>*)

lemma behaviourally_equiv_implements:
  assumes "behaviourally_equiv jp jp'"
  shows "implements jp \<longleftrightarrow> implements jp'"
(*<*)
  using assms unfolding behaviourally_equiv_def implements_def by simp
(*>*)
text\<open>\<close>

end (* context IncrEnvironment *)

(* **************************************** *)

subsection\<open>Automata using Equivalence Classes\<close>

text\<open>

We now show that there is an implementation of every JKBP with respect
to every incremental synchronous view. Intuitively the states of the
automaton for agent @{term "a"} represent the equivalence classes of
traces that @{term "a"} considers possible, and the transitions update
these sets according to her KBP.

\<close>

context IncrEnvironment
begin

definition
  mkAutoEC :: "('a, 'obs, 'aAct, 's Trace set) JointProtocol"
where
  "mkAutoEC \<equiv> \<lambda>a.
     \<lparr> pInit = \<lambda>obs. { t \<in> jkbpC . jviewInit a obs = jview a t },
       pTrans = \<lambda>obs ps. { t |t t'. t \<in> jkbpC \<and> t' \<in> ps
                                 \<and> jview a t = jviewIncr a obs (jview a t') },
       pAct = \<lambda>ps. jAction MC (SOME t. t \<in> ps) a \<rparr>"

text\<open>

The function \<open>SOME\<close> is Hilbert's indefinite description
operator @{term "\<epsilon>"}, used here to choose an arbitrary trace from the
protocol state.

That this automaton maintains the correct equivalence class on a trace
@{term "t"} follows from an easy induction over @{term "t"}.

\<close>

lemma mkAutoEC_ec:
  assumes "t \<in> jkbpC"
  shows "runJP mkAutoEC t a = { t' \<in> jkbpC . jview a t' = jview a t }"
(*<*)
  using assms
  apply (induct t)
   apply (auto simp add: mkAutoEC_def jviewInit)[1]
  apply simp
  apply (subst mkAutoEC_def)
  apply (auto iff: Let_def jviewIncr)
  done
(*>*)

text\<open>

We can show that the construction yields an implementation by
appealing to the previous lemma and showing that the @{term "pAct"}
functions coincide.

\<close>

lemma mkAutoEC_implements: "implements mkAutoEC"
(*<*)
  apply (rule implements_ind_jkbpC)
  apply (subst mkAutoEC_def)
  apply simp
  apply (subgoal_tac "t \<in> jkbpC")
   using mkAutoEC_ec
   apply simp
   apply (rule S5n_jAction_eq)
    apply simp_all
    apply (rule_tac a=t in someI2)
     apply simp_all
    unfolding mkM_def
    apply auto
   done
(*>*)

text\<open>

This definition leans on the canonical trace set jkbpC, and is indeed
effective: we can enumerate all canonical traces and are sure to find
one that has the view we expect. Then it is sufficient to consider
other traces of the same length due to synchrony.  We would need to do
this computation dynamically, as the automaton will (in general) have
an infinite state space.

\<close>

end (* context IncrEnvironment *)

(* **************************************** *)

subsection\<open>Simulations\<close>

text\<open>
\label{sec:kbps-theory-automata-env-sims}

Our goal now is to reduce the space required by the automaton
constructed by @{term "mkAutoEC"} by \emph{simulating} the equivalence
classes (\S\ref{sec:kripke-theory-simulations}).

The following locale captures the framework of \citet{Ron:1996}:

\<close>

locale SimIncrEnvironment =
  IncrEnvironment jkbp envInit envAction envTrans envVal jview envObs
                  jviewInit jviewIncr
    for jkbp :: "('a, 'p, 'aAct) JKBP"

    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
    and jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
    and jviewIncr :: "('a, 'obs, 'tv) IncrJointView"
+ fixes simf :: "'s Trace \<Rightarrow> 'ss"
  fixes simRels :: "'a \<Rightarrow> 'ss Relation"
  fixes simVal :: "'ss \<Rightarrow> 'p \<Rightarrow> bool"
  assumes simf: "sim MC (mkKripke (simf ` jkbpC) simRels simVal) simf"

context SimIncrEnvironment
begin

text\<open>

Note that the back tick \<open>`\<close> is Isabelle/HOL's relational image
operator. In context it says that @{term "simf"} must be a simulation
from @{term "jkbpC"} to its image under @{term "simf"}.

Firstly we lift our familiar canonical trace sets and Kripke
structures through the simulation.

\<close>

abbreviation jkbpCSn :: "nat \<Rightarrow> 'ss set"(*<*)("jkbpCS\<^bsub>_\<^esub>")(*>*) where
  "jkbpCS\<^bsub>n\<^esub> \<equiv> simf ` jkbpC\<^bsub>n\<^esub>"

abbreviation jkbpCS :: "'ss set" where
  "jkbpCS \<equiv> simf ` jkbpC"

abbreviation MCSn :: "nat \<Rightarrow> ('a, 'p, 'ss) KripkeStructure"(*<*)("MCS\<^bsub>_\<^esub>")(*>*) where
  "MCS\<^bsub>n\<^esub> \<equiv> mkKripke jkbpCS\<^bsub>n\<^esub> simRels simVal"

abbreviation MCS :: "('a, 'p, 'ss) KripkeStructure" where
  "MCS \<equiv> mkKripke jkbpCS simRels simVal"
(*<*)
lemma jkbpCSn_jkbpCS_subset:
  "jkbpCSn n \<subseteq> jkbpCS"
  by (rule image_mono[OF jkbpCn_jkbpC_subset])

(*>*)
text\<open>

We will be often be concerned with the equivalence class of traces
generated by agent @{term "a"}'s view:

\<close>

abbreviation sim_equiv_class :: "'a \<Rightarrow> 's Trace \<Rightarrow> 'ss set" where
  "sim_equiv_class a t \<equiv> simf ` { t' \<in> jkbpC . jview a t' = jview a t }"

abbreviation jkbpSEC :: "'ss set set" where
  "jkbpSEC \<equiv> \<Union>a. sim_equiv_class a ` jkbpC"

text\<open>

With some effort we can show that the temporal slice of the simulated
structure is adequate for determining the actions of the JKBP. The
proof is tedious and routine, exploiting the sub-model property
(\S\ref{sec:generated_models}).

\<close>
(*<*)

lemma sim_submodel_aux:
  assumes s: "s \<in> worlds (MCSn n)"
  shows "gen_model MCS s = gen_model (MCSn n) s"
proof(rule gen_model_subset[where T="jkbpCSn n"])
  from s show "s \<in> worlds MCS"
    by (simp add: subsetD[OF jkbpCSn_jkbpCS_subset])
  from s show "s \<in> worlds (MCSn n)" by assumption
next
  fix a
  show "relations MCS a \<inter> jkbpCSn n \<times> jkbpCSn n
      = relations (MCSn n) a \<inter> jkbpCSn n \<times> jkbpCSn n"
    by (simp add: Int_ac Int_absorb1
                  relation_mono[OF jkbpCSn_jkbpCS_subset jkbpCSn_jkbpCS_subset])
next
  from s
  show "(\<Union>a. relations (MCSn n) a)\<^sup>* `` {s} \<subseteq> jkbpCSn n"
    apply (clarsimp simp del: mkKripke_simps)
    apply (erule kripke_rels_trc_worlds)
    apply auto
    done
next
  from s obtain t
    where st: "s = simf t"
      and tCn: "t \<in> jkbpCn n"
    by fastforce
  from tCn have tC: "t \<in> jkbpC" by blast
  { fix t'
    assume tt': "(t, t') \<in> (\<Union>a. relations MC a)\<^sup>*"
    from tC tt' have t'C: "t' \<in> jkbpC"
      by - (erule kripke_rels_trc_worlds, simp_all)
    from tCn tt' have t'Len: "tLength t' = n"
      by (auto dest: sync_tLength_eq_trc[where as=UNIV])
    from t'C t'Len have "t' \<in> jkbpCn n"
      by - (erule jkbpC_tLength_inv) }
  hence "(\<Union>a. relations MC a)\<^sup>* `` {t} \<subseteq> jkbpCn n"
    by clarsimp
  hence "simf ` ((\<Union>a. relations MC a)\<^sup>* `` {t}) \<subseteq> jkbpCSn n"
    by (rule image_mono)
  with st tC
  show "(\<Union>a. relations MCS a)\<^sup>* `` {s} \<subseteq> jkbpCSn n"
    using sim_trc_commute[OF _ simf, where t=t]
    by simp
qed simp_all
(*>*)

lemma jkbpC_jkbpCSn_jAction_eq:
  assumes tCn: "t \<in> jkbpCn n"
  shows "jAction MC t = jAction (MCSn n) (simf t)"
(*<*) (is "?lhs = ?rhs")
proof -
  have "?lhs = jAction MCS (simf t)"
    by (simp add: simulation_jAction_eq simf jkbpCn_jkbpC_inc[OF tCn])
  also have "... = ?rhs"
    using tCn
    by - ( rule gen_model_jAction_eq[OF sim_submodel_aux, where w="simf t"]
         , auto intro: gen_model_world_refl )
  finally show ?thesis .
qed
(*>*)

end (* context SimIncrEnvironment *)

text\<open>

It can be shown that a suitable simulation into a finite structure is
adequate to establish the existence of finite-state implementations
\citep[Theorem~2]{Ron:1996}: essentially we apply the simulation to
the states of @{term "mkAutoEC"}. However this result does not make it
clear how the transition function can be incrementally
constructed. One approach is to maintain @{term "jkbpC"} while
extending the automaton, which is quite space inefficient.

Intuitively we would like to compute the possible @{term
"sim_equiv_class"} successors of a given @{term "sim_equiv_class"}
without reference to @{term "jkbpC"}, and this should be possible as
the reachable simulated worlds must contain enough information to
differentiate themselves from every other simulated world (reachable
or not) that represents a trace that is observationally distinct to
their own.

This leads us to asking for some extra functionality of our
simulation, which we do in the following section.

\<close>

subsection\<open>Automata using simulations\<close>

text_raw\<open>
\label{sec:kbps-automata-synthesis-alg}

\begin{figure}[hp]
\begin{isabellebody}%
\<close>
locale AlgSimIncrEnvironment =
  SimIncrEnvironment jkbp envInit envAction envTrans envVal
                     jview envObs jviewInit jviewIncr simf simRels simVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"

    and jview :: "('a, 's, 'tv) JointView"
    and envObs :: "'a \<Rightarrow> 's \<Rightarrow> 'obs"
    and jviewInit :: "('a, 'obs, 'tv) InitialIncrJointView"
    and jviewIncr :: "('a, 'obs, 'tv) IncrJointView"

    and simf :: "'s Trace \<Rightarrow> 'ss"
    and simRels :: "'a \<Rightarrow> 'ss Relation"
    and simVal :: "'ss \<Rightarrow> 'p \<Rightarrow> bool"

+ fixes simAbs :: "'rep \<Rightarrow> 'ss set"

    and simObs :: "'a \<Rightarrow> 'rep \<Rightarrow> 'obs"
    and simInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 'rep"
    and simTrans :: "'a \<Rightarrow> 'rep \<Rightarrow> 'rep list"
    and simAction :: "'a \<Rightarrow> 'rep \<Rightarrow> 'aAct list"

  assumes simInit:
            "\<forall>a iobs. iobs \<in> envObs a ` set envInit
                   \<longrightarrow> simAbs (simInit a iobs)
                     = simf ` { t' \<in> jkbpC. jview a t' = jviewInit a iobs }"
      and simObs:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> simObs a ec = envObs a (tLast t)"
      and simAction:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> set (simAction a ec) = set (jAction MC t a)"
      and simTrans:
            "\<forall>a ec t. t \<in> jkbpC \<and> simAbs ec = sim_equiv_class a t
                   \<longrightarrow> simAbs ` set (simTrans a ec)
                     = { sim_equiv_class a (t' \<leadsto> s)
                         |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t }"
text_raw\<open>
\end{isabellebody}%
\begin{isamarkuptext}%
\caption{The \<open>SimEnvironment\<close> locale extends the @{term
"Environment"} locale with simulation and algorithmic operations. The
backtick \<open>`\<close> is Isabelle/HOL's image-of-a-set-under-a-function
operator.}
\label{fig:kbps-theory-auto-SimEnvironment}
\end{isamarkuptext}%
\end{figure}
\<close>

text\<open>

The locale in Figure~\ref{fig:kbps-theory-auto-SimEnvironment} captures
our extra requirements of a simulation.

Firstly we relate the concrete representation @{typ "'rep"} of
equivalence classes under simulation to differ from the abstract
representation @{typ "'ss set"} using the abstraction function @{term
"simAbs"} \citep{EdR:cup98}; there is no one-size-fits-all concrete
representation, as we will see.

Secondly we ask for a function @{term "simInit a iobs"} that
faithfully generates a representation of the equivalence class of
simulated initial states that are possible for agent @{term "a"} given
the valid initial observation @{term "iobs"}.

Thirdly the @{term "simObs"} function allows us to partition the
results of @{term "simTrans"} according to the recurrent observation
that agent @{term "a"} makes of the equivalence class.

Fourthly, the function @{term "simAction"} computes a list of actions
enabled by the JKBP on a state that concretely represents a canonical
equivalence class.

Finally we expect to compute the list of represented @{term
"sim_equiv_class"} successors of a given @{term "sim_equiv_class"}
using @{term "simTrans"}.

Note that these definitions are stated relative to the environment and
the JKBP, allowing us to treat specialised cases such as broadcast
(\S\ref{sec:kbps-theory-spr-deterministic-protocols} and
\S\ref{sec:kbps-theory-spr-non-deterministic-protocols}).

With these functions in hand, we can define our desired automaton:

\<close>

definition (in AlgSimIncrEnvironment)
  mkAutoSim :: "('a, 'obs, 'aAct, 'rep) JointProtocol"
where
  "mkAutoSim \<equiv> \<lambda>a.
     \<lparr> pInit = simInit a,
       pTrans = \<lambda>obs ec. (SOME ec'. ec' \<in> set (simTrans a ec)
                                  \<and> simObs a ec' = obs),
       pAct = simAction a \<rparr>"
(*<*)

context AlgSimIncrEnvironment
begin

lemma jAction_simAbs_cong:
  assumes tC: "t \<in> jkbpC"
      and ec: "simAbs ec = sim_equiv_class a t"
      and ec': "simAbs ec = simAbs ec'"
  shows "set (simAction a ec) = set (simAction a ec')"
  using assms simAction[rule_format, where a=a and t=t] tC by simp

lemma simTrans_simAbs_cong:
  assumes tC: "t \<in> jkbpC"
      and ec: "simAbs ec = sim_equiv_class a t"
      and ec': "simAbs ec = simAbs ec'"
  shows "simAbs ` set (simTrans a ec) = simAbs ` set (simTrans a ec')"
  using assms simTrans[rule_format, where a=a and t=t] tC by simp

lemma mkAutoSim_simps[simp]:
  "pInit (mkAutoSim a) = simInit a"
  "pTrans (mkAutoSim a) = (\<lambda>obs ec. (SOME ec'. ec' \<in> set (simTrans a ec) \<and> simObs a ec' = obs))"
  "pAct (mkAutoSim a) = simAction a"
  unfolding mkAutoSim_def by simp_all

end (* context AlgSimIncrEnvironment *)

(*>*)
text\<open>

The automaton faithfully constructs the simulated equivalence class of
the given trace:

\<close>

lemma (in AlgSimIncrEnvironment) mkAutoSim_ec:
  assumes tC: "t \<in> jkbpC"
  shows "simAbs (runJP mkAutoSim t a) = sim_equiv_class a t"
(*<*)
using tC
proof(induct t)
  case (tInit s) thus ?case
    by (simp add: jviewInit[rule_format, symmetric] simInit)
next
  case (tStep t s)
  hence tC: "t \<in> jkbpC" by blast

      from tC tStep
      have F: "simAbs ` set (simTrans a (runJP mkAutoSim t a))
             = { sim_equiv_class a (t' \<leadsto> s)
                 |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
        using simTrans[rule_format, where a=a and t=t and ec="runJP mkAutoSim t a"]
        apply clarsimp
        done

      from tStep
      have G: "sim_equiv_class a (t \<leadsto> s)
             \<in> { sim_equiv_class a (t' \<leadsto> s)
                |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
        by auto

      from F G
      have H: "sim_equiv_class a (t \<leadsto> s) \<in> simAbs ` set (simTrans a (runJP mkAutoSim t a))"
        by simp

      then obtain r
        where R: "r \<in> set (simTrans a (runJP mkAutoSim t a))"
        and S: "simAbs r = sim_equiv_class a (t \<leadsto> s)"
        by auto

  show ?case
  proof(simp, rule someI2)
    from R S tStep tC
    show "r \<in> set (simTrans a (runJP mkAutoSim t a)) \<and> simObs a r = envObs a s"
      using simObs[rule_format, where t="t\<leadsto>s" and a=a]
      apply clarsimp
      done
  next
    fix x assume x: "x \<in> set (simTrans a (runJP mkAutoSim t a)) \<and> simObs a x = envObs a s"

    from x
    have A: "simObs a x = envObs a s" by simp

    from x
    have "simAbs x \<in> simAbs ` set (simTrans a (runJP mkAutoSim t a))" by simp
    with tStep tC
    have "simAbs x \<in> { sim_equiv_class a (t' \<leadsto> s)
                         |t' s. t' \<leadsto> s \<in> jkbpC \<and> jview a t' = jview a t}"
      using simTrans[rule_format, where a=a and t=t] by simp
    then obtain t' s'
      where X: "simAbs x = sim_equiv_class a (t' \<leadsto> s')"
          and Y: "t' \<leadsto> s' \<in> jkbpC"
          and Z: "jview a t' = jview a t"
      by auto

    from A X Y Z
    show "simAbs x = sim_equiv_class a (t \<leadsto> s)"
      using simObs[rule_format, where a=a and t="t'\<leadsto>s'", symmetric]
      by (simp add: jviewIncr)
  qed
qed

(*>*)
text\<open>

This follows from a simple induction on @{term "t"}.

The following is a version of the Theorem 2 of \citet{Ron:1996}.

\<close>

theorem (in AlgSimIncrEnvironment) mkAutoSim_implements:
  "implements mkAutoSim"
(*<*)
  apply rule
  apply rule
  apply (auto dest: jkbpCn_jkbpC_inc iff: mkAutoSim_ec simAction)
  done
(*>*)

text\<open>

The reader may care to contrast these structures with the
\emph{progression structures} of \citet{Ron:1997}, where states
contain entire Kripke structures, and expanding the automaton is
alternated with bisimulation reduction to ensure termination when a
finite-state implementation exists (see \S\ref{sec:kbps-alg-auto-min})
We also use simulations in Appendix~\ref{ch:complexity} to show the
complexity of some related model checking problems.

We now review a simple \emph{depth-first search} (DFS) theory, and an
abstraction of finite maps, before presenting the algorithm for KBP
synthesis.

\FloatBarrier

\<close>

(*<*)
end
(*>*)


section \<open>Executable compilation chain\<close>

theory Compiler
imports Composition
begin

definition term_to_exp :: "C_info \<Rightarrow> rule fset \<Rightarrow> term \<Rightarrow> exp" where
"term_to_exp C_info rs t =
  cakeml.mk_con C_info (heads_of rs |\<union>| constructors.C C_info)
    (pterm_to_sterm (nterm_to_pterm (fresh_frun (term_to_nterm [] t) (heads_of rs |\<union>| constructors.C C_info))))"

lemma (in rules) "Compiler.term_to_exp C_info rs = term_to_cake"
  unfolding term_to_exp_def by (simp add: all_consts_def)

primrec compress_pterm :: "pterm \<Rightarrow> pterm" where
"compress_pterm (Pabs cs) = Pabs (fcompress (map_prod id compress_pterm |`| cs))" |
"compress_pterm (Pconst name) = Pconst name" |
"compress_pterm (Pvar name) = Pvar name" |
"compress_pterm (t $\<^sub>p u) = compress_pterm t $\<^sub>p compress_pterm u"

lemma compress_pterm_eq[simp]: "compress_pterm t = t"
by (induction t) (auto simp: subst_pabs_id fset_map_snd_id map_prod_def fmember_iff_member_fset)

definition compress_crule_set :: "crule_set \<Rightarrow> crule_set" where
"compress_crule_set = fcompress \<circ> fimage (map_prod id fcompress)"

definition compress_irule_set :: "irule_set \<Rightarrow> irule_set" where
"compress_irule_set = fcompress \<circ> fimage (map_prod id (fcompress \<circ> fimage (map_prod id compress_pterm)))"

definition compress_prule_set :: "prule fset \<Rightarrow> prule fset" where
"compress_prule_set = fcompress \<circ> fimage (map_prod id compress_pterm)"

lemma compress_crule_set_eq[simp]: "compress_crule_set rs = rs"
unfolding compress_crule_set_def by force

lemma compress_irule_set_eq[simp]: "compress_irule_set rs = rs"
unfolding compress_irule_set_def map_prod_def by simp

lemma compress_prule_set[simp]: "compress_prule_set rs = rs"
unfolding compress_prule_set_def by force

definition transform_irule_set_iter :: "irule_set \<Rightarrow> irule_set" where
"transform_irule_set_iter rs = ((transform_irule_set \<circ> compress_irule_set) ^^ max_arity rs) rs"

definition as_sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env \<Rightarrow> v sem_env" where
"as_sem_env C_info rs env =
  \<lparr> sem_env.v =
      build_rec_env (cakeml.mk_letrec_body C_info (fset_of_list (map fst rs) |\<union>| constructors.C C_info) rs) env nsEmpty,
    sem_env.c =
      nsEmpty \<rparr>"

definition empty_sem_env :: "C_info \<Rightarrow> v sem_env" where
"empty_sem_env C_info = \<lparr> sem_env.v = nsEmpty, sem_env.c = constructors.as_static_cenv C_info \<rparr>"

definition sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env" where
"sem_env C_info rs = extend_dec_env (as_sem_env C_info rs (empty_sem_env C_info)) (empty_sem_env C_info)"

definition compile :: "C_info \<Rightarrow> rule fset \<Rightarrow> Ast.prog" where
"compile C_info =
  CakeML_Backend.compile' C_info \<circ>
  Rewriting_Sterm.compile \<circ>
  compress_prule_set \<circ>
  Rewriting_Pterm.compile \<circ>
  transform_irule_set_iter \<circ>
  compress_irule_set \<circ>
  Rewriting_Pterm_Elim.compile \<circ>
  compress_crule_set \<circ>
  Rewriting_Nterm.consts_of \<circ>
  fcompress \<circ>
  Rewriting_Nterm.compile' C_info \<circ>
  fcompress"

definition compile_to_env :: "C_info \<Rightarrow> rule fset \<Rightarrow> v sem_env" where
"compile_to_env C_info =
  sem_env C_info \<circ>
  Rewriting_Sterm.compile \<circ>
  compress_prule_set \<circ>
  Rewriting_Pterm.compile \<circ>
  transform_irule_set_iter \<circ>
  compress_irule_set \<circ>
  Rewriting_Pterm_Elim.compile \<circ>
  compress_crule_set \<circ>
  Rewriting_Nterm.consts_of \<circ>
  fcompress \<circ>
  Rewriting_Nterm.compile' C_info \<circ>
  fcompress"

lemma (in rules) "Compiler.compile_to_env C_info rs = rules.cake_sem_env C_info rs"
unfolding Compiler.compile_to_env_def Compiler.sem_env_def Compiler.as_sem_env_def Compiler.empty_sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_sem_env_def
unfolding empty_sem_env_def
by (auto simp:
        Compiler.compress_irule_set_eq[abs_def]
        Composition.transform_irule_set_iter_def[abs_def]
        Compiler.transform_irule_set_iter_def[abs_def] comp_def pre_constants.all_consts_def)

export_code
  term_to_exp compile compile_to_env
  checking Scala

end


(*  Title:      Jinja/J/Annotate.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Program annotation} *}

theory Annotate
imports
  WellType
begin

abbreviation (output)
  unanFAcc :: "'addr expr \<Rightarrow> vname \<Rightarrow> 'addr expr" ("(_\<bullet>_)" [10,10] 90)
where
  "unanFAcc e F \<equiv> FAcc e F (STR [])"

abbreviation (output)
  unanFAss :: "'addr expr \<Rightarrow> vname \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr" ("(_\<bullet>_ := _)" [10,0,90] 90)
where
  "unanFAss e F e' \<equiv> FAss e F (STR []) e'"

definition array_length_field_name :: vname
where "array_length_field_name = STR ''length''"

notation (output) array_length_field_name ("length")

definition super :: vname
where "super = STR ''super''"

lemma super_neq_this [simp]: "super \<noteq> this" "this \<noteq> super"
by(simp_all add: this_def super_def)

inductive Anno :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr \<Rightarrow> bool"
  ("_,_,_ \<turnstile> _ \<leadsto> _"   [51,51,0,0,51]50)
  and Annos :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr list \<Rightarrow> bool"
  ("_,_,_ \<turnstile> _ [\<leadsto>] _" [51,51,0,0,51]50)
for is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" and P :: "'addr J_prog"
where
  AnnoNew: "is_lub,P,E \<turnstile> new C \<leadsto> new C"
| AnnoNewArray: "is_lub,P,E \<turnstile> i \<leadsto> i' \<Longrightarrow> is_lub,P,E \<turnstile> newA T\<lfloor>i\<rceil> \<leadsto> newA T\<lfloor>i'\<rceil>"
| AnnoCast: "is_lub,P,E \<turnstile> e \<leadsto> e' \<Longrightarrow> is_lub,P,E \<turnstile> Cast C e \<leadsto> Cast C e'"
| AnnoInstanceOf: "is_lub,P,E \<turnstile> e \<leadsto> e' \<Longrightarrow> is_lub,P,E \<turnstile> e instanceof T \<leadsto> e' instanceof T"
| AnnoVal: "is_lub,P,E \<turnstile> Val v \<leadsto> Val v"
| AnnoVarVar: "\<lbrakk> E V = \<lfloor>T\<rfloor>; V \<noteq> super \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> Var V \<leadsto> Var V"
| AnnoVarField:
  -- {*
    There is no need to handle access of array fields explicitly,
    because arrays do not implement methods, i.e. @{term "this"} is
    always of a @{term "Class"} type.
  *}
  "\<lbrakk> E V = None; V \<noteq> super; E this = \<lfloor>Class C\<rfloor>; P \<turnstile> C sees V:T (fm) in D \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> Var V \<leadsto> Var this\<bullet>V{D}"
| AnnoBinOp:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 \<leadsto> e1';  is_lub,P,E \<turnstile> e2 \<leadsto> e2' \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 \<leadsto> e1' \<guillemotleft>bop\<guillemotright> e2'"
| AnnoLAssVar:
  "\<lbrakk> E V = \<lfloor>T\<rfloor>; V \<noteq> super; is_lub,P,E \<turnstile> e \<leadsto> e' \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> V:=e \<leadsto> V:=e'"
| AnnoLAssField:
  "\<lbrakk> E V = None; V \<noteq> super; E this = \<lfloor>Class C\<rfloor>; P \<turnstile> C sees V:T (fm) in D; is_lub,P,E \<turnstile> e \<leadsto> e' \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> V:=e \<leadsto> Var this\<bullet>V{D} := e'"
| AnnoAAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> a \<leadsto> a'; is_lub,P,E \<turnstile> i \<leadsto> i' \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> \<leadsto> a'\<lfloor>i'\<rceil>"
| AnnoAAss:
  "\<lbrakk> is_lub,P,E \<turnstile> a \<leadsto> a'; is_lub,P,E \<turnstile> i \<leadsto> i'; is_lub,P,E \<turnstile> e \<leadsto> e' \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> := e \<leadsto> a'\<lfloor>i'\<rceil> := e'"
| AnnoALength:
  "is_lub,P,E \<turnstile> a \<leadsto> a' \<Longrightarrow> is_lub,P,E \<turnstile> a\<bullet>length \<leadsto> a'\<bullet>length"
| -- {*
    All arrays implicitly declare a final field called @{term "array_length_field_name"} to
    store the array length, which hides a potential field of the same name in @{term "Object"} (cf. JLS 6.4.5).
    The last premise implements the hiding because field lookup does does not model the implicit declaration.
  *}
  AnnoFAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e';  is_lub,P,E \<turnstile> e' :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D;
     is_Array U \<longrightarrow> F \<noteq> array_length_field_name \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>F{STR []} \<leadsto> e'\<bullet>F{D}"
| AnnoFAccALength:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e'; is_lub,P,E \<turnstile> e' :: T\<lfloor>\<rceil> \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>array_length_field_name{STR []} \<leadsto> e'\<bullet>length"
| AnnoFAccSuper:
  -- {* In class C with super class D, "super" is syntactic sugar for "((D) this)" (cf. JLS, 15.11.2) *}
  "\<lbrakk> E this = \<lfloor>Class C\<rfloor>; C \<noteq> Object; class P C = \<lfloor>(D, fs, ms)\<rfloor>;
     P \<turnstile> D sees F:T (fm) in D' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> Var super\<bullet>F{STR []} \<leadsto> (Cast (Class D) (Var this))\<bullet>F{D'}"
|  AnnoFAss:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 \<leadsto> e1';  is_lub,P,E \<turnstile> e2 \<leadsto> e2';
     is_lub,P,E \<turnstile> e1' :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D;
     is_Array U \<longrightarrow> F \<noteq> array_length_field_name \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e1\<bullet>F{STR []} := e2 \<leadsto> e1'\<bullet>F{D} := e2'"
| AnnoFAssSuper:
  "\<lbrakk> E this = \<lfloor>Class C\<rfloor>; C \<noteq> Object; class P C = \<lfloor>(D, fs, ms)\<rfloor>;
     P \<turnstile> D sees F:T (fm) in D'; is_lub,P,E \<turnstile> e \<leadsto> e' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> Var super\<bullet>F{STR []} := e \<leadsto> (Cast (Class D) (Var this))\<bullet>F{D'} := e'"
| AnnoCall:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e';  is_lub,P,E \<turnstile> es [\<leadsto>] es' \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> Call e M es \<leadsto> Call e' M es'"
| AnnoBlock:
  "is_lub,P,E(V \<mapsto> T) \<turnstile> e \<leadsto> e'  \<Longrightarrow>  is_lub,P,E \<turnstile> {V:T=vo; e} \<leadsto> {V:T=vo; e'}"
| AnnoSync:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 \<leadsto> e1'; is_lub,P,E \<turnstile> e2 \<leadsto> e2' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> sync(e1) e2 \<leadsto> sync(e1') e2'"
| AnnoComp:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 \<leadsto> e1';  is_lub,P,E \<turnstile> e2 \<leadsto> e2' \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> e1;;e2 \<leadsto> e1';;e2'"
| AnnoCond:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e'; is_lub,P,E \<turnstile> e1 \<leadsto> e1';  is_lub,P,E \<turnstile> e2 \<leadsto> e2' \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> if (e) e1 else e2 \<leadsto> if (e') e1' else e2'"
| AnnoLoop:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e';  is_lub,P,E \<turnstile> c \<leadsto> c' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> while (e) c \<leadsto> while (e') c'"
| AnnoThrow:
  "is_lub,P,E \<turnstile> e \<leadsto> e' \<Longrightarrow> is_lub,P,E \<turnstile> throw e \<leadsto> throw e'"
| AnnoTry:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 \<leadsto> e1';  is_lub,P,E(V \<mapsto> Class C) \<turnstile> e2 \<leadsto> e2' \<rbrakk>
   \<Longrightarrow> is_lub,P,E \<turnstile> try e1 catch(C V) e2 \<leadsto> try e1' catch(C V) e2'"

| AnnoNil:
  "is_lub,P,E \<turnstile> [] [\<leadsto>] []"
| AnnoCons:
  "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e';  is_lub,P,E \<turnstile> es [\<leadsto>] es' \<rbrakk> \<Longrightarrow>  is_lub,P,E \<turnstile> e#es [\<leadsto>] e'#es'"

inductive_cases Anno_cases [elim!]:
  "is_lub',P,E \<turnstile> new C \<leadsto> e"
  "is_lub',P,E \<turnstile> newA T\<lfloor>e\<rceil> \<leadsto> e'"
  "is_lub',P,E \<turnstile> Cast T e \<leadsto> e'"
  "is_lub',P,E \<turnstile> e instanceof T \<leadsto> e'"
  "is_lub',P,E \<turnstile> Val v \<leadsto> e'"
  "is_lub',P,E \<turnstile> Var V \<leadsto> e'"
  "is_lub',P,E \<turnstile> e1 \<guillemotleft>bop\<guillemotright> e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> V := e \<leadsto> e'"
  "is_lub',P,E \<turnstile> e1\<lfloor>e2\<rceil> \<leadsto> e'"
  "is_lub',P,E \<turnstile> e1\<lfloor>e2\<rceil> := e3 \<leadsto> e'"
  "is_lub',P,E \<turnstile> e\<bullet>length \<leadsto> e'"
  "is_lub',P,E \<turnstile> e\<bullet>F{D} \<leadsto> e'"
  "is_lub',P,E \<turnstile> e1\<bullet>F{D} := e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> e\<bullet>M(es) \<leadsto> e'"
  "is_lub',P,E \<turnstile> {V:T=vo; e} \<leadsto> e'"
  "is_lub',P,E \<turnstile> sync(e1) e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> insync(a) e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> e1;; e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> if (e) e1 else e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> while(e1) e2 \<leadsto> e'"
  "is_lub',P,E \<turnstile> throw e \<leadsto> e'"
  "is_lub',P,E \<turnstile> try e1 catch(C V) e2 \<leadsto> e'"

inductive_cases Annos_cases [elim!]:
  "is_lub',P,E \<turnstile> [] [\<leadsto>] es'"
  "is_lub',P,E \<turnstile> e # es [\<leadsto>] es'"

abbreviation Anno' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr \<Rightarrow> bool"  ("_,_ \<turnstile> _ \<leadsto> _"   [51,0,0,51]50)
where "Anno' P \<equiv> Anno (TypeRel.is_lub P) P"

abbreviation Annos' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr list \<Rightarrow> bool"  ("_,_ \<turnstile> _ [\<leadsto>] _" [51,0,0,51]50)
where "Annos' P \<equiv> Annos (TypeRel.is_lub P) P"

definition annotate :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr"
where "annotate P E e = THE_default e (\<lambda>e'. P,E \<turnstile> e \<leadsto> e')"

lemma fixes is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_unique: "\<And>T1 T2 T3 T4. \<lbrakk> \<turnstile> lub(T1, T2) = T3; \<turnstile> lub(T1, T2) = T4 \<rbrakk> \<Longrightarrow> T3 = T4"
  shows Anno_fun: "\<lbrakk> is_lub,P,E \<turnstile> e \<leadsto> e'; is_lub,P,E \<turnstile> e \<leadsto> e'' \<rbrakk> \<Longrightarrow> e' = e''"
  and Annos_fun: "\<lbrakk> is_lub,P,E \<turnstile> es [\<leadsto>] es'; is_lub,P,E \<turnstile> es [\<leadsto>] es'' \<rbrakk> \<Longrightarrow> es' = es''"
proof(induct arbitrary: e'' and es'' rule: Anno_Annos.inducts)
  case (AnnoFAcc E e e' U C F T fm D)
  from `is_lub,P,E \<turnstile> e\<bullet>F{STR []} \<leadsto> e''` show ?case
  proof(rule Anno_cases)
    fix e''' U' C' T' fm' D'
    assume "is_lub,P,E \<turnstile> e \<leadsto> e'''" "is_lub,P,E \<turnstile> e''' :: U'"
      and "class_type_of' U' = \<lfloor>C'\<rfloor>"
      and "P \<turnstile> C' sees F:T' (fm') in D'" "e'' = e'''\<bullet>F{D'}"
    from `is_lub,P,E \<turnstile> e \<leadsto> e'''` have "e' = e'''" by(rule AnnoFAcc)
    with `is_lub,P,E \<turnstile> e' :: U` `is_lub,P,E \<turnstile> e''' :: U'`
    have "U = U'" by(auto intro: WT_unique is_lub_unique)
    with `class_type_of' U = \<lfloor>C\<rfloor>` `class_type_of' U' = \<lfloor>C'\<rfloor>`
    have "C = C'" by(auto)
    with `P \<turnstile> C' sees F:T' (fm') in D'` `P \<turnstile> C sees F:T (fm) in D`
    have "D' = D" by(auto dest: sees_field_fun)
    with `e'' = e'''\<bullet>F{D'}` `e' = e'''` show ?thesis by simp
  next
    fix e''' T
    assume "e'' = e'''\<bullet>length"
      and "is_lub,P,E \<turnstile> e''' :: T\<lfloor>\<rceil>"
      and "is_lub,P,E \<turnstile> e \<leadsto> e'''"
      and "F = array_length_field_name"
    from `is_lub,P,E \<turnstile> e \<leadsto> e'''` have "e' = e'''" by(rule AnnoFAcc)
    with `is_lub,P,E \<turnstile> e' :: U` `is_lub,P,E \<turnstile> e''' :: T\<lfloor>\<rceil>` have "U = T\<lfloor>\<rceil>" by(auto intro: WT_unique is_lub_unique)
    with `class_type_of' U = \<lfloor>C\<rfloor>` `is_Array U \<longrightarrow> F \<noteq> array_length_field_name`
    show ?thesis using `F = array_length_field_name` by simp
  next
    fix C' D' fs ms T D''
    assume "E this = \<lfloor>Class C'\<rfloor>"
      and "class P C' = \<lfloor>(D', fs, ms)\<rfloor>"
      and "e = Var super"
      and "e'' = Cast (Class D') (Var this)\<bullet>F{D''}"
    with `is_lub,P,E \<turnstile> e \<leadsto> e'` have False by(auto)
    thus ?thesis ..
  qed
next
  case AnnoFAccALength thus ?case by(fastforce intro: WT_unique[OF is_lub_unique])
next
  case (AnnoFAss E e1 e1' e2 e2' U C F T fm D)
  from `is_lub,P,E \<turnstile> e1\<bullet>F{STR []} := e2 \<leadsto> e''`
  show ?case
  proof(rule Anno_cases)
    fix e1'' e2'' U' C' T' fm' D'
    assume "is_lub,P,E \<turnstile> e1 \<leadsto> e1''" "is_lub,P,E \<turnstile> e2 \<leadsto> e2''"
      and "is_lub,P,E \<turnstile> e1'' :: U'" and "class_type_of' U' = \<lfloor>C'\<rfloor>"
      and "P \<turnstile> C' sees F:T' (fm') in D'"
      and "e'' = e1''\<bullet>F{D'} := e2''"
    from `is_lub,P,E \<turnstile> e1 \<leadsto> e1''` have "e1' = e1''" by(rule AnnoFAss)
    moreover with `is_lub,P,E \<turnstile> e1' :: U` `is_lub,P,E \<turnstile> e1'' :: U'`
    have "U = U'" by(auto intro: WT_unique is_lub_unique)
    with `class_type_of' U = \<lfloor>C\<rfloor>` `class_type_of' U' = \<lfloor>C'\<rfloor>`
    have "C = C'" by(auto)
    with `P \<turnstile> C' sees F:T' (fm') in D'` `P \<turnstile> C sees F:T (fm) in D`
    have "D' = D" by(auto dest: sees_field_fun)
    moreover from `is_lub,P,E \<turnstile> e2 \<leadsto> e2''` have "e2' = e2''" by(rule AnnoFAss)
    ultimately show ?thesis using `e'' = e1''\<bullet>F{D'} := e2''` by simp
  next
    fix C' D' fs ms T' fm' D'' e'''
    assume "e'' = Cast (Class D') (Var this)\<bullet>F{D''} := e'''"
      and "E this = \<lfloor>Class C'\<rfloor>"
      and "class P C' = \<lfloor>(D', fs, ms)\<rfloor>"
      and "P \<turnstile> D' sees F:T' (fm') in D''"
      and "is_lub,P,E \<turnstile> e2 \<leadsto> e'''"
      and "e1 = Var super"
    with `is_lub,P,E \<turnstile> e1 \<leadsto> e1'` have False by(auto elim: Anno_cases)
    thus ?thesis ..
  qed
qed(fastforce dest: sees_field_fun)+

subsection {* Code generation *}

definition Anno_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr \<Rightarrow> bool" ("_,_ \<turnstile> _ \<leadsto>' _"   [51,0,0,51]50)
where "Anno_code P = Anno (is_lub_sup P) P"

definition Annos_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr list \<Rightarrow> bool" ("_,_ \<turnstile> _ [\<leadsto>''] _" [51,0,0,51]50)
where "Annos_code P = Annos (is_lub_sup P) P"

primrec block_types :: "('a, 'b, 'addr) exp \<Rightarrow> ty list"
  and blocks_types :: "('a, 'b, 'addr) exp list \<Rightarrow> ty list"
where
  "block_types (new C) = []"
| "block_types (newA T\<lfloor>e\<rceil>) = block_types e"
| "block_types (Cast U e) = block_types e"
| "block_types (e instanceof U) = block_types e"
| "block_types (e1\<guillemotleft>bop\<guillemotright>e2) = block_types e1 @ block_types e2"
| "block_types (Val v) = []"
| "block_types (Var V) = []"
| "block_types (V := e) = block_types e"
| "block_types (a\<lfloor>i\<rceil>) = block_types a @ block_types i"
| "block_types (a\<lfloor>i\<rceil> := e) = block_types a @ block_types i @ block_types e"
| "block_types (a\<bullet>length) = block_types a"
| "block_types (e\<bullet>F{D}) = block_types e"
| "block_types (e\<bullet>F{D} := e') = block_types e @ block_types e'"
| "block_types (e\<bullet>M(es)) = block_types e @ blocks_types es"
| "block_types {V:T=vo; e} = T # block_types e"
| "block_types (sync\<^bsub>V\<^esub>(e) e') = block_types e @ block_types e'"
| "block_types (insync\<^bsub>V\<^esub>(a) e) = block_types e"
| "block_types (e;;e') = block_types e @ block_types e'"
| "block_types (if (e) e1 else e2) = block_types e @ block_types e1 @ block_types e2"
| "block_types (while (b) c) = block_types b @ block_types c"
| "block_types (throw e) = block_types e"
| "block_types (try e catch(C V) e') = block_types e @ Class C # block_types e'"

| "blocks_types [] = []"
| "blocks_types (e#es) = block_types e @ blocks_types es"

lemma fixes is_lub1 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>1 lub'((_,/ _)') = _" [51,51,51] 50)
  and is_lub2 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>2 lub'((_,/ _)') = _" [51,51,51] 50)
  assumes wf: "wf_prog wf_md P"
  and is_lub1_into_is_lub2: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>1 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> \<turnstile>2 lub(T1, T2) = T3"
  and is_lub2_is_type: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>2 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T3"
  shows Anno_change_is_lub:
  "\<lbrakk> is_lub1,P,E \<turnstile> e \<leadsto> e'; ran E \<union> set (block_types e) \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> e \<leadsto> e'"
  and Annos_change_is_lub:
  "\<lbrakk> is_lub1,P,E \<turnstile> es [\<leadsto>] es'; ran E \<union> set (blocks_types es) \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> es [\<leadsto>] es'"
proof(induct rule: Anno_Annos.inducts)
  case (AnnoBlock E V T e e' vo)
  from `ran E \<union> set (block_types {V:T=vo; e}) \<subseteq> types P`
  have "ran (E(V \<mapsto> T)) \<union> set (block_types e) \<subseteq> types P"
    by(auto simp add: ran_def)
  thus ?case using AnnoBlock by(blast intro: Anno_Annos.intros)
next
  case (AnnoTry E e1 e1' V C e2 e2')
  from `ran E \<union> set (block_types (try e1 catch(C V) e2)) \<subseteq> types P`
  have "ran (E(V \<mapsto> Class C)) \<union> set (block_types e2) \<subseteq> types P"
    by(auto simp add: ran_def)
  thus ?case using AnnoTry by(simp del: fun_upd_apply)(blast intro: Anno_Annos.intros)
qed(simp_all del: is_Array.simps is_Array_conv, (blast intro: Anno_Annos.intros WT_change_is_lub[OF wf, where ?is_lub1.0=is_lub1 and ?is_lub2.0=is_lub2] is_lub1_into_is_lub2 is_lub2_is_type)+)

lemma assumes wf: "wf_prog wf_md P"
  shows Anno_into_Anno_code: "\<lbrakk> P,E \<turnstile> e \<leadsto> e'; ran E \<union> set (block_types e) \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e \<leadsto>' e'"
  and Annos_into_Annos_code: "\<lbrakk> P,E \<turnstile> es [\<leadsto>] es'; ran E \<union> set (blocks_types es) \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [\<leadsto>'] es'"
proof -
  assume anno: "P,E \<turnstile> e \<leadsto> e'"
    and ran: "ran E \<union> set (block_types e) \<subseteq> types P"
  show "P,E \<turnstile> e \<leadsto>' e'" unfolding Anno_code_def
    by(rule Anno_change_is_lub[OF wf _ _ anno ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+
next
  assume annos: "P,E \<turnstile> es [\<leadsto>] es'"
    and ran: "ran E \<union> set (blocks_types es) \<subseteq> types P"
  show "P,E \<turnstile> es [\<leadsto>'] es'" unfolding Annos_code_def
    by(rule Annos_change_is_lub[OF wf _ _ annos ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+
qed

lemma assumes wf: "wf_prog wf_md P"
  shows Anno_code_into_Anno: "\<lbrakk> P,E \<turnstile> e \<leadsto>' e'; ran E \<union> set (block_types e) \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e \<leadsto> e'"
  and Annos_code_into_Annos: "\<lbrakk> P,E \<turnstile> es [\<leadsto>'] es'; ran E \<union> set (blocks_types es) \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [\<leadsto>] es'"
proof -
  assume anno: "P,E \<turnstile> e \<leadsto>' e'"
    and ran: "ran E \<union> set (block_types e) \<subseteq> types P"
  show "P,E \<turnstile> e \<leadsto> e'"
    by(rule Anno_change_is_lub[OF wf _ _ anno[unfolded Anno_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
next
  assume annos: "P,E \<turnstile> es [\<leadsto>'] es'"
    and ran: "ran E \<union> set (blocks_types es) \<subseteq> types P"
  show "P,E \<turnstile> es [\<leadsto>] es'"
    by(rule Annos_change_is_lub[OF wf _ _ annos[unfolded Annos_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+
qed

lemma fixes is_lub
  assumes wf: "wf_prog wf_md P"
  shows WT_block_types_is_type: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> set (block_types e) \<subseteq> types P"
  and WTs_blocks_types_is_type: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> set (blocks_types es) \<subseteq> types P"
apply(induct rule: WT_WTs.inducts)
apply(auto intro: is_class_sub_Throwable[OF wf])
done

lemma fixes is_lub
  shows Anno_block_types: "is_lub,P,E \<turnstile> e \<leadsto> e' \<Longrightarrow> block_types e = block_types e'"
  and Annos_blocks_types: "is_lub,P,E \<turnstile> es [\<leadsto>] es' \<Longrightarrow> blocks_types es = blocks_types es'"
by(induct rule: Anno_Annos.inducts) auto

code_pred
  (modes: (i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [detect_switches, skip_proof]
  Anno
.

definition annotate_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> 'addr expr"
where "annotate_code P E e = THE_default e (\<lambda>e'. P,E \<turnstile> e \<leadsto>' e')"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  Anno_code
.

lemma eval_Anno_i_i_i_o_conv:
  "Predicate.eval (Anno_code_i_i_i_o P E e) = (\<lambda>e'. P,E \<turnstile> e \<leadsto>' e')"
by(auto intro!: ext intro: Anno_code_i_i_i_oI elim: Anno_code_i_i_i_oE)

lemma annotate_code [code]:
  "annotate_code P E e = Predicate.singleton (\<lambda>_. Code.abort (STR ''annotate'') (\<lambda>_. e)) (Anno_code_i_i_i_o P E e)"
by(simp add: THE_default_def Predicate.singleton_def annotate_code_def eval_Anno_i_i_i_o_conv)

end