(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: fmi.thy                                                              *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 20 Sep 2017 *)

section {* FMI {\Circus} Model *}

theory fmi
imports "UTP-Toolkit.Positive" Time
  "UTP-Axm.utp_axm"
  "../theories/utp_circus"
begin recall_syntax

declare [[typedef_overloaded]]
declare [[quick_and_dirty]]

default_sort type

subsection {* Preliminaries *}

subsubsection {* Syntax Extensions *}

paragraph \<open>Application and update of HOL partial functions.\<close>

definition map_apply :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
"map_apply f = the o f"

adhoc_overloading uapply map_apply

definition map_upd :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"map_upd m x y = m(x \<mapsto> y)"

text \<open>The commented-out overloading causes parsing ambiguities.\<close>

adhoc_overloading (* uupd fun_upd and *) uupd map_upd

paragraph {* Positive Subtype *}

text \<open>Lifted coercion operator from @{typ "'a pos"} to @{typ "'a"}.\<close>

syntax "_uRep_pos" :: "('a pos, '\<alpha>) uexpr \<Rightarrow> ('a, '\<alpha>) uexpr" ("\<section>'(_')")

translations "_uRep_pos p" \<rightleftharpoons> "(CONST uop) (CONST Rep_pos) p"

subsubsection {* Class Instantiations *}

lemma card_gt_two_witness:
"finite S \<Longrightarrow> 2 \<le> card S \<Longrightarrow> (\<exists>a\<in>S. \<exists>b\<in>S. a \<noteq> b)"
apply (atomize (full))
apply (rule impI)
apply (erule finite.induct)
-- {* Subgoal 1 *}
apply (simp)
-- {* Subgoal 2 *}
apply (clarify)
apply (case_tac "a \<in> A")
-- {* Subgoal 2.1 *}
apply (simp add: insert_absorb)
-- {* Subgoal 2.2 *}
apply (rule_tac x = "a" in bexI)
apply (clarsimp)
using card_le_Suc_iff apply (blast)
apply (simp)
done

theorem card_ge_two_unfold:
"finite S \<Longrightarrow> 2 \<le> card S = (\<exists>x y. x \<in> S \<and> y \<in> S \<and> x \<noteq> y)"
apply (rule iffI)
-- {* Subgoal 1 *}
using card_gt_two_witness apply (blast)
-- {* Subgoal 2 *}
apply (case_tac "card S = 0")
apply (clarsimp)
apply (case_tac "card S = 1")
apply (clarsimp)
using card_eq_SucD apply (blast)
apply (clarsimp)
apply (meson card_eq_0_iff less_2_cases not_less)
done

theorem instance_twoI:
"\<exists>x y. x \<in> S \<and> y \<in> S \<and> x \<noteq> y \<Longrightarrow> \<not> finite S \<or> 2 \<le> card S"
apply (case_tac "finite S")
apply (simp_all)
apply (subst card_ge_two_unfold)
apply (assumption)
apply (clarsimp)
done

text {* By default, the product type did not instantiate class @{class two}. *}

instance prod :: (two, two) two
apply (intro_classes)
apply (rule instance_twoI)
apply (subgoal_tac "\<exists>(a::'a) (b::'a). a \<noteq> b")
apply (subgoal_tac "\<exists>(c::'b) (d::'b). c \<noteq> d")
apply (clarsimp)
apply (rule two_diff)
apply (rule two_diff)
done

text {* By default, the product type did not instantiate @{class vst}. *}

instantiation prod :: (vst, vst) vst
begin
definition vstore_lens_prod :: "vstore \<Longrightarrow> 'a \<times> 'b" where
"vstore_lens_prod = vstore_lens ;\<^sub>L fst\<^sub>L"
instance
apply (intro_classes)
apply (unfold vstore_lens_prod_def)
apply (simp)
done
end

subsection {* FMI Types  *}

text {* In this section, we encode the various FMI types in HOL. *}

subsubsection {* \<open>TIME\<close> and \<open>NZTIME\<close> *}

text {*
  Our aim is to treat time abstractly in the FMI model via some arbitrary type
  @{typ "'\<tau>"} that must be a member of class @{class time}. We thus introduce
  additional syntax below to impose the respective sort constraint(s). We also
  require that time can be injected into deep variable stores. In particular,
  membership to @{class linordered_ab_group_add} ensures @{class continuum}
  closure under the @{typ "'a pos"} type.
*}

class ctime = time + linordered_ab_group_add + continuum + two (* + injectable *)

syntax   "_TIME" :: "type \<Rightarrow> type" ("TIME'(_')")
syntax "_NZTIME" :: "type \<Rightarrow> type" ("NZTIME'(_')")

translations (type) "TIME('\<tau>)" \<rightleftharpoons> (type) "'\<tau>::ctime"
translations (type) "NZTIME('\<tau>)" \<rightleftharpoons> (type) "'\<tau>::ctime pos"

subsubsection {* \<open>FMI2COMP\<close> *}

text {*
  The type @{text FMI2COMP} of FMI component identifiers is introduced as a
  given (deferred) type. Concrete co-simulation models have to introduced an
  axiomatisation in order to determine the elements of this type, along with
  the additional property that they are distinct and partition the type.
*}

typedecl FMI2COMP

text {* Syntactic sugar for \<open>UNIV::FMI2COMP set\<close>. *}

abbreviation FMI2COMP :: "FMI2COMP set" where
"FMI2COMP \<equiv> UNIV"

text {*
  We require the type @{type FMI2COMP} to be finite and containing at least two
  elements. This is important so that we can later on instantiate it as members
  of @{class two} and @{class continuum} for injection into the deep variable
  model. We observe that FMI {\Circus} processes use state and local variables
  involving the type @{type FMI2COMP}. To avoid the need for axioms, locales
  could perhaps be used.
*}

axiomatization where
  FMI2COMP_finite: "finite FMI2COMP" and
  FMI2COMP_gt_two: "card FMI2COMP \<ge> 2"

text {* Instantiation of relevant classes for the axiomatic value model. *}

instantiation FMI2COMP :: typerep
begin
definition typerep_FMI2COMP :: "FMI2COMP itself \<Rightarrow> utype" where
[typing]: "typerep_FMI2COMP t = typerep.Typerep (STR ''fmi.FMI2COMP'') []"
instance ..
end

instantiation FMI2COMP :: typedep
begin
definition typedep_FMI2COMP :: "FMI2COMP itself \<Rightarrow> utype set" where
[typing]: "typedep_FMI2COMP t = {TYPEREP(FMI2COMP)}"
instance ..
end

text {* Injection into the axiomatic value model. *}

inject_type FMI2COMP

text {* The below facilitates evaluation of the transitive closure of PDGs. *}

instantiation FMI2COMP :: equal
begin
definition equal_FMI2COMP ::"FMI2COMP \<Rightarrow> FMI2COMP \<Rightarrow> bool" where
"equal_FMI2COMP x y = (x = y)"
instance
apply (intro_classes)
apply (unfold equal_FMI2COMP_def)
apply (rule refl)
done
end

text {* Instantiation of relevant classes for the deep value model. *}

instance FMI2COMP :: finite
apply (intro_classes)
apply (rule FMI2COMP_finite)
done

-- {* The above already guarantees membership to class @{class continuum}. *}

instance FMI2COMP :: "{continuum, two}"
apply (intro_classes)
apply (rule disjI2)
apply (rule FMI2COMP_gt_two)
done

subsubsection {* \<open>FMUSTATE\<close> *}

text {*
  Likewise, @{text FMUSTATE} is introduced as a given type for now. We may
  need to review this in the future; for instance, the universal value model
  could be used to encode a generic (monomorphic) state type able to encode
  the state of any concrete FMU.
*}

typedecl FMUSTATE

text {* Instantiation of relevant classes for the axiomatic value model. *}

instantiation FMUSTATE :: typerep
begin
definition typerep_FMUSTATE :: "FMUSTATE itself \<Rightarrow> utype" where
[typing]: "typerep_FMUSTATE t = typerep.Typerep (STR ''fmi.FMUSTATE'') []"
instance ..
end

instantiation FMUSTATE :: typedep
begin
definition typedep_FMUSTATE :: "FMUSTATE itself \<Rightarrow> utype set" where
[typing]: "typedep_FMUSTATE t = {TYPEREP(FMUSTATE)}"
instance ..
end

text {* Injection into the axiomatic value model. *}

inject_type FMUSTATE

text {* Instantiation of relevant classes for the deep value model. *}

text {*
  Clearly, it is not possible to prove that @{type FMUSTATE} is an instance of
  either class @{class two} or @{class continuum} due to its abstract nature.
  The only solution is once again to encapsulate the instantiation axioms as
  global axiomatic properties of the @{type FMUSTATE} type. Likewise, it may
  be safer to use a @{command locale} instead of an @{command axiomatization}.
*}

axiomatization where
   FMUSTATE_continuum: "OFCLASS(FMUSTATE, continuum_class)" and
   FMUSTATE_two:       "OFCLASS(FMUSTATE, two_class)"

text {* The instantiation below is proved by virtue of the axioms above. *}

instance FMUSTATE :: "{continuum, two}"
apply (rule FMUSTATE_continuum)
apply (rule FMUSTATE_two)
done

subsubsection {* \<open>VAR\<close> and \<open>VAL\<close> *}

text {* Type synonyms for permissible FMI 2.0 port types. *}

type_synonym fmi2Real = "real"
type_synonym fmi2Integer = "int"
type_synonym fmi2String = "string"
type_synonym fmi2Boolean = "bool"

text {*
  The FMI types of \<open>VAR\<close> and \<open>VAL\<close> are equated with the unified variable and
  value types of the axiomatic value model. While we could have alternatively
  used deep variables here, an approach via axiomatic variables means that we
  are not restricted to the standard FMI types. An issue is thought that \<open>VAL\<close>
  itself is clearly not injectable. The ranked axiomatic model may provide a
  solution to this problem, but this is work in progress for now.
*}

type_synonym VAR = "uvar.uvar" ("VAR")
type_synonym VAL = "uval.uval" ("VAL")

text {* Translations for pretty-printing. *}

translations (type) "VAR" \<leftharpoondown> (type) "uvar.uvar"
translations (type) "VAL" \<leftharpoondown> (type) "uval.uval"

subsubsection {* \<open>FMIST\<close> and \<open>FMISTF\<close> *}

text {* We declare a datatype for \<open>fmi2Status\<close> flags the FMI API. *}

datatype FMI2ST =
  fmi2OK |
  fmi2Error |
  fmi2Fatal
  (*fmi2Warning *)
  (*fmi2Penidng *)

text {* Instantiation of relevant classes for the axiomatic value model. *}

inject_type FMI2ST

text {* Instantiation of relevant classes for the deep value model. *}

text {* We note that countability implies membership to @{class continuum} *}

instance FMI2ST :: countable
apply (countable_datatype)
done

instance FMI2ST :: continuum
apply (intro_classes)
done

instance FMI2ST :: two
apply (intro_classes)
apply (rule instance_twoI)
apply (rule_tac x = "fmi2OK" in exI)
apply (rule_tac x = "fmi2Error" in exI)
apply (clarsimp)
done

subsubsection {* \<open>FMUSTF\<close> *}

datatype FMI2STF =
  fmi2Status (fmi2StatusOf: "FMI2ST") |
  fmi2Discard

text {* Instantiation of relevant classes for the axiomatic value model. *}

inject_type FMI2STF

text {* Instantiation of relevant classes for the deep value model. *}

text {* We note that countability implies membership to @{class continuum} *}

instance FMI2STF :: countable
apply (countable_datatype)
done

instance FMI2STF :: continuum
apply (intro_classes)
done

instance FMI2STF :: two
apply (intro_classes)
apply (rule instance_twoI)
apply (rule_tac x = "fmi2Status _" in exI)
apply (rule_tac x = "fmi2Discard" in exI)
apply (clarsimp)
done

subsubsection {* Error Flags *}

typedef ErrorFlag = "{fmi2Error, fmi2Fatal}"
apply (rule_tac x = "fmi2Error" in exI)
apply (clarsimp)
done

text {* Instantiation of relevant classes for the axiomatic value model. *}

inject_type ErrorFlag

text {* Instantiation of relevant classes for the deep value model. *}

text {* We note that countability implies membership to @{class continuum} *}

instance ErrorFlag :: countable
apply (intro_classes)
apply (rule_tac x = "to_nat o Rep_ErrorFlag" in exI)
apply (rule inj_comp)
-- {* Subgoal 1 *}
apply (simp)
-- {* Subgoal 2 *}
apply (rule inj_onI; clarsimp)
apply (simp add: Rep_ErrorFlag_inject)
done

instance ErrorFlag :: continuum
apply (intro_classes)
done

instance ErrorFlag :: two
apply (intro_classes)
apply (rule instance_twoI)
apply (rule_tac x = "Abs_ErrorFlag fmi2Error" in exI)
apply (rule_tac x = "Abs_ErrorFlag fmi2Fatal" in exI)
apply (simp add: Abs_ErrorFlag_inject)
done

subsection {* FMI Events *}

text {*
  While the trace type for CSP is fixed to @{typ "'a list"}, we still have to
  define the event type @{typ "'a"}. Generally, we can think of events as sum
  types. Since events may be parametric, as with states there is an issue how
  to model events with different (HOL) types as a single unified type. A deep
  model may encode them as pairs consisting of a name \& type. Below, we adopt
  a shallow model that uses a datatype construction wrapped into a @{type sum}
  type as to make the datatype extensible. As an alternative, Simon mentioned
  \emph{prisms} as an analogue of lenses for sum types.
*}

subsubsection {* FMI API Channels *}

text {*
  We note that all constructor functions are of type @{type chan}. To obtain
  extensible event types, we introduce a prefixing (scoping) operator for each
  channel type that lifts the underlying datatype into a @{type sum} type with
  an open slot for later extension. Eventually, those prefix operators will be
  introduced automatically by the tool, namely through a custom @{text events}
  command for defining channel events (future work).
*}

datatype '\<tau>::ctime fmi_event =
  fmi2Get "FMI2COMP \<times> VAR \<times> VAL \<times> FMI2ST" |
  fmi2Set "FMI2COMP \<times> VAR \<times> VAL \<times> FMI2STF" |
  fmi2DoStep "FMI2COMP \<times> TIME('\<tau>) \<times> NZTIME('\<tau>) \<times> FMI2STF" |
  fmi2Instantiate "FMI2COMP \<times> bool" |
  fmi2SetUpExperiment "FMI2COMP \<times> TIME('\<tau>) \<times> bool \<times> TIME('\<tau>) \<times> FMI2ST" |
  fmi2EnterInitializationMode "FMI2COMP \<times> FMI2ST" |
  fmi2ExitInitializationMode "FMI2COMP \<times> FMI2ST" |
  fmi2GetBooleanStatusfmi2Terminated "FMI2COMP \<times> bool \<times> FMI2ST" |
  fmi2GetMaxStepSize "FMI2COMP \<times> TIME('\<tau>) \<times> FMI2ST" |
  fmi2Terminate "FMI2COMP \<times> FMI2ST" |
  fmi2FreeInstance "FMI2COMP \<times> FMI2ST" |
  fmi2GetFMUState "FMI2COMP \<times> FMUSTATE \<times> FMI2ST" |
  fmi2SetFMUState "FMI2COMP \<times> FMUSTATE \<times> FMI2ST"

abbreviation fmi_prefix ::
  "('a, '\<tau>::ctime fmi_event) chan \<Rightarrow>
   ('a, ('\<tau>::ctime fmi_event) + 'ext) chan" where
"fmi_prefix c \<equiv> Inl o c"

notation fmi_prefix ("fmi:_" [1000] 1000)

abbreviation "FMIAPI \<equiv>
  \<epsilon>(fmi:fmi2Get) \<union>
  \<epsilon>(fmi:fmi2Set) \<union>
  \<epsilon>(fmi:fmi2DoStep) \<union>
  \<epsilon>(fmi:fmi2Instantiate) \<union>
  \<epsilon>(fmi:fmi2SetUpExperiment) \<union>
  \<epsilon>(fmi:fmi2EnterInitializationMode) \<union>
  \<epsilon>(fmi:fmi2ExitInitializationMode) \<union>
  \<epsilon>(fmi:fmi2GetBooleanStatusfmi2Terminated) \<union>
  \<epsilon>(fmi:fmi2GetMaxStepSize) \<union>
  \<epsilon>(fmi:fmi2Terminate) \<union>
  \<epsilon>(fmi:fmi2FreeInstance) \<union>
  \<epsilon>(fmi:fmi2GetFMUState) \<union>
  \<epsilon>(fmi:fmi2SetFMUState)"

subsubsection {* Timer Channels *}

datatype '\<tau>::ctime timer_event =
  setT "TIME('\<tau>)" |
  updateSS "NZTIME('\<tau>)" |
  step "TIME('\<tau>) \<times> NZTIME('\<tau>)" |
  endc "unit"

abbreviation timer_prefix ::
  "('a, '\<tau>::ctime timer_event) chan \<Rightarrow>
   ('a, ('\<tau>::ctime fmi_event) + ('\<tau>::ctime timer_event) + 'ext) chan" where
"timer_prefix c \<equiv> Inr o Inl o c"

notation timer_prefix ("tm:_" [1000] 1000)

abbreviation "tm_events \<equiv>
  \<epsilon>(tm:step) \<union> \<epsilon>(tm:endc) \<union> \<epsilon>(tm:setT) \<union> \<epsilon>(tm:updateSS)"

subsubsection {* Control Channels *}

type_synonym error = (* "ErrorFlag" *) "FMI2ST"

datatype ctrl_event =
  stepToComplete "unit" |
  stepAnalysed "unit" |
  stepComplete "unit" |
  endsimulation "unit" |
  error "error"

abbreviation ctrl_prefix ::
  "('a, ctrl_event) chan \<Rightarrow>
   ('a, ('\<tau>::ctime fmi_event) + ('\<tau>::ctime timer_event) + (ctrl_event) + 'ext) chan" where
"ctrl_prefix c \<equiv> Inr o Inr o Inl o c"

notation ctrl_prefix ("ctr:_" [1000] 1000)

abbreviation "ctrl_events \<equiv>
  \<epsilon>(ctr:stepToComplete) \<union>
  \<epsilon>(ctr:stepAnalysed) \<union>
  \<epsilon>(ctr:stepComplete) \<union>
  \<epsilon>(ctr:endsimulation) \<union>
  \<epsilon>(ctr:error)"

subsubsection {* FMI Process Type *}

type_synonym ('\<sigma>, '\<tau>, 'ext) fmi_action =
  "('\<sigma>, '\<tau> fmi_event + '\<tau> timer_event + ctrl_event + 'ext) action"

type_synonym ('\<tau>, 'ext) fmi_process = "(unit, '\<tau>, 'ext) fmi_action"

subsection {* FMI Ports *}

text {*
  For readability, we introduce a @{command type_synonym} for FMI ports. A port
  is encoded by a pair consisting of an FMI component (of type @{type FMI2COMP})
  and a variable (of type @{type VAR}). We do not distinguish input and output
  ports at the level of the encoding.
*}

type_synonym port = "FMI2COMP \<times> VAR" ("PORT")

text {* Shall we pretty-print the @{typ PORT} type too? *}

(* translations (type) "PORT" \<leftharpoondown> (type) "FMI2COMP \<times> VAR" *)

text \<open>Getter function to obtain the FMU and name of a port object.\<close>

abbreviation FMU :: "PORT \<Rightarrow> FMI2COMP" where
"FMU port \<equiv> (fst port)"

abbreviation name :: "PORT \<Rightarrow> VAR" where
"name port \<equiv> (snd port)"

subsection {* FMI Configuration *}

text {*
  The configuration for a particular FMI system is introduced abstractly via
  HOL constants. A concrete model can provide overloaded definitions to give
  concrete meanings to them; this may allow us to potentially prove additional
  properties. An open question is whether some additional caveats need to be
  specified already here (e.g.~acyclicity  of the port dependency graph). This
  could possibly be done through a type definition. We note that we encode the
  Z type @{text "seq"} by HOL's list type @{typ "'a list"}.
*}

text {*
  In line with the CSP model of Deliverable D2.2d, I added a separate list
  \<open>initialValues\<close> rather than using the \<open>inputs\<close> sequence to provide initial
  values for inputs. This also proves to be slightly more convenient in terms
  of the mechanised model. Further, I changed the type of the port dependency
  graph to bee a function rather than a relation, mapping each outputs to a
  list of connected inputs. The advantage of this is that it facilitates the
  definition of the @{text DistributeInputs} action since currently, iterated
  sequence e.g.~of actions is only define for lists but not for (finite) sets.
  Lastly, I included another relation \<open>idd\<close> to record the internal direct
  dependencies of the FMI system. Conceptually, it turns out that it is not
  the \<open>pdg\<close> that has to be acyclic but the union of the \<open>pdg\<close> and \<open>idd\<close> to
  guarantee the absence of algebraic loops.
*}

-- \<open>In D2.2d: \<open>inputs :: FMI2COMP \<times> VAR \<times> VAL\<close> and \<open>pdg :: PORT relation\<close>.\<close>

consts
  FMUs :: "FMI2COMP list"
  parameters :: "(FMI2COMP \<times> VAR \<times> VAL) list"
  initialValues :: "(PORT \<times> VAL) list"
  inputs :: "PORT list"
  outputs :: "PORT list"
  pdg :: "PORT \<Rightarrow> (PORT list)" -- \<open>Port Dependency Graph\<close>
  idd :: "PORT \<Rightarrow> (PORT list)" -- \<open>Internal Direct Dependencies\<close>

subsection {* Simulation Parameters *}

-- {* In line with the D2.2d example, I added these as global constants, too. *}

consts startTime :: "TIME('\<tau>)"
consts stopTimeDefined :: "bool"
consts stopTime :: "TIME('\<tau>)"

subsection {* FMI Processes *}

subsubsection {* \<open>Timer\<close> Process *}

alphabet '\<tau>::ctime timer_state =
  currentTime :: "TIME('\<tau>)"
  stepSize :: "NZTIME('\<tau>)"

type_synonym '\<tau> timer_action =
  "('\<tau> timer_state, '\<tau> timer_event) action"

definition
"process Timer(ct::TIME('\<tau>), hc::NZTIME('\<tau>), tN::TIME('\<tau>)) \<triangleq> begin
  state('\<tau> timer_state)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> currentTime :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> stepSize :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&currentTime)!(&stepSize) \<^bold>\<rightarrow>
      currentTime :=\<^sub>C min\<^sub>u(&currentTime + \<section>(&stepSize), \<guillemotleft>tN\<guillemotright>)) \<box>
    (&currentTime =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> (currentTime, stepSize) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

text \<open>The same process definition using deep variables.\<close>

definition
"process DvarTimer(ct::TIME('\<tau>), hc::NZTIME('\<tau>), tN::TIME('\<tau>)) \<triangleq> begin
  state(vstore)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> <currentTime> :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> <stepSize> :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&<currentTime>)!(&<stepSize>) \<^bold>\<rightarrow>
      <currentTime> :=\<^sub>C min\<^sub>u(&<currentTime> + \<section>(&<stepSize>), \<guillemotleft>tN\<guillemotright>)) \<box>
    (&<currentTime> =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> (<currentTime>, <stepSize>) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"

(*<*)
(*
text \<open>The same process definition using axiomatic variables. FIX!\<close>

definition
"process AvarTimer(ct::TIME('\<tau>), hc::NZTIME('\<tau>), tN::TIME('\<tau>)) \<triangleq> begin
  state(ust_store)
  Step = (
    (tm:setT?(t : \<guillemotleft>t \<le> tN\<guillemotright>) \<^bold>\<rightarrow> {currentTime} :=\<^sub>C \<guillemotleft>t\<guillemotright>) \<box>
    (tm:updateSS?(ss) \<^bold>\<rightarrow> {stepSize} :=\<^sub>C \<guillemotleft>ss\<guillemotright>) \<box>
    (tm:step!(&{currentTime})!(&{stepSize}) \<^bold>\<rightarrow>
      {currentTime} :=\<^sub>C min\<^sub>u(&{currentTime} + \<section>(&{stepSize}), \<guillemotleft>tN\<guillemotright>)) \<box>
    (&{currentTime} =\<^sub>u \<guillemotleft>tN\<guillemotright>) &\<^sub>u tm:endc \<^bold>\<rightarrow> Stop) ;; Step
  \<bullet> ({currentTime}, {stepSize}) :=\<^sub>C (\<guillemotleft>ct\<guillemotright>, \<guillemotleft>hc\<guillemotright>) ;; Step
end"
*)
(*>*)

text \<open>Prove that @{const Timer} and @{const DvarTimer} do not diverge.\<close>

lemma "pre\<^sub>R(Timer(ct, hc, tN)) = true\<^sub>r"
apply (unfold Timer_def)
apply (rdes_calc)
apply (rel_simp)
done

lemma "pre\<^sub>R(DvarTimer(ct, hc, tN)) = true\<^sub>r"
apply (unfold DvarTimer_def)
apply (rdes_calc)
apply (rel_simp)
done

subsubsection {* \<open>Interaction\<close> Process *}

text \<open>
  We here use the type @{typ "PORT \<rightharpoonup> VAL"} for \<open>rinps\<close>, rather than the type
  @{typ "FMI2COMP \<rightharpoonup> (VAR \<rightharpoonup> VAL)"} as in Figure 4 of D2.2d. Simon developed a
  separate embedding of partial maps in theory @{theory Pfun}); it may be worth
  considering using it here too. Importantly, the state space also includes a
  store for local (deep) variables. I wonder if there is another solution for
  integrating deep variables into alphabets. We could have, of course, also
  encoded \<open>rinps\<close> as a deep variable, but this would then constrain its type
  to be a member of the classes @{class "continuum"} and @{class "two"}.
\<close>

alphabet ia_state =
  rinps :: "PORT \<rightharpoonup> VAL"
  ia_locals :: "vstore"

instantiation ia_state_ext :: (type) vst
begin
definition vstore_lens_ia_state_ext :: "vstore \<Longrightarrow> 'a ia_state_scheme" where
"\<V> = ia_locals"
instance
apply (intro_classes)
apply (simp add: vstore_lens_ia_state_ext_def)
done
end

definition
"process Interaction \<triangleq> begin
  state(ia_state)

  Instantiation = (;;\<^sub>C i : FMUs \<bullet>
    fmi:fmi2Instantiate.(\<guillemotleft>i\<guillemotright>)?(sc) \<^bold>\<rightarrow> Skip) and

  InstantiationMode =
    (;;\<^sub>C (i, x, v) : parameters \<bullet>
      fmi:fmi2Set!(\<guillemotleft>i\<guillemotright>)!(\<guillemotleft>x\<guillemotright>)!(\<guillemotleft>v\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) ;;
    (;;\<^sub>C i : FMUs \<bullet>
      fmi:fmi2SetUpExperiment!(\<guillemotleft>i\<guillemotright>)!(\<guillemotleft>startTime\<guillemotright>)
        !(\<guillemotleft>stopTimeDefined\<guillemotright>)!(\<guillemotleft>stopTime\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) ;;
    (;;\<^sub>C i : FMUs \<bullet>
      fmi:fmi2EnterInitializationMode.(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) and

  InitializationMode =
    (;;\<^sub>C ((i, x), v) : initialValues \<bullet>
      fmi:fmi2Set!(\<guillemotleft>i\<guillemotright>)!(\<guillemotleft>x\<guillemotright>)!(\<guillemotleft>v\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) ;;
    (;;\<^sub>C i : FMUs \<bullet>
      fmi:fmi2ExitInitializationMode!(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) and

  TakeOutputs = rinps :=\<^sub>C \<guillemotleft>empty\<guillemotright> ;;
    (;;\<^sub>C out : outputs \<bullet>
      fmi:fmi2Get.(\<guillemotleft>FMU out\<guillemotright>).(\<guillemotleft>name out\<guillemotright>)?(v)?(st) \<^bold>\<rightarrow>
        (;;\<^sub>C inp : pdg out \<bullet> rinps :=\<^sub>C &rinps(\<guillemotleft>inp\<guillemotright> \<mapsto> \<guillemotleft>v\<guillemotright>)\<^sub>u)) and

  DistributeInputs = (;;\<^sub>C inp : inputs \<bullet>
    fmi:fmi2Set.(\<guillemotleft>FMU inp\<guillemotright>).(\<guillemotleft>name inp\<guillemotright>)!(&rinps(\<guillemotleft>inp\<guillemotright>)\<^sub>a)?(st) \<^bold>\<rightarrow> Skip) and

  (* Review the function below, Casper hinted some possible issues. I recall
   * this has to do with the use of fmi2GetMaxStepSize(_). Such ought to be
   * called before the simulation step is performed via fmi2DoStep(_). Also,
   * master algorithms may want to enquire the maximum predicted step size of
   * all FMUs first, before performing any simulation steps. Lastly, it is
   * not part of the FMI 2.0 Standard, hence should be model it here at all? *)

  Step = (;;\<^sub>C i : [0..(length FMUs)] \<bullet>
    (if i = 0 then
      ctr:stepToComplete \<^bold>\<rightarrow>
        (fmi:fmi2DoStep.(\<guillemotleft>FMUs!0\<guillemotright>).(&<t>).(&<hc>)?(st) \<^bold>\<rightarrow> Skip)
    else if i < (length FMUs) then
      (\<mu>\<^sub>C X \<bullet>
        (fmi:fmi2GetBooleanStatusfmi2Terminated.(\<guillemotleft>FMUs!nat (i-1)\<guillemotright>)?(b)?(st) \<^bold>\<rightarrow> X) \<box>
        (fmi:fmi2GetMaxStepSize.(\<guillemotleft>FMUs!nat (i-1)\<guillemotright>)?(t)?(st) \<^bold>\<rightarrow> X)) \<box>
        (fmi:fmi2DoStep.(\<guillemotleft>FMUs!nat i\<guillemotright>).(&<t>).(&<hc>)?(st) \<^bold>\<rightarrow> Skip)
    else
      (\<mu>\<^sub>C X \<bullet>
        (fmi:fmi2GetBooleanStatusfmi2Terminated.(\<guillemotleft>FMUs!nat (i-1)\<guillemotright>)?(b)?(st) \<^bold>\<rightarrow> X) \<box>
        (fmi:fmi2GetMaxStepSize.(\<guillemotleft>FMUs!nat (i-1)\<guillemotright>)?(t)?(st) \<^bold>\<rightarrow> X)) \<box>
        (ctr:stepAnalysed \<^bold>\<rightarrow> Skip)))
    (* ;; NextStep *) and

  Terminated =
    (;;\<^sub>C i : FMUs \<bullet>
      fmi:fmi2Terminate.(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> fmi:fmi2FreeInstance.(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) ;;
    ctr:endsimulation \<^bold>\<rightarrow> Skip and

  slaveInitialized =
    (tm:endc \<^bold>\<rightarrow> Terminated) \<box>
    (tm:step?(t)?(hc) \<^bold>\<rightarrow> (
      (<t>, <hc>) :=\<^sub>C (\<guillemotleft>t::TIME('\<tau>)\<guillemotright>, \<guillemotleft>hc::NZTIME('\<tau>)\<guillemotright>));;
    TakeOutputs ;; DistributeInputs ;; Step) and

  (* I had to add the sequence ... ;; NextStep below to get around the issue of
   * mutual recursion in the original CSP model of the Interaction process. *)

  NextStep =
    (tm:updateSS?(d) \<^bold>\<rightarrow> NextStep) \<box>
    (tm:setT?(t) \<^bold>\<rightarrow> NextStep) \<box>
    (slaveInitialized ;; NextStep) \<box>
    (Terminated)

  \<bullet> Instantiation ;; InstantiationMode ;; InitializationMode ;; slaveInitialized ;; NextStep
end"

theorem "P Interaction"
apply (unfold Interaction_def)
apply (simp add: circus_syntax Let_def)
oops

lemma "pre\<^sub>R(Interaction) = true\<^sub>r"
apply (unfold Interaction_def)
apply (simp add: circus_syntax Let_def)
apply (rdes_calc)
oops

subsubsection {* End Simulation Process *}

definition
"process endSimulation \<triangleq> ctr:endsimulation \<^bold>\<rightarrow> Skip"

subsubsection {* \<open>FMUStatesManager\<close> Process *}

text {* Since we only have a single state component. *}

abbreviation fmu_state :: "FMUSTATE \<Longrightarrow> FMUSTATE" where
"fmu_state \<equiv> 1\<^sub>L"

definition
"process FMUStateManager(i::FMI2COMP) \<triangleq> begin
  state(FMUSTATE)

  AllowsGetsAndSets =
    (fmi:fmi2GetFMUState!(\<guillemotleft>i\<guillemotright>)?(s)?(st) \<^bold>\<rightarrow>
      (fmu_state :=\<^sub>C \<guillemotleft>s\<guillemotright>) ;; AllowsGetsAndSets) \<box>
    (fmi:fmi2SetFMUState!(\<guillemotleft>i\<guillemotright>)!(&fmu_state)?(st) \<^bold>\<rightarrow> AllowsGetsAndSets) and

  AllowAGet =
    (fmi:fmi2GetFMUState!(\<guillemotleft>i\<guillemotright>)?(s)?(st) \<^bold>\<rightarrow>
      (fmu_state :=\<^sub>C \<guillemotleft>s\<guillemotright>) ;; AllowsGetsAndSets)

  \<bullet> fmi:fmi2Instantiate!(\<guillemotleft>i\<guillemotright>)?(b) \<^bold>\<rightarrow> AllowAGet
end"

text \<open>The same process definition using deep variables.\<close>

definition
"process DVarFMUStateManager(i::FMI2COMP) \<triangleq> begin
  state(vstore)

  AllowsGetsAndSets =
    (fmi:fmi2GetFMUState!(\<guillemotleft>i\<guillemotright>)?(s)?(st) \<^bold>\<rightarrow>
      (<fmu_state> :=\<^sub>C \<guillemotleft>s\<guillemotright>) ;; AllowsGetsAndSets) \<box>
    (fmi:fmi2SetFMUState!(\<guillemotleft>i\<guillemotright>)!(&<fmu_state>)?(st) \<^bold>\<rightarrow> AllowsGetsAndSets) and

  AllowAGet =
    (fmi:fmi2GetFMUState!(\<guillemotleft>i\<guillemotright>)?(s)?(st) \<^bold>\<rightarrow>
      (<fmu_state> :=\<^sub>C \<guillemotleft>s\<guillemotright>) ;; AllowsGetsAndSets)

  \<bullet> fmi:fmi2Instantiate!(\<guillemotleft>i\<guillemotright>)?(b) \<^bold>\<rightarrow> AllowAGet
end"

text {* \todo{Write the same process using the axiomatic model.} *}

definition
"process FMUStatesManager \<triangleq>
  (||| i : FMUs \<bullet> FMUStateManager(i)) \<triangle> endSimulation"

subsubsection {* Error Handling *}

text {*
  The encoding of the \<open>ErrorMonitor\<close> is a bit more tricky due to the presence
  of mutual recursion and parametrised actions. Parameters of actions are dealt
  with through a state component \<open>st_arg\<close> to pass the argument. This works as
  all calls are tail recursive. Mutual recursion is dealt with by defining one
  of the mutually-recursive actions i.e.~\<open>StopError\<close> as a higher-order function
  \emph{outside} the scope of the process. Effectively, this mirrors expanding
  \<open>StopError\<close> within the process definition, turning the mutual recursion into
  a single-recursive action.
*}

hide_const (open) utp_rea_designs.st -- \<open>Conflicts with the use of \<open>st\<close> below.\<close>

text {* Since we only have a single state component. *}

abbreviation st_arg :: "error \<Longrightarrow> error" where
"st_arg \<equiv> 1\<^sub>L"

text {*
  To break the mutual recursion in the process definition, we encode the local
  action \<open>StopError\<close> as a higher-order action. State component @{const st_arg}
  is used to pass an argument back to the \<open>Monitor\<close> action.
*}

definition
"process StopError(Monitor, st, mst) \<triangleq>
  (let MonitorCall = (\<lambda>st. st_arg :=\<^sub>C \<guillemotleft>st\<guillemotright> ;; Monitor) in
    (\<guillemotleft>st = mst\<guillemotright> &\<^sub>u ctr:error!(\<guillemotleft>mst\<guillemotright>) \<^bold>\<rightarrow> MonitorCall(st)) \<box>
    (\<guillemotleft>st \<noteq> mst\<guillemotright> &\<^sub>u MonitorCall(st)))"

definition
"process ErrorMonitor(mst) \<triangleq> begin
  Monitor = (
    (fmi:fmi2Get?(i)?(n)?(v)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2Set?(i)?(n)?(v)?(st) \<^bold>\<rightarrow> StopError(Monitor, (fmi2StatusOf st), mst)) \<box>
    (fmi:fmi2GetFMUState?(i)?(s)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2SetFMUState?(i)?(s)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2SetUpExperiment?(i)?(t)?(b)?(hc)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2EnterInitializationMode?(i)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2ExitInitializationMode?(i)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2GetBooleanStatusfmi2Terminated?(i)?(b)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2DoStep?(i)?(t)?(hc)?(st) \<^bold>\<rightarrow> StopError(Monitor, (fmi2StatusOf st), mst)) \<box>
    (fmi:fmi2Terminate?(i)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2GetMaxStepSize?(i)?(t)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)) \<box>
    (fmi:fmi2Instantiate?(i)?(b) \<^bold>\<rightarrow>
      (if b then StopError(Monitor, fmi2OK, mst)
            else StopError(Monitor, fmi2Fatal, mst))) \<box>
    (fmi:fmi2FreeInstance?(i)?(st) \<^bold>\<rightarrow> StopError(Monitor, st, mst)))

  \<bullet> Monitor \<triangle> (ctr:endsimulation \<^bold>\<rightarrow> Skip)
end"

definition
"process ErrorHandler \<triangleq>
  ErrorMonitor(fmi2Error)
    \<lbrakk>(FMIAPI \<union> \<epsilon>(ctr:endsimulation))\<rbrakk>\<^sub>C
  ErrorMonitor(fmi2Fatal)"

definition
"process FatalError \<triangleq>
  ctr:error.(\<guillemotleft>fmi2Fatal\<guillemotright>) \<^bold>\<rightarrow> ctr:endsimulation \<^bold>\<rightarrow> Skip"

definition
"process ShutdownCreated(i) \<triangleq>
  (ctr:error.(\<guillemotleft>fmi2Error\<guillemotright>) \<^bold>\<rightarrow> fmi:fmi2FreeInstance.(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip) \<box>
  (fmi:fmi2FreeInstance.(\<guillemotleft>i\<guillemotright>)?(st) \<^bold>\<rightarrow> Skip)"

definition
"process Shutdown(i) \<triangleq>
  (fmi:fmi2Instantiate.(\<guillemotleft>i\<guillemotright>)?(b) \<^bold>\<rightarrow> ShutdownCreated(i) ;; ctr:endsimulation \<^bold>\<rightarrow> Skip) \<box>
  (ctr:error.(\<guillemotleft>fmi2Error\<guillemotright>) \<^bold>\<rightarrow> ctr:endsimulation \<^bold>\<rightarrow> Skip)"

definition
"process ErrorManagement \<triangleq>
  (|| i : FMUs \<bullet> [\<epsilon>(ctr:error) \<union> \<epsilon>(ctr:endsimulation)] Shutdown(i))"

definition
"process ErrorManager \<triangleq> FatalError \<box> ErrorManagement"

subsubsection {* Master Algorithm *}

-- {* \todo{Check why the below does not pretty-print correctly.} *}

definition
"process TimedInteraction(t0, hc, tN) \<triangleq>
  (Timer(t0, hc, tN) \<triangle> endSimulation
    \<lbrakk>(tm_events \<union> \<epsilon>(ctr:endsimulation))\<rbrakk>\<^sub>C Interaction) \\
  tm_events \<union> \<epsilon>(ctr:stepAnalysed) \<union> \<epsilon>(ctr:stepComplete)"

(* print_theorems *)

definition
"process MAlgorithm(t0, hc, tN) \<triangleq>
  (((TimedInteraction(t0, hc, tN)
    \<lbrakk>(\<epsilon>(ctr:endsimulation) \<union> \<epsilon>(fmi:fmi2Instantiate))\<rbrakk>\<^sub>C
      FMUStatesManager) \<triangle> ErrorManager)
    \<lbrakk>(FMIAPI \<union> \<epsilon>(ctr:endsimulation) \<union> \<epsilon>(ctr:error))\<rbrakk>\<^sub>C ErrorHandler)
  \\ \<epsilon>(ctr:error)"

subsection {* Concrete MAs *}

definition
"process NoStatesManager \<triangleq>
  (||| i : FMUs \<bullet> fmi:fmi2Instantiate!(\<guillemotleft>i\<guillemotright>)?(b) \<^bold>\<rightarrow> Stop) \<triangle> endSimulation"

theorem "FMUStatesManager \<sqsubseteq> NoStatesManager"
apply (simp add: FMUStatesManager_def NoStatesManager_def)
-- {* Need monotonicity of interrupt and iterated interleaving to continue. *}
oops

(*<*)
(*
subsection {* FMU Wrapping (TODO) *}

definition RUN :: "'\<epsilon> set \<Rightarrow> ('\<sigma>, '\<epsilon>) action" where
"RUN evts = undefined"

(* I think the problem below is that the state space of i_b includes the whole
   of the reactive alphabet whereas the guard operator only expects a predicate
   on the state variables... *)

definition
"process FMUInterface(i::FMI2COMP) \<triangleq>
begin
  Instantiated =
    (&<st> =\<^sub>u \<guillemotleft>fmi2Fatal\<guillemotright>) &\<^sub>u RUN(fmi_events) and
  Instantiation =
    (fmi:fmi2Instantiate?\<^sub>u(i_b : \<pi>\<^sub>1(\<guillemotleft>i_b\<guillemotright>) =\<^sub>u \<guillemotleft>i\<guillemotright>) \<rightarrow>
      ((\<pi>\<^sub>2(&i_b) =\<^sub>u \<guillemotleft>True\<guillemotright>) &\<^sub>u Instantiated))
  \<bullet> Instantiation \<triangle> endSimulation
end"
*)
(*>*)
end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

header {* \isaheader{Kildall for the JVM}\label{sec:JVM} *}

theory BVExec
imports
  "../DFA/Abstract_BV"
  TF_JVM
begin

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

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

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

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
  apply (insert wf)
  apply (unfold kiljvm_def)
  apply (fold r_def f_def step_def_exec)
  apply (rule is_bcv_kildall)
       apply simp
       apply (rule Semilat.intro)
       apply (fold sl_def2, erule semilat_JVM)
      apply simp
      apply blast
     apply (simp add: JVM_le_unfold)
    apply (rule exec_pres_type)
   apply (rule bounded_step)
  apply (erule step_mono)
  done
(*>*)

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

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

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

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

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

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

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

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

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

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

  -- "soundness"
  assume wt: "wf_jvm_prog\<^sub>k P"
  hence "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P"
    apply (unfold wf_jvm_prog_phi_def wf_jvm_prog\<^sub>k_def)
    apply (erule wf_prog_lift)
    apply (auto intro: someI_ex[OF start_context.wt_kil_correct [OF start_context.intro]])
    done
  thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
next
  -- "completeness"
  assume wt: "wf_jvm_prog P"
  thus "wf_jvm_prog\<^sub>k P"
    apply (unfold wf_jvm_prog_def wf_jvm_prog_phi_def wf_jvm_prog\<^sub>k_def)
    apply (clarify)
    apply (erule wf_prog_lift)
    apply (auto intro!: start_context.wt_kil_complete start_context.intro)
    done
qed
(*>*)

end


(*  Title:      JinjaThreads/Common/Conform.thy
    Author:     David von Oheimb, Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Conform.thy by David von Oheimb and Tobias Nipkow
*)

section \<open>Conformance Relations for Type Soundness Proofs\<close>

theory Conform
imports
  StartConfig
begin

context heap_base begin

definition conf :: "'m prog \<Rightarrow> 'heap \<Rightarrow> 'addr val \<Rightarrow> ty \<Rightarrow> bool"   ("_,_ \<turnstile> _ :\<le> _"  [51,51,51,51] 50)
where "P,h \<turnstile> v :\<le> T  \<equiv> \<exists>T'. typeof\<^bsub>h\<^esub> v = Some T' \<and> P \<turnstile> T' \<le> T"

definition lconf :: "'m prog \<Rightarrow> 'heap \<Rightarrow> (vname \<rightharpoonup> 'addr val) \<Rightarrow> (vname \<rightharpoonup> ty) \<Rightarrow> bool"   ("_,_ \<turnstile> _ '(:\<le>') _" [51,51,51,51] 50)
where "P,h \<turnstile> l (:\<le>) E  \<equiv> \<forall>V v. l V = Some v \<longrightarrow> (\<exists>T. E V = Some T \<and> P,h \<turnstile> v :\<le> T)"

abbreviation confs :: "'m prog \<Rightarrow> 'heap \<Rightarrow> 'addr val list \<Rightarrow> ty list \<Rightarrow> bool" ("_,_ \<turnstile> _ [:\<le>] _" [51,51,51,51] 50)
where "P,h \<turnstile> vs [:\<le>] Ts  ==  list_all2 (conf P h) vs Ts"

definition tconf :: "'m prog \<Rightarrow> 'heap \<Rightarrow> 'thread_id \<Rightarrow> bool" ("_,_ \<turnstile> _ \<surd>t" [51,51,51] 50)
where "P,h \<turnstile> t \<surd>t \<equiv> \<exists>C. typeof_addr h (thread_id2addr t) = \<lfloor>Class_type C\<rfloor> \<and> P \<turnstile> C \<preceq>\<^sup>* Thread"

end

locale heap_conf_base =
  heap_base +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  fixes hconf :: "'heap \<Rightarrow> bool"
  and P :: "'m prog"

sublocale heap_conf_base < prog P .

locale heap_conf =
  heap
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    P
  +
  heap_conf_base
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P
  for addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and hconf :: "'heap \<Rightarrow> bool"
  and P :: "'m prog"
  +
  assumes hconf_empty [iff]: "hconf empty_heap"
  and typeof_addr_is_type: "\<lbrakk> typeof_addr h a = \<lfloor>hT\<rfloor>; hconf h \<rbrakk> \<Longrightarrow> is_type P (ty_of_htype hT)"
  and hconf_allocate_mono: "\<And>a. \<lbrakk> (h', a) \<in> allocate h hT; hconf h; is_htype P hT \<rbrakk> \<Longrightarrow> hconf h'"
  and hconf_heap_write_mono:
  "\<And>T. \<lbrakk> heap_write h a al v h'; hconf h; P,h \<turnstile> a@al : T; P,h \<turnstile> v :\<le> T \<rbrakk> \<Longrightarrow> hconf h'"

locale heap_progress =
  heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P
  for addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and hconf :: "'heap \<Rightarrow> bool"
  and P :: "'m prog"
  +
  assumes heap_read_total: "\<lbrakk> hconf h; P,h \<turnstile> a@al : T \<rbrakk> \<Longrightarrow> \<exists>v. heap_read h a al v \<and> P,h \<turnstile> v :\<le> T"
  and heap_write_total: "\<lbrakk> hconf h; P,h \<turnstile> a@al : T; P,h \<turnstile> v :\<le> T \<rbrakk> \<Longrightarrow> \<exists>h'. heap_write h a al v h'"

locale heap_conf_read =
  heap_conf
    addr2thread_id thread_id2addr
    spurious_wakeups
    empty_heap allocate typeof_addr heap_read heap_write
    hconf P
  for addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and hconf :: "'heap \<Rightarrow> bool"
  and P :: "'m prog"
  +
  assumes heap_read_conf: "\<lbrakk> heap_read h a al v; P,h \<turnstile> a@al : T; hconf h \<rbrakk> \<Longrightarrow> P,h \<turnstile> v :\<le> T"

locale heap_typesafe =
  heap_conf_read +
  heap_progress +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<rightharpoonup> htype"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap \<Rightarrow> bool"
  and hconf :: "'heap \<Rightarrow> bool"
  and P :: "'m prog"

context heap_conf begin

lemmas hconf_heap_ops_mono =
  hconf_allocate_mono
  hconf_heap_write_mono

end

subsection\<open>Value conformance \<open>:\<le>\<close>\<close>

context heap_base begin

lemma conf_Null [simp]: "P,h \<turnstile> Null :\<le> T  =  P \<turnstile> NT \<le> T"
unfolding conf_def by(simp (no_asm))

lemma typeof_conf[simp]: "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow> P,h \<turnstile> v :\<le> T"
unfolding conf_def by (cases v) auto

lemma typeof_lit_conf[simp]: "typeof v = Some T \<Longrightarrow> P,h \<turnstile> v :\<le> T"
by (rule typeof_conf[OF typeof_lit_typeof])

lemma defval_conf[simp]: "P,h \<turnstile> default_val T :\<le> T"
unfolding conf_def by (cases T) auto

lemma conf_widen: "P,h \<turnstile> v :\<le> T \<Longrightarrow> P \<turnstile> T \<le> T' \<Longrightarrow> P,h \<turnstile> v :\<le> T'"
unfolding conf_def by (cases v) (auto intro: widen_trans)

lemma conf_sys_xcpt:
  "\<lbrakk>preallocated h; C \<in> sys_xcpts\<rbrakk> \<Longrightarrow> P,h \<turnstile> Addr (addr_of_sys_xcpt C) :\<le> Class C"
by(simp add: conf_def typeof_addr_sys_xcp)

lemma conf_NT [iff]: "P,h \<turnstile> v :\<le> NT = (v = Null)"
by (auto simp add: conf_def)

lemma is_IntgI: "P,h \<turnstile> v :\<le> Integer \<Longrightarrow> is_Intg v"
by (unfold conf_def) auto

lemma is_BoolI: "P,h \<turnstile> v :\<le> Boolean \<Longrightarrow> is_Bool v"
by (unfold conf_def) auto

lemma is_RefI: "P,h \<turnstile> v :\<le> T \<Longrightarrow> is_refT T \<Longrightarrow> is_Ref v"
by(cases v)(auto elim: is_refT.cases simp add: conf_def is_Ref_def)

lemma non_npD:
  "\<lbrakk> v \<noteq> Null; P,h \<turnstile> v :\<le> Class C; C \<noteq> Object \<rbrakk>
  \<Longrightarrow> \<exists>a C'. v = Addr a \<and> typeof_addr h a = \<lfloor>Class_type C'\<rfloor> \<and> P \<turnstile> C' \<preceq>\<^sup>* C"
by(cases v)(auto simp add: conf_def widen_Class)

lemma non_npD2:
  "\<lbrakk>v \<noteq> Null; P,h \<turnstile> v :\<le> Class C \<rbrakk>
  \<Longrightarrow> \<exists>a hT. v = Addr a \<and> typeof_addr h a = \<lfloor>hT\<rfloor> \<and> P \<turnstile> class_type_of hT \<preceq>\<^sup>* C"
by(cases v)(auto simp add: conf_def widen_Class)

end

context heap begin

lemma conf_hext: "\<lbrakk> h \<unlhd> h'; P,h \<turnstile> v :\<le> T \<rbrakk> \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
unfolding conf_def by(cases v)(auto dest: typeof_addr_hext_mono)

lemma conf_heap_ops_mono:
  assumes "P,h \<turnstile> v :\<le> T"
  shows conf_allocate_mono: "(h', a) \<in> allocate h hT \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
  and conf_heap_write_mono: "heap_write h a al v' h' \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
using assms
by(auto intro: conf_hext dest: hext_heap_ops)

end

subsection\<open>Value list conformance \<open>[:\<le>]\<close>\<close>

context heap_base begin

lemma confs_widens [trans]: "\<lbrakk>P,h \<turnstile> vs [:\<le>] Ts; P \<turnstile> Ts [\<le>] Ts'\<rbrakk> \<Longrightarrow> P,h \<turnstile> vs [:\<le>] Ts'"
by (rule list_all2_trans)(rule conf_widen)

lemma confs_rev: "P,h \<turnstile> rev s [:\<le>] t = (P,h \<turnstile> s [:\<le>] rev t)"
by(rule list_all2_rev1)

lemma confs_conv_map:
  "P,h \<turnstile> vs [:\<le>] Ts' = (\<exists>Ts. map typeof\<^bsub>h\<^esub> vs = map Some Ts \<and> P \<turnstile> Ts [\<le>] Ts')"
apply(induct vs arbitrary: Ts')
 apply simp
apply(case_tac Ts')
apply(auto simp add:conf_def)
apply(rule_tac x="T' # Ts" in exI)
apply(simp add: fun_of_def)
done

lemma confs_Cons2: "P,h \<turnstile> xs [:\<le>] y#ys = (\<exists>z zs. xs = z#zs \<and> P,h \<turnstile> z :\<le> y \<and> P,h \<turnstile> zs [:\<le>] ys)"
by (rule list_all2_Cons2)

end

context heap begin

lemma confs_hext: "P,h \<turnstile> vs [:\<le>] Ts \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> vs [:\<le>] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)

end

subsection \<open>Local variable conformance\<close>

context heap_base begin

lemma lconf_upd:
  "\<lbrakk> P,h \<turnstile> l (:\<le>) E; P,h \<turnstile> v :\<le> T; E V = Some T \<rbrakk> \<Longrightarrow> P,h \<turnstile> l(V\<mapsto>v) (:\<le>) E"
unfolding lconf_def by auto

lemma lconf_empty [iff]: "P,h \<turnstile> Map.empty (:\<le>) E"
by(simp add:lconf_def)

lemma lconf_upd2: "\<lbrakk>P,h \<turnstile> l (:\<le>) E; P,h \<turnstile> v :\<le> T\<rbrakk> \<Longrightarrow> P,h \<turnstile> l(V\<mapsto>v) (:\<le>) E(V\<mapsto>T)"
by(simp add:lconf_def)

end

context heap begin

lemma lconf_hext: "\<lbrakk> P,h \<turnstile> l (:\<le>) E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> l (:\<le>) E"
unfolding lconf_def by(fast elim: conf_hext)

end

subsection \<open>Thread object conformance\<close>

context heap_base begin

lemma tconfI: "\<lbrakk> typeof_addr h (thread_id2addr t) = \<lfloor>Class_type C\<rfloor>; P \<turnstile> C \<preceq>\<^sup>* Thread \<rbrakk> \<Longrightarrow> P,h \<turnstile> t \<surd>t"
by(simp add: tconf_def)

lemma tconfD: "P,h \<turnstile> t \<surd>t \<Longrightarrow> \<exists>C. typeof_addr h (thread_id2addr t) = \<lfloor>Class_type C\<rfloor> \<and> P \<turnstile> C \<preceq>\<^sup>* Thread"
by(auto simp add: tconf_def)

end

context heap begin

lemma tconf_hext_mono: "\<lbrakk> P,h \<turnstile> t \<surd>t; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> t \<surd>t"
by(auto simp add: tconf_def dest: typeof_addr_hext_mono)

lemma tconf_heap_ops_mono:
  assumes "P,h \<turnstile> t \<surd>t"
  shows tconf_allocate_mono: "(h', a) \<in> allocate h hT \<Longrightarrow> P,h' \<turnstile> t \<surd>t"
  and tconf_heap_write_mono: "heap_write h a al v h' \<Longrightarrow> P,h' \<turnstile> t \<surd>t"
using tconf_hext_mono[OF assms, of h']
by(blast intro: hext_heap_ops)+

lemma tconf_start_heap_start_tid:
  "\<lbrakk> start_heap_ok; wf_syscls P \<rbrakk> \<Longrightarrow> P,start_heap \<turnstile> start_tid \<surd>t"
unfolding start_tid_def start_heap_def start_heap_ok_def start_heap_data_def initialization_list_def addr_of_sys_xcpt_def start_addrs_def sys_xcpts_list_def
apply(clarsimp split: prod.split_asm simp add: create_initial_object_simps split: if_split_asm)
apply(erule not_empty_pairE)+
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule (1) allocate_Eps)
apply(drule allocate_SomeD[where hT="Class_type Thread"])
 apply simp
apply(rule tconfI)
 apply(erule typeof_addr_hext_mono[OF hext_allocate])+
 apply simp
apply blast
done

lemma start_heap_write_typeable:
  assumes "WriteMem ad al v \<in> set start_heap_obs"
  shows "\<exists>T. P,start_heap \<turnstile> ad@al : T \<and> P,start_heap \<turnstile> v :\<le> T"
using assms
unfolding start_heap_obs_def start_heap_def
by clarsimp

end

subsection \<open>Well-formed start state\<close>

context heap_base begin

inductive wf_start_state :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> 'addr val list \<Rightarrow> bool"
for P :: "'m prog" and C :: cname and M :: mname and vs :: "'addr val list"
where
  wf_start_state:
  "\<lbrakk> P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D; start_heap_ok; P,start_heap \<turnstile> vs [:\<le>] Ts \<rbrakk>
  \<Longrightarrow> wf_start_state P C M vs"

end

end


theory Logic
imports
  DirectLogic
begin

fun unpairMsg :: "execmsg \<Rightarrow> trace"
where
  "unpairMsg (Tup x y) = MkUnt x y # unpairMsg x @ unpairMsg y"
| "unpairMsg m         = []"

fun unpairTrace :: "wt_subst \<Rightarrow> trace \<Rightarrow> trace"
where
  "unpairTrace s [] = []"
| "unpairTrace s (MkStep tid (Send l msg) # es) =
     MkStep tid (Send l msg) #
     unpairMsg (subst s (spec2exec msg tid)) @
     unpairTrace s es"
| "unpairTrace s (MkDecr m k # es) =
     MkDecr m k #
     unpairMsg m @
     unpairTrace s es"
| "unpairTrace s (e # es) = e # unpairTrace s es"

thm reachable_eout_extend_wts

lemma unpairTrace_append [simp]:
  "unpairTrace s (t@t') = unpairTrace s t @ unpairTrace s t'"
  by(induct t rule: unpairTrace.induct, auto)

lemma extend_wts_assoc:
  "extend_wts (extend_wts s s') s'' = extend_wts s (extend_wts s' s'')"
  sorry

lemma reachable_unpairTrace_extend_wts [simp]:
  "(t, r, s) \<in> reachable P
   \<Longrightarrow> unpairTrace (extend_wts s s') t = unpairTrace s t"
  apply(induct arbitrary: s' rule: reachable.induct)
  apply(simp_all add: extend_wts_assoc extend_wts_conv_subst
                      reachable_Send_ground)
  done

lemma knows_unpairTrace_subset:
  "knows s t \<subseteq> knows s (unpairTrace s t)"
  by(induct t rule: unpairTrace.induct, auto)

lemma reachable_append_unpairMsg:
  "\<lbrakk> (t,r,s) \<in> reachable P; m \<in> knows s t \<rbrakk>
   \<Longrightarrow> (t@unpairMsg m, r, s) \<in> reachable P"
proof(induct m arbitrary: t)
  case (Tup x y) show ?case using prems(3-4)
    apply(simp)
    apply(subgoal_tac "t @ MkUnt x y # unpairMsg x @ unpairMsg y =
                       (t @ MkUnt x y # unpairMsg x) @ unpairMsg y")
    apply(simp only:)
    apply(rule prems(2))
    apply(subgoal_tac "t @ MkUnt x y # unpairMsg x =
                       (t @ [MkUnt x y]) @ unpairMsg x")
    apply(simp only:)
    apply(rule prems(1))
    apply(erule reachable.intros)
    apply(simp_all (no_asm))
    done
next
  case Lit thus ?case by simp next
  case Enc thus ?case by simp next
  case Hash thus ?case by simp next
  case SK thus ?case by simp next
  case PK thus ?case by simp next
  case K thus ?case by simp next
qed

lemma reachable_unpairTrace_reachable:
  "(t,r,s) \<in> reachable P \<Longrightarrow>
   (unpairTrace s t, r, s) \<in> reachable P"
proof(induct rule: reachable.induct)
  case init thus ?case by(simp add: reachable.init)
  case (create t r s tid R \<alpha>) thus ?case
    apply(simp)
    apply(rotate_tac 1)
    apply(drule reachable.create)
    apply(simp+)
    apply(subgoal_tac
     "(\<lambda>a. if a = tid then Some (newThread R) else r a) =
      r(tid \<mapsto> newThread R)")
    apply(simp)
    apply(rule ext, simp)
    done
next
  case (recv t r s l msg tid \<alpha>) thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case hash thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case encr thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case tuple thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case untup thus ?case
    apply(simp)
    apply(rule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case (decr t r s m k) thus ?case
    apply(simp add: reachable_append_unpairMsg)
    apply(subgoal_tac "unpairTrace s t @ MkDecr m k # unpairMsg m =
                       (unpairTrace s t @ [MkDecr m k]) @ unpairMsg m")
    apply(simp only:)
    apply(rule reachable_append_unpairMsg)
    apply(erule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
next
  case (send t r s l msg tid) thus ?case
    apply(simp add: reachable_append_unpairMsg)
    apply(subgoal_tac "unpairTrace s t @ MkStep tid (Send l msg) # unpairMsg (subst s (spec2exec msg tid)) =
                       (unpairTrace s t @ [MkStep tid (Send l msg)]) @ unpairMsg (subst s (spec2exec msg tid))")
    apply(simp only:)
    apply(rule reachable_append_unpairMsg)
    apply(erule reachable.intros)
    by(auto elim!: subsetD[OF knows_unpairTrace_subset])
qed

lemma unpairTrace_charn:
  "\<lbrakk> m \<in> knows s t; m' \<in> unpair m \<rbrakk> \<Longrightarrow>
   m' \<in> knows s (unpairTrace s t)"
  apply(induct m)
  apply(auto elim!: subsetD[OF knows_unpairTrace_subset])
  apply(simp add: knows_conv_eout)
  apply(erule disjE)
  apply(force simp: IK0_def)
  apply(clarsimp)
  apply(case_tac x)
  apply(case_tac rolestep)
  apply(simp_all)
  sorry

fun out :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "out s (MkStep tid (Send lbl msg)) =
     unpair (subst s (spec2exec msg tid))"
| "out s (MkStep tid (Recv lbl msg)) = {}"
| "out s (MkTup  x y)       = unpair x \<union> unpair y"
| "out s (MkUnt  x y)       = unpair x \<union> unpair y"
| "out s (MkHash m)         = {Hash m}"
| "out s (MkEncr m k)       = {Enc m k}"
| "out s (MkDecr m k)       = unpair m"

definition kn' :: "state \<Rightarrow> execmsg \<Rightarrow> bool"
where "kn' q m' = (case q of (t,r,s) \<Rightarrow>
                   \<forall> m \<in> unpair (subst s m').
                     m \<in> IK0 \<or> (\<exists> e \<in> set t. m \<in> out s e))"

lemma out_conv_eout:
  "out s e = (\<Union> m \<in> eout s e. unpair m)"
  by(induct e rule: out.induct, auto)

lemma kn'_conv_knows:
  "kn' (t,r,s) m' =
  (\<forall> m \<in> unpair m'. subst s m \<in> knows s (unpairTrace s t))"
  apply(simp add: kn'_def)
  apply(rule iffI)
  apply(clarify)
  apply(frule unpair_subst_distr)
  apply(drule bspec)
  apply(assumption)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(subgoal_tac "subst s m \<in> knows s t")

section{* Secrecy and Authentication Logic *}

subsection{* Abstract Events *}

datatype logicevent =
   DoStep tid rolestep
 | DoHash execmsg
 | DoEncr execmsg execmsg
 | DoDecr execmsg execmsg

fun substEv :: "wt_subst \<Rightarrow> logicevent \<Rightarrow> logicevent"
where
  "substEv s (DoStep tid step) = DoStep tid step"
| "substEv s (DoHash m)        = DoHash (subst s m)"
| "substEv s (DoEncr m k)      = DoEncr (subst s m) (subst s k)"
| "substEv s (DoDecr m k)      = DoDecr (subst s m) (subst s k)"

fun instEv :: "logicevent \<Rightarrow> execevent"
where
  "instEv (DoStep tid step) = MkStep tid step"
| "instEv (DoHash m)        = MkHash m"
| "instEv (DoEncr m k)      = MkEncr m k"
| "instEv (DoDecr m k)      = MkDecr m k"

fun out :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "out s (MkStep tid (Send lbl msg)) =
     unpair (subst s (spec2exec msg tid))"
| "out s (MkStep tid (Recv lbl msg)) = {}"
| "out s (MkTup  x y)       = unpair x \<union> unpair y"
| "out s (MkUnt  x y)       = unpair x \<union> unpair y"
| "out s (MkHash m)         = {Hash m}"
| "out s (MkEncr m k)       = {Enc m k}"
| "out s (MkDecr m k)       = unpair m"

subsection{* Predicates *}

definition kn :: "state \<Rightarrow> execmsg \<Rightarrow> bool"
where "kn q m' = (case q of (t,r,s) \<Rightarrow>
                   \<forall> m \<in> unpair (subst s m').
                     m \<in> IK0 \<or> (\<exists> e \<in> set t. m \<in> out s e))"

definition ev :: "state \<Rightarrow> logicevent \<Rightarrow> bool"
where "ev q e \<equiv> (case q of (t,r,s) \<Rightarrow>
                  instEv (substEv s e) \<in> set t)"

definition learn :: "state \<Rightarrow> logicevent \<Rightarrow> execmsg \<Rightarrow> bool"
where "learn q e m' \<equiv> (case q of (t,r,s) \<Rightarrow>
                        instEv (substEv s e) \<in> set t \<and>
                        (\<forall> m \<in> unpair (subst s m').
                            m \<in> IK0 \<or>
                            m \<in> out s (instEv (substEv s e)) \<or>
                           (\<exists> e'. (e',(instEv (substEv s e))) \<in> firstOccOrd t \<and>
                                   m \<in> out s e')
                        ) \<and>
                        (\<exists> m \<in> unpair (subst s m').
                           m \<notin> IK0 \<and>
                           m \<in> out s (instEv (substEv s e)) \<and>
                          (\<forall> e'. (e',instEv (substEv s e)) \<in> firstOccOrd t \<longrightarrow>
                                  m \<notin> out s e'
                          )
                        )
                      )"

definition evbefore :: "state \<Rightarrow> logicevent \<Rightarrow> logicevent \<Rightarrow> bool"
where "evbefore q e1 e2 \<equiv> (case q of (t,r,s) \<Rightarrow>
                            (instEv (substEv s e1), instEv (substEv s e2))
                            \<in> firstOccOrd t)"

definition knbefore :: "state \<Rightarrow> execmsg \<Rightarrow> logicevent \<Rightarrow> bool"
where "knbefore q m' e \<equiv> (case q of (t,r,s) \<Rightarrow>
                           instEv (substEv s e) \<in> set t \<and>
                           (\<forall> m \<in> unpair (subst s m').
                              m \<in> IK0 \<or>
                              (\<exists> e'. (e',instEv (substEv s e)) \<in> firstOccOrd t \<and>
                                     m \<in> out s e'
                              )
                            )
                          )"

definition runs :: "state \<Rightarrow> tid \<Rightarrow> role \<Rightarrow> bool"
where "runs q tid R \<equiv> (case q of (t,r,s) \<Rightarrow>
                        (case r tid of
                          Some (todo,done) \<Rightarrow> Rep_role R = rev done @ todo
                        | None             \<Rightarrow> False))"

subsection{* Properties of Conversion Operators *}

lemma out_conv_eout:
  "out s e = (\<Union> m \<in> eout s e. unpair m)"
  by(induct e rule: out.induct, auto)

lemma reachable_instEv_substEv_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P; instEv (substEv s e) \<in> set t \<rbrakk>
    \<Longrightarrow> instEv (substEv (extend_wts s s') e) = instEv (substEv s e)"
  apply(induct e rule: substEv.induct)
  apply(auto simp: extend_wts_conv_subst
             dest!: reachable_eventMsg_ground)
  done

subsection{* Rules *}

subsubsection{* Simplification *}

lemma kn_simps [simp]:
  "kn q (Tup x y) = (kn q x \<and> kn q y)"
  "kn q (Lit (EConst c))"
  "kn q (Lit (EHonest a))"
  "kn q (Lit (EveNonce n))"
  "kn q (SK (Lit Eve))"
  "kn q (PK (Lit (EHonest a)))"
  "kn q (K (Lit (EHonest a)) (Lit Eve))"
  "kn q (K (Lit Eve) (Lit (EHonest a)))"
  apply(cases q, simp add: add kn_def ball_Un)
  by(cases q, simp add: IK0_def kn_def image_def)+

lemma knbefore_simps:
  "knbefore q (Tup x y) e = (knbefore q x e \<and> knbefore q y e)"
  "ev q e \<Longrightarrow> knbefore q (Lit (EConst c)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EHonest a)) e"
  "ev q e \<Longrightarrow> knbefore q (Lit (EveNonce n)) e"
  "ev q e \<Longrightarrow> knbefore q (SK (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (PK (Lit (EHonest a))) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit (EHonest a)) (Lit Eve)) e"
  "ev q e \<Longrightarrow> knbefore q (K (Lit Eve) (Lit (EHonest a))) e"
  apply(cases q, simp add: knbefore_def, force)
  by(cases q, simp add: IK0_def knbefore_def image_def ev_def)+

subsubsection{* Purely Logical *}

lemma evbeforeD1: "evbefore q e1 e2 \<Longrightarrow> ev q e1"
  by(auto dest: in_set_firstOccOrd1 simp: evbefore_def ev_def)

lemma evbeforeD2: "evbefore q e1 e2 \<Longrightarrow> ev q e2"
  by(auto dest: in_set_firstOccOrd2 simp: evbefore_def ev_def)

lemma knbeforeD1: "knbefore q m e \<Longrightarrow> kn q m"
  by(auto dest!: in_set_firstOccOrd1 simp: knbefore_def kn_def)

lemma knbeforeD2: "knbefore q m e \<Longrightarrow> ev q e"
  by(auto dest!: in_set_firstOccOrd2 simp: knbefore_def ev_def)

lemma learnD1: "learn q e m \<Longrightarrow> ev q e"
  by(auto simp: learn_def ev_def)

lemma learnD2: "learn q e m \<Longrightarrow> kn q m"
  by(auto dest!: in_set_firstOccOrd1 simp add: learn_def kn_def)

lemma ebefore_irr: "\<not>evbefore q e e"
  by(auto simp: evbefore_def)

lemma ebefore_trans: "\<lbrakk> evbefore q e1 e2; evbefore q e2 e3 \<rbrakk> \<Longrightarrow> evbefore q e1 e3"
  by(auto simp: evbefore_def intro: firstOccOrd_trans)

lemma learn_fun:
  "\<lbrakk> learn q e1 m; learn q e2 m \<rbrakk>
  \<Longrightarrow> instEv (substEv (sts q) e1) = instEv (substEv (sts q) e2)"
  apply(clarsimp simp: learn_def)
  apply(drule firstOccOrd_cases)
  apply(assumption)
  apply(erule disjE)
  apply(simp)
  apply(erule disjE)
  apply(thin_tac "\<forall> x \<in> ?X. ?P x")
  apply(drule_tac x=ma in bspec)
  apply(force)
  apply(simp)
  apply(force)
  apply(auto)
  by(auto simp: learn_def dest: firstOccOrd_cases)

lemma learn_knbefore_evbefore:
  "\<lbrakk> learn q e1 m; knbefore q m e2 \<rbrakk> \<Longrightarrow> evbefore q e1 e2"
  apply(clarsimp simp: learn_def knbefore_def evbefore_def)
  apply(drule_tac y="instEv (substEv ya e2)" in firstOccOrd_cases)
  apply(drule in_set_firstOccOrd2, simp)
  apply(safe)
  apply(force)
  apply(subgoal_tac "(e', instEv (substEv ya e1)) \<in> firstOccOrd xa")
  apply(force)
  apply(rule firstOccOrd_trans)
  apply(auto)
  done

lemma runs_fun: "\<lbrakk> runs q tid R1; runs q tid R2 \<rbrakk> \<Longrightarrow> R1 = R2"
  by(auto simp: runs_def Rep_role_inject[symmetric] split: option.splits )

subsubsection{* Role Order *}

lemma evbefore_roleOrd:
  "\<lbrakk> ev q (DoStep tid step);  runs q tid R;
     (prev, step) \<in> roleOrd R; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> evbefore q (DoStep tid prev) (DoStep tid step)"
  apply(clarsimp simp: ev_def evbefore_def firstOccOrd_def runs_def
                split: option.splits)
  apply(rename_tac t r s todo "done")
  apply(unfold roleOrd_def)
  apply(rule reachable_roleOrd)
  apply(assumption)
  apply(assumption)
  apply(auto dest: reachable_todo_notin_trace reachable_done_in_trace in_set_listOrd2)
  done

subsubsection{* Input Messages *}

fun einp :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "einp s (MkStep tid (Send l m)) = {}"
| "einp s (MkStep tid (Recv l m)) = {subst s (spec2exec m tid)}"
| "einp s (MkHash m)              = {m}"
| "einp s (MkTup x y)             = {x, y}"
| "einp s (MkUnt x y)             = {Tup x y}"
| "einp s (MkEncr m k)            = {m, k}"
| "einp s (MkDecr m k)            = {Enc m k, inv k}"

fun inp :: "logicevent \<Rightarrow> execmsg set"
where
  "inp (DoStep tid (Send l m)) = {}"
| "inp (DoStep tid (Recv l m)) = unpair (spec2exec m tid)"
| "inp (DoHash m)            = unpair m"
| "inp (DoEncr m k)          = unpair m \<union> unpair k"
| "inp (DoDecr m k)          = insert (Enc m k) (unpair (inv k))"

lemma einp_ground_by_eventMsg_ground:
  "\<lbrakk> m \<in> einp s e; ground (eventMsg s e) \<rbrakk> \<Longrightarrow> ground m"
  by(induct e rule: einp.induct, auto)

lemma reachable_einp_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t \<rbrakk>
    \<Longrightarrow> einp (extend_wts s s') e = einp s e"
  apply(induct rule: einp.induct)
  apply(auto dest: reachable_eventMsg_ground
             simp: extend_wts_conv_subst)
  done

lemma reachable_knows_einp:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t; m \<in> einp s e \<rbrakk>
   \<Longrightarrow> m \<in> knows s t"
thm reachable_knows_extend_wts

thm reachable_einp_extend_wts

  by(induct arbitrary: e rule: reachable.induct, auto)

lemma reachable_knows_before_einp:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t; m \<in> einp s e \<rbrakk>
   \<Longrightarrow>
   m \<in> IK0 \<or> (\<exists> e' \<in> set t. (e', e) \<in> firstOccOrd t \<and> m \<in> eout s e')"
  apply(induct arbitrary: e m rule: reachable.induct)
  apply(simp_all)
  apply(erule disjE, simp)
  apply(force intro!: firstOccOrd_appendI1)
  apply((thin_tac "dom_wts ?x = ?X")?, (thin_tac "ran_wts ?x = ?X")?)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  apply(case_tac "e \<in> set t")
  apply(force intro!: firstOccOrd_appendI1)
  apply(force simp: knows_conv_eout intro!: firstOccOrd_appendI2)
  done

lemma Recv_knbefore:
  "\<lbrakk>  ev q (DoStep tid (Recv l msg));
      m \<in> unpair (spec2exec msg tid);
      q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoStep tid (Recv l msg))"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption, simp)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Hash_knbefore:
  "\<lbrakk>  ev q (DoHash m'); m \<in> unpair m'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoHash m')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption, simp)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Encr_knbefore_msg:
  "\<lbrakk>  ev q (DoEncr m' k'); m \<in> unpair m'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoEncr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption)
  apply(simp, rule disjI1, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Encr_knbefore_key:
  "\<lbrakk>  ev q (DoEncr m' k'); m \<in> unpair k'; q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoEncr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption)
  apply(simp, rule disjI2, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemma Decr_knbefore_enc:
  "\<lbrakk>  ev q (DoDecr m k); q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q (Enc m k) (DoDecr m k)"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption)
  apply(simp, rule disjI1, rule refl)
  apply(force simp: out_conv_eout knows_conv_eout)
  done

lemma Decr_knbefore_key:
  "\<lbrakk>  ev q (DoDecr m' k'); m \<in> unpair (inv k'); q \<in> reachable P \<rbrakk>
   \<Longrightarrow> knbefore q m (DoDecr m' k')"
  apply(cases q, rename_tac t r s)
  apply(simp add: ev_def knbefore_def)
  apply(drule reachable_knows_before_einp, assumption)
  apply(simp, rule disjI2, rule refl)
  apply(drule unpair_subst_distr)
  apply(simp add: out_conv_eout knows_conv_eout)
  apply(erule disjE)
  apply(drule in_IK0_by_unpair, assumption, simp)
  apply(force)
  done

lemmas Hash_kn = knbeforeD1[OF Hash_knbefore, rule_format]

subsubsection{* Decryption Chains *}

types chain = "(specmsg \<times> specmsg) list \<times> specmsg"

fun msgChains :: "specmsg \<Rightarrow> chain list"
where
  "msgChains (Lit (SNonce n))      = [([], Lit (SNonce n))]"
| "msgChains (Lit (SVar (MVar n))) = [([], Lit (SVar (MVar n)))]"
| "msgChains (Lit _)               = []"
| "msgChains (Tup x y) = msgChains x @ msgChains y"
| "msgChains (Enc m k) =
     ([], Enc m k) #
     map (\<lambda> (encs,end). ((m,k)#encs,end)) (msgChains m)"
| "msgChains (Hash m)  = [([], Hash m)]"
| "msgChains (K a b)   = [([], K a b) ]"
| "msgChains (PK a)    = [([], PK a)  ]"
| "msgChains (SK a)    = [([], SK a)  ]"

fun chainStart :: "chain \<Rightarrow> specmsg"
where
  "chainStart ([],start)  = start"
| "chainStart ((m,k)#_,_) = Enc m k"

fun chainEnd :: "chain \<Rightarrow> specmsg"
where
  "chainEnd (_,end) = end"

lemma chainEnd_in_parts:
  "c \<in> set (msgChains msg) \<Longrightarrow> chainEnd c \<in> parts msg"
  apply(induct msg arbitrary: c, case_tac lit)
  apply(auto)
  by(case_tac varid, auto)

(* if there are no long-term-keys in the parts of the message
   then chain end is not part of it *)
lemma no_ltkeys_chainEnd:
  "\<lbrakk> no_ltkeys msg; c \<in> set (msgChains msg) \<rbrakk> \<Longrightarrow>
   K a b \<noteq> chainEnd c \<and> PK a \<noteq> chainEnd c \<and> SK a \<noteq> chainEnd c"
  apply(induct msg arbitrary: c, case_tac lit)
  apply(simp_all)
  apply(case_tac varid)
  by(simp+, force+)

fun chain :: "state \<Rightarrow> tid \<Rightarrow> chain \<Rightarrow> bool"
where
  "chain q tid ([],      _  ) = True"
| "chain q tid ([(m,k)], end) =
     learn q (DoDecr (spec2exec m tid)
                     (spec2exec k tid))
             (spec2exec end tid)"
| "chain q tid ((m,k)#(m',k')#encs, end) =
    (learn q (DoDecr (spec2exec m tid)
                     (spec2exec k tid))
             (spec2exec (Enc m' k') tid)
     \<and> chain q tid ((m',k')#encs, end)
    )"

lemma kn_rolemap_inv:
  "kn (t, r', s) m \<Longrightarrow> kn (t, r, s) m"
  by(simp add: kn_def)

(*
lemma reachable_kn_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P \<rbrakk>
  \<Longrightarrow> kn (t,r, extend_wts s s') m = kn (t,r,s) m"
  apply(simp add: kn_def)

*)

lemma kn_substI: "kn q m \<Longrightarrow> kn q (subst (sts q) m)"
  by(auto simp: kn_def)

lemma kn_substE:
  "\<lbrakk> kn q (subst s m); subst (sts q) (subst s m) = subst (sts q) m \<rbrakk>
  \<Longrightarrow> kn q m"
  by(auto simp: kn_def)

thm extend_wts_conv_subst

lemma subst_subdomain:
  "dom_wts s' \<subseteq> dom_wts s \<Longrightarrow> subst s' (subst s m) = subst s m"
  apply(induct m rule: subst.induct, simp_all)
  apply(case_tac "l \<in> dom_wts s")
  apply(auto simp: dom_wts_def)
  done

lemma substEv_subdomain:
  "dom_wts s' \<subseteq> dom_wts s \<Longrightarrow> substEv s' (substEv s e) = substEv s e"
  by(induct e rule: substEv.induct, auto intro!: subst_subdomain)

lemma reachable_kn_extend_wts [simp]:
  "(t,r,s) \<in> reachable P \<Longrightarrow>
   kn (t,r,extend_wts s s') m = kn (t,r,s) (subst (extend_wts s s') m)"
  apply(subgoal_tac "subst s (subst (extend_wts s s') m) =
                     subst (extend_wts s s') m")
  apply(auto simp: kn_def out_conv_eout
           intro!: subst_subdomain)
  done

lemma reachable_learn_extend_wts [simp]:
  "(t,r',s) \<in> reachable P \<Longrightarrow>
   learn (t,r,extend_wts s s') e m =
   learn (t,r',s) (substEv (extend_wts s s') e) (subst (extend_wts s s') m)"
  apply(subgoal_tac "subst s (subst (extend_wts s s') m) =
                     subst (extend_wts s s') m")
  apply(subgoal_tac "substEv s (substEv (extend_wts s s') e) =
                     substEv (extend_wts s s') e")
  apply(simp add: learn_def out_conv_eout)
  apply(rule iffI)
  apply(force dest: in_set_firstOccOrd1)
  apply(force dest: in_set_firstOccOrd1)
  apply(auto intro!: substEv_subdomain subst_subdomain)
  done

lemma Rep_wt_subst_atomic: "\<exists> l'. Rep_wt_subst s l = Lit l'"
  apply(insert Rep_wt_subst_welltyped[of s])
  apply(simp add: welltyped_def)
  apply(drule_tac x=l in spec, auto)
  done

lemma Rep_wt_subst_noteq_simps [simp]:
  "Rep_wt_subst s l \<noteq> Hash m"
  "Rep_wt_subst s l \<noteq> Enc m k"
  "Rep_wt_subst s l \<noteq> Tup x y"
  "Rep_wt_subst s l \<noteq> PK a"
  "Rep_wt_subst s l \<noteq> SK a"
  "Rep_wt_subst s l \<noteq> K a b"
  by(insert Rep_wt_subst_atomic[of s l], auto)

lemma kn_append_cases:
  "kn (t@t', r, s) m \<Longrightarrow>
   kn (t, r, s) m \<or>
   (\<exists> e \<in> set t'. e \<notin> set t \<and> subst s m \<in> out s e)"
  by(auto simp: kn_def)

lemma firstOccOrd_Nil [simp]: "firstOccOrd [] = {}"
  by(simp add: firstOccOrd_def)

lemma firstOccOrd_Snoc1 [simp]:
  "x \<in> set xs \<Longrightarrow> firstOccOrd (xs@[x]) = firstOccOrd xs"
  by(induct xs rule: rev_induct, auto simp: firstOccOrd_def)

lemma firstOccOrd_Snoc2 [simp]:
  "x \<notin> set xs \<Longrightarrow>
   firstOccOrd (xs@[x]) = firstOccOrd xs \<union> { (y,x) | y. y \<in> set xs }"
  by(induct xs rule: rev_induct, auto simp: firstOccOrd_def)

thm if_splits(1)

lemma firstOccOrd_splits:
  "P (firstOccOrd (xs@[x])) =
   ((x \<in> set xs \<longrightarrow> P (firstOccOrd xs)) \<and>
    (x \<notin> set xs \<longrightarrow> P (firstOccOrd xs \<union> { (y,x) | y. y \<in> set xs })))"
  by(auto, case_tac "x \<in> set xs", auto)

lemma firstOccOrd_decomp:
  "(e,e') \<in> firstOccOrd t
  \<Longrightarrow> \<exists> xs ys zs. t = xs@e#ys@e'#zs \<and>
                  e \<notin> set xs \<and> e' \<notin> set xs \<and> e \<noteq> e' \<and> e' \<notin> set ys"
  apply(induct t rule: rev_induct)
  apply(auto split: firstOccOrd_splits)
  apply(case_tac "x \<in> set xs")
  apply(simp_all)
  apply(force)
  apply(erule disjE)
  apply(force)
  apply(clarsimp)
  apply(drule split_list_first)
  apply(clarsimp)
  apply(auto)
  done

lemma append_eq_append_before_first:
  "\<lbrakk> vs @ y#ws = xs @ y#ys; y \<notin> set vs; y \<notin> set xs;
     x \<in> set xs \<rbrakk>
   \<Longrightarrow> x \<in> set vs"
  apply(simp add: append_eq_append_conv2)
  apply(auto)
  apply(case_tac us)
  apply(auto)
  done

lemma firstOccOrd_appendD1:
  "\<lbrakk> (e,e') \<in> firstOccOrd (t@t'); e' \<in> set t \<rbrakk> \<Longrightarrow> (e,e') \<in> firstOccOrd t"
  apply(drule firstOccOrd_decomp)
  apply(clarsimp)
  apply(drule split_list_first)
  apply(clarsimp)
  apply(rule firstOccOrd_appendI2)
  apply(simp_all)
  apply(simp add: append_eq_append_conv2)
  apply(auto)
  apply(case_tac us, auto)
  apply(case_tac us, auto)
  done

lemma learn_appendI1:
  "learn (t,r,s) e m \<Longrightarrow> learn (t@t', r', s) e m"
  by(auto simp: learn_def dest: firstOccOrd_appendD1)

lemma learn_Snoc_MkTup [simp]:
  "learn (t@[MkTup x y],r,s) = learn (t,r,s)"
  apply(rule ext, rule ext, rename_tac e m, case_tac e)
  by(auto simp: learn_def split: firstOccOrd_splits)

lemma learn_Snoc_MkUnt [simp]:
  "learn (t@[MkUnt x y],r,s) = learn (t,r,s)"
  apply(rule ext, rule ext, rename_tac e m, case_tac e)
  by(auto simp: learn_def split: firstOccOrd_splits)

lemma runs_free_args:
  "runs (t',r,s') = runs (t,r,s)"
  by(rule ext,rule ext, simp add: runs_def)

(* TODO: Using Isar this lemma should be removed *)
lemma chain_Snoc_MkTup_aux [rule_format]:
  "q = (t,r,s) \<longrightarrow>
   chain (t@[MkTup x y],r,s) tid c = chain q tid c"
  by(induct c rule: chain.induct, auto)

lemma chain_Snoc_MkTup [simp]:
  "chain (t@[MkTup x y],r,s) = chain (t,r,s)"
  by(rule ext, rule ext, auto intro!: chain_Snoc_MkTup_aux)

thm kn_def

lemma learn:
  "\<lbrakk> (t,r,s) \<in> reachable P; kn (t,r,s) m' \<rbrakk> \<Longrightarrow>
   subst s m' \<in> IK0 \<or>
   (\<exists> m.   m' = Hash m   \<and> learn (t,r,s) (DoHash m)   (Hash m)) \<or>
   (\<exists> m k. m' = Enc  m k \<and> learn (t,r,s) (DoEncr m k) (Enc m k)) \<or>
   (\<exists> R \<in> P. \<exists> l msg. Send l msg \<in> roleEvs R \<and>
      (\<exists> c \<in> set (msgChains msg). \<exists> tid.
         runs (t,r,s) tid R \<and>
         learn (t,r,s) (DoStep tid (Send l msg))
                       (spec2exec (chainStart c) tid) \<and>
         chain (t,r,s) tid c \<and>
         subst s m' = subst s (spec2exec (chainEnd c) tid)
      )
   )"
proof (induct arbitrary: m' rule: reachable.induct)
  case init thus ?case by(simp add: kn_def)
next
  case (tuple t r s x y) thus ?case
    apply(simp)
    apply(subst runs_free_args[where t=t and s=s])

next
  case (hash t r s m) thus ?case
    apply(insert kn_append_cases[OF prems(4)])
    apply(erule disjE)
    apply(drule prems(2))
    apply(erule disjE)
    apply(simp)
    apply(erule disjE)
    apply(rule disjI2, rule disjI1)
    apply(simp add: learn_def)
    apply(clarsimp)

    apply(insert prems(1))
    apply(rule disjI2, rule disjI1)

  case (create t r s tid R \<alpha>) show ?case using prems(1,7)
    apply(drule_tac r=r in kn_rolemap_inv)
    apply(simp)
    apply(drule prems(2))
    apply(erule disjE)
    apply(subst (asm) subst_subdomain)
    apply(force)
    apply(simp)
    apply(erule disjE)
    apply(rule disjI2,rule disjI1)
    apply(clarsimp)
    apply(cases m')
    apply(simp_all)
    apply(erule disjE)
    apply(rule disjI2, rule disjI2, rule disjI1)
    apply(cases m')
    apply(simp_all)
    apply(rule disjI2, rule disjI2, rule disjI2)
    apply(clarsimp)
    apply(case_tac "tida = tid")
    apply(clarsimp)
    apply(insert prems(3))
    apply(force simp: runs_def dom_def split: option.splits)
    apply(rule bexI)
    apply(rule exI, rule exI, rule conjI)
    apply(assumption)
    apply(rule_tac x="(a,b)" in bexI)
    apply(rule_tac x="tida" in exI)
    apply(simp add: runs_def)
    sorry
next

thm reachable_eout_extend_wts

    apply(simp add: kn_def out_conv_eout)
  sorry

lemma learn_Hash:
  "\<lbrakk> q \<in> reachable P; kn q (Hash m) \<rbrakk> \<Longrightarrow>
   learn q (DoHash m) (Hash m) \<or>
   (\<exists> R \<in> P. \<exists> l msg. Send l msg \<in> roleEvs R \<and>
      (\<exists> c \<in> set (msgChains msg). \<exists> tid.
         runs q tid R \<and>
         learn q (DoStep tid (Send l msg)) (spec2exec (chainStart c) tid) \<and>
         chain q tid c \<and>
         Hash (subst (sts q) m)  = subst (sts q) (spec2exec (chainEnd c) tid)
      )
   )"
  apply(drule learn, assumption)
  by(auto simp: IK0_def)

lemma learn_SK:
  "\<lbrakk> q \<in> reachable P; kn q (SK a) \<rbrakk> \<Longrightarrow>
   subst (sts q) a = Lit Eve"
  apply(drule learn, assumption)
  apply(auto)
  apply(force simp: IK0_def)
  apply(case_tac b, case_tac lit)
  apply(simp_all)
  apply(insert Rep_wt_subst_welltyped[of "sts q"])
  apply(simp add: welltyped_def)
  apply(drule_tac x="EVar varid tid" in spec)
  apply(force)
  apply(simp add: roleEvs_def)
  apply(drule Rep_role_Send_no_ltkeys)
  apply(drule no_ltkeys_chainEnd)
  apply(assumption)
  apply(force)
  done