(* Author: Tobias Nipkow *)

section "Annotated Commands"

theory ACom
imports "HOL-IMP.Com"
begin

datatype 'a acom =
  SKIP 'a                           ("SKIP {_}" 61) |
  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
  If bexp "('a acom)" "('a acom)" 'a
    ("(IF _/ THEN _/ ELSE _//{_})"  [0, 0, 61, 0] 61) |
  While 'a bexp "('a acom)" 'a
    ("({_}//WHILE _/ DO (_)//{_})"  [0, 0, 61, 0] 61)

fun post :: "'a acom \<Rightarrow>'a" where
"post (SKIP {P}) = P" |
"post (x ::= e {P}) = P" |
"post (c1;; c2) = post c2" |
"post (IF b THEN c1 ELSE c2 {P}) = P" |
"post ({Inv} WHILE b DO c {P}) = P"

fun strip :: "'a acom \<Rightarrow> com" where
"strip (SKIP {P}) = com.SKIP" |
"strip (x ::= e {P}) = (x ::= e)" |
"strip (c1;;c2) = (strip c1;; strip c2)" |
"strip (IF b THEN c1 ELSE c2 {P}) = (IF b THEN strip c1 ELSE strip c2)" |
"strip ({Inv} WHILE b DO c {P}) = (WHILE b DO strip c)"

fun anno :: "'a \<Rightarrow> com \<Rightarrow> 'a acom" where
"anno a com.SKIP = SKIP {a}" |
"anno a (x ::= e) = (x ::= e {a})" |
"anno a (c1;;c2) = (anno a c1;; anno a c2)" |
"anno a (IF b THEN c1 ELSE c2) =
  (IF b THEN anno a c1 ELSE anno a c2 {a})" |
"anno a (WHILE b DO c) =
  ({a} WHILE b DO anno a c {a})"

fun annos :: "'a acom \<Rightarrow> 'a list" where
"annos (SKIP {a}) = [a]" |
"annos (x::=e {a}) = [a]" |
"annos (C1;;C2) = annos C1 @ annos C2" |
"annos (IF b THEN C1 ELSE C2 {a}) = a #  annos C1 @ annos C2" |
"annos ({i} WHILE b DO C {a}) = i # a # annos C"

fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
"map_acom f (SKIP {P}) = SKIP {f P}" |
"map_acom f (x ::= e {P}) = (x ::= e {f P})" |
"map_acom f (c1;;c2) = (map_acom f c1;; map_acom f c2)" |
"map_acom f (IF b THEN c1 ELSE c2 {P}) =
  (IF b THEN map_acom f c1 ELSE map_acom f c2 {f P})" |
"map_acom f ({Inv} WHILE b DO c {P}) =
  ({f Inv} WHILE b DO map_acom f c {f P})"

lemma post_map_acom[simp]: "post(map_acom f c) = f(post c)"
by (induction c) simp_all

lemma strip_acom[simp]: "strip (map_acom f c) = strip c"
by (induction c) auto

lemma map_acom_SKIP:
 "map_acom f c = SKIP {S'} \<longleftrightarrow> (\<exists>S. c = SKIP {S} \<and> S' = f S)"
by (cases c) auto

lemma map_acom_Assign:
 "map_acom f c = x ::= e {S'} \<longleftrightarrow> (\<exists>S. c = x::=e {S} \<and> S' = f S)"
by (cases c) auto

lemma map_acom_Seq:
 "map_acom f c = c1';;c2' \<longleftrightarrow>
 (\<exists>c1 c2. c = c1;;c2 \<and> map_acom f c1 = c1' \<and> map_acom f c2 = c2')"
by (cases c) auto

lemma map_acom_If:
 "map_acom f c = IF b THEN c1' ELSE c2' {S'} \<longleftrightarrow>
 (\<exists>S c1 c2. c = IF b THEN c1 ELSE c2 {S} \<and> map_acom f c1 = c1' \<and> map_acom f c2 = c2' \<and> S' = f S)"
by (cases c) auto

lemma map_acom_While:
 "map_acom f w = {I'} WHILE b DO c' {P'} \<longleftrightarrow>
 (\<exists>I P c. w = {I} WHILE b DO c {P} \<and> map_acom f c = c' \<and> I' = f I \<and> P' = f P)"
by (cases w) auto

lemma strip_anno[simp]: "strip (anno a c) = c"
by(induct c) simp_all

lemma strip_eq_SKIP:
  "strip c = com.SKIP \<longleftrightarrow> (\<exists>P. c = SKIP {P})"
by (cases c) simp_all

lemma strip_eq_Assign:
  "strip c = x::=e \<longleftrightarrow> (\<exists>P. c = x::=e {P})"
by (cases c) simp_all

lemma strip_eq_Seq:
  "strip c = c1;;c2 \<longleftrightarrow> (\<exists>d1 d2. c = d1;;d2 & strip d1 = c1 & strip d2 = c2)"
by (cases c) simp_all

lemma strip_eq_If:
  "strip c = IF b THEN c1 ELSE c2 \<longleftrightarrow>
  (\<exists>d1 d2 P. c = IF b THEN d1 ELSE d2 {P} & strip d1 = c1 & strip d2 = c2)"
by (cases c) simp_all

lemma strip_eq_While:
  "strip c = WHILE b DO c1 \<longleftrightarrow>
  (\<exists>I d1 P. c = {I} WHILE b DO d1 {P} & strip d1 = c1)"
by (cases c) simp_all

lemma set_annos_anno[simp]: "set (annos (anno a C)) = {a}"
by(induction C)(auto)

lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
apply(induct C2 arbitrary: C1)
apply (auto simp: strip_eq_SKIP strip_eq_Assign strip_eq_Seq strip_eq_If strip_eq_While)
done

lemmas size_annos_same2 = eqTrueI[OF size_annos_same]

end


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

subsection\<open>Perfect Recall in Non-deterministic Broadcast Environments\<close>

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

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

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

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

(*>*)
text\<open>

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

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

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

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

\<close>

context FiniteBroadcastEnvironment
begin

text\<open>

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

\<close>

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

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

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

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

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

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

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

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

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

(*>*)
text\<open>

Similarly we introduce common and agent-specific abstraction functions:

\<close>

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

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

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

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

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

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

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

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

(*>*)

end (* context FiniteBroadcastEnvironment *)

text\<open>

The simulation is identical to that in the previous section:

\<close>

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

context FiniteBroadcastEnvironment
begin

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

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

(*>*)
text\<open>

The Kripke structure over simulated traces is also the same:

\<close>

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

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

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

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

(*>*)
text\<open>

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

To do this we define a splicing operation:

\<close>

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

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

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

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

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

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

(*>*)
text\<open>

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

We hoist this operation pointwise to traces:

\<close>

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

declare sSplice_envObs_a[simp] sSplice_envObs_not_a[simp]

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

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

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

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

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

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

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

(*>*)
text\<open>

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

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

\<close>

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

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

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

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

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

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

  define aact'' where "aact'' = aact (a := aact' a)"

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

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

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

  moreover

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

  moreover

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

  moreover note eact trans tt'n

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

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

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

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

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

  define q where "q = t \<^bsub>\<^esub>\<bowtie>\<^bsub>a\<^esub> p"

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

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

(*>*)
text\<open>

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

\<close>

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

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

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

(*>*)
text\<open>

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

\FloatBarrier

\<close>
(*<*)

end
(*>*)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Signed Words"

theory Signed_Words
  imports "HOL-Library.Word"
begin

text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>

typedef ('a::len0) signed = "UNIV :: 'a set" ..

lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
  unfolding type_definition.card [OF type_definition_signed]
  by simp

instantiation signed :: (len0) len0
begin

definition
  len_signed [simp]: "len_of (x::'a::len0 signed itself) = LENGTH('a)"

instance ..

end

instance signed :: (len) len
  by (intro_classes, simp)

lemma scast_scast_id [simp]:
  "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
  "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
  by (auto simp: is_up scast_up_scast_id)

lemma ucast_scast_id [simp]:
  "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_of_nat [simp]:
  "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_ucast_id [simp]:
  "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
  by transfer (simp add: take_bit_signed_take_bit)

lemma scast_eq_scast_id [simp]:
  "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
  by (metis ucast_scast_id)

lemma ucast_eq_ucast_id [simp]:
  "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
  by (metis scast_ucast_id)

lemma scast_ucast_norm [simp]:
  "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
  "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
  by (metis scast_ucast_id ucast_scast_id)+

lemma scast_2_power [simp]: "scast ((2 :: 'a::len signed word) ^ x) = ((2 :: 'a word) ^ x)"
  by (rule bit_word_eqI) (auto simp add: bit_simps)

lemma ucast_nat_def':
  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> ('b :: len) signed word) x"
  by (fact of_nat_unat)

lemma zero_sle_ucast_up:
  "\<not> is_down (ucast :: 'a word \<Rightarrow> 'b signed word) \<Longrightarrow>
          (0 <=s ((ucast (b::('a::len) word)) :: ('b::len) signed word))"
  by transfer (simp add: bit_simps)

lemma word_le_ucast_sless:
  "\<lbrakk> x \<le> y; y \<noteq> -1; LENGTH('a) < LENGTH('b) \<rbrakk> \<Longrightarrow>
    (ucast x :: ('b :: len) signed word) <s ucast (y + 1)"
  for x y :: \<open>'a::len word\<close>
  apply (cases \<open>LENGTH('b)\<close>)
  apply simp_all
  apply transfer
  apply (simp add: signed_take_bit_take_bit)
  apply (metis add.commute mask_eq_exp_minus_1 mask_eq_take_bit_minus_one take_bit_incr_eq zle_add1_eq_le)
  done

lemma zero_sle_ucast:
  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                = (uint b < 2 ^ (LENGTH('a) - 1))"
  apply transfer
  apply (cases \<open>LENGTH('a)\<close>)
   apply (simp_all add: take_bit_Suc_from_most bit_simps)
  apply (simp_all add: bit_simps disjunctive_add)
  done

type_synonym 'a sword = "'a signed word"

end


(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * Analysis_OCL.thy --- OCL Contracts and an Example.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2012-2015 Université Paris-Saclay, Univ. Paris-Sud, France
 *               2013-2015 IRT SystemX, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

theory
  Analysis_OCL
imports
  Analysis_UML
begin
text \<open>\label{ex:employee-analysis:ocl}\<close>

section\<open>OCL Part: Invariant\<close>
text\<open>These recursive predicates can be defined conservatively
by greatest fix-point
constructions---automatically. See~\cite{brucker.ea:hol-ocl-book:2006,brucker:interactive:2007}
for details. For the purpose of this example, we state them as axioms
here.

\begin{ocl}
context Person
  inv label : self .boss <> null implies (self .salary  \<le>  ((self .boss) .salary))
\end{ocl}
\<close>

definition Person_label\<^sub>i\<^sub>n\<^sub>v :: "Person \<Rightarrow> Boolean"
where     "Person_label\<^sub>i\<^sub>n\<^sub>v (self) \<equiv>
                 (self .boss <> null implies (self .salary  \<le>\<^sub>i\<^sub>n\<^sub>t  ((self .boss) .salary)))"

definition Person_label\<^sub>i\<^sub>n\<^sub>v\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e :: "Person \<Rightarrow> Boolean"
where     "Person_label\<^sub>i\<^sub>n\<^sub>v\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e (self) \<equiv>
                 (self .boss@pre <> null implies (self .salary@pre \<le>\<^sub>i\<^sub>n\<^sub>t ((self .boss@pre) .salary@pre)))"

definition Person_label\<^sub>g\<^sub>l\<^sub>o\<^sub>b\<^sub>a\<^sub>l\<^sub>i\<^sub>n\<^sub>v :: "Boolean"
where     "Person_label\<^sub>g\<^sub>l\<^sub>o\<^sub>b\<^sub>a\<^sub>l\<^sub>i\<^sub>n\<^sub>v \<equiv> (Person .allInstances()->forAll\<^sub>S\<^sub>e\<^sub>t(x | Person_label\<^sub>i\<^sub>n\<^sub>v (x)) and
                                  (Person .allInstances@pre()->forAll\<^sub>S\<^sub>e\<^sub>t(x | Person_label\<^sub>i\<^sub>n\<^sub>v\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e (x))))"

lemma "\<tau> \<Turnstile> \<delta> (X .boss) \<Longrightarrow> \<tau> \<Turnstile> Person .allInstances()->includes\<^sub>S\<^sub>e\<^sub>t(X .boss) \<and>
                            \<tau> \<Turnstile> Person .allInstances()->includes\<^sub>S\<^sub>e\<^sub>t(X) "
oops
(* To be generated generically ... hard, but crucial lemma that should hold.
   It means that X and it successor are object representation that actually
   occur in the state. *)

lemma REC_pre : "\<tau> \<Turnstile> Person_label\<^sub>g\<^sub>l\<^sub>o\<^sub>b\<^sub>a\<^sub>l\<^sub>i\<^sub>n\<^sub>v
       \<Longrightarrow> \<tau> \<Turnstile> Person .allInstances()->includes\<^sub>S\<^sub>e\<^sub>t(X) \<comment> \<open>\<open>X\<close> represented object in state\<close>
       \<Longrightarrow> \<exists> REC.  \<tau> \<Turnstile> REC(X)  \<triangleq> (Person_label\<^sub>i\<^sub>n\<^sub>v (X) and (X .boss <> null implies REC(X .boss)))"
oops (* Attempt to allegiate the burden of he following axiomatizations: could be
        a witness for a constant specification ...*)

text\<open>This allows to state a predicate:\<close>

axiomatization inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l :: "Person \<Rightarrow> Boolean"
where inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l_def:
"(\<tau> \<Turnstile> Person .allInstances()->includes\<^sub>S\<^sub>e\<^sub>t(self)) \<Longrightarrow>
 (\<tau> \<Turnstile> (inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l(self) \<triangleq>  (self .boss <> null implies
                                  (self .salary  \<le>\<^sub>i\<^sub>n\<^sub>t  ((self .boss) .salary)) and
                                   inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l(self .boss))))"

axiomatization inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e :: "Person \<Rightarrow> Boolean"
where inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e_def:
"(\<tau> \<Turnstile> Person .allInstances@pre()->includes\<^sub>S\<^sub>e\<^sub>t(self)) \<Longrightarrow>
 (\<tau> \<Turnstile> (inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e(self) \<triangleq> (self .boss@pre <> null implies
                                   (self .salary@pre  \<le>\<^sub>i\<^sub>n\<^sub>t  ((self .boss@pre) .salary@pre)) and
                                    inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l\<^sub>A\<^sub>T\<^sub>p\<^sub>r\<^sub>e(self .boss@pre))))"

lemma inv_1 :
"(\<tau> \<Turnstile> Person .allInstances()->includes\<^sub>S\<^sub>e\<^sub>t(self)) \<Longrightarrow>
    (\<tau> \<Turnstile> inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l(self) = ((\<tau> \<Turnstile> (self .boss \<doteq> null)) \<or>
                               ( \<tau> \<Turnstile> (self .boss <> null) \<and>
                                 \<tau> \<Turnstile> ((self .salary)  \<le>\<^sub>i\<^sub>n\<^sub>t  (self .boss .salary))  \<and>
                                 \<tau> \<Turnstile> (inv\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<^sub>_\<^sub>l\<^sub>a\<^sub>b\<^sub>e\<^sub>l(self .boss))))) "
oops (* Let's hope that this holds ... *)

text\<open>A very first attempt to characterize the axiomatization by an inductive
definition - this can not be the last word since too weak (should be equality!)\<close>
coinductive inv :: "Person \<Rightarrow> (\<AA>)st \<Rightarrow> bool" where
 "(\<tau> \<Turnstile> (\<delta> self)) \<Longrightarrow> ((\<tau> \<Turnstile> (self .boss \<doteq> null)) \<or>
                      (\<tau> \<Turnstile> (self .boss <> null) \<and> (\<tau> \<Turnstile> (self .boss .salary \<le>\<^sub>i\<^sub>n\<^sub>t self .salary))  \<and>
                     ( (inv(self .boss))\<tau> )))
                     \<Longrightarrow> ( inv self \<tau>)"

section\<open>OCL Part: The Contract of a Recursive Query\<close>
text\<open>The original specification of a recursive query :
\begin{ocl}
context Person::contents():Set(Integer)
pre:   true
post:  result = if self.boss = null
                then Set{i}
                else self.boss.contents()->including(i)
                endif
\end{ocl}\<close>

text\<open>For the case of recursive queries, we use at present just axiomatizations:\<close>

axiomatization contents :: "Person \<Rightarrow> Set_Integer"  ("(1(_).contents'('))" 50)
where contents_def:
"(self .contents()) = (\<lambda> \<tau>. SOME res. let res = \<lambda> _. res in
                            if \<tau> \<Turnstile> (\<delta> self)
                            then ((\<tau> \<Turnstile> true) \<and>
                                  (\<tau> \<Turnstile> res \<triangleq> if (self .boss \<doteq> null)
                                              then (Set{self .salary})
                                              else (self .boss .contents()
                                                       ->including\<^sub>S\<^sub>e\<^sub>t(self .salary))
                                              endif))
                            else \<tau> \<Turnstile> res \<triangleq> invalid)"
and cp0_contents:"(X .contents()) \<tau> = ((\<lambda>_. X \<tau>) .contents()) \<tau>"

interpretation contents : contract0 "contents" "\<lambda> self. true"
                          "\<lambda> self res.  res \<triangleq> if (self .boss \<doteq> null)
                                              then (Set{self .salary})
                                              else (self .boss .contents()
                                                       ->including\<^sub>S\<^sub>e\<^sub>t(self .salary))
                                              endif"
         proof (unfold_locales)
            show "\<And>self \<tau>. true \<tau> = true \<tau>" by auto
         next
            show "\<And>self. \<forall>\<sigma> \<sigma>' \<sigma>''. ((\<sigma>, \<sigma>') \<Turnstile> true) = ((\<sigma>, \<sigma>'') \<Turnstile> true)" by auto
         next
            show "\<And>self. self .contents() \<equiv>
                       \<lambda> \<tau>. SOME res. let res = \<lambda> _. res in
                            if \<tau> \<Turnstile> (\<delta> self)
                            then ((\<tau> \<Turnstile> true) \<and>
                                  (\<tau> \<Turnstile> res \<triangleq> if (self .boss \<doteq> null)
                                              then (Set{self .salary})
                                              else (self .boss .contents()
                                                       ->including\<^sub>S\<^sub>e\<^sub>t(self .salary))
                                              endif))
                            else \<tau> \<Turnstile> res \<triangleq> invalid"
                  by(auto simp: contents_def )
         next
            have A:"\<And>self \<tau>. ((\<lambda>_. self \<tau>) .boss \<doteq> null) \<tau> = (\<lambda>_. (self .boss \<doteq> null) \<tau>) \<tau>"
            by (metis (no_types) StrictRefEq\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n cp_StrictRefEq\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<B>\<O>\<S>\<S>)
            have B:"\<And>self \<tau>. (\<lambda>_. Set{(\<lambda>_. self \<tau>) .salary} \<tau>) = (\<lambda>_. Set{self .salary} \<tau>)"
                   apply(subst UML_Set.OclIncluding.cp0)
                   apply(subst (2) UML_Set.OclIncluding.cp0)
                   apply(subst (2) Analysis_UML.cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<S>\<A>\<L>\<A>\<R>\<Y>) by simp
            have C:"\<And>self \<tau>. ((\<lambda>_. self \<tau>).boss .contents()->including\<^sub>S\<^sub>e\<^sub>t((\<lambda>_. self \<tau>).salary) \<tau>) =
                              (self .boss .contents() ->including\<^sub>S\<^sub>e\<^sub>t(self .salary) \<tau>)"
                   apply(subst UML_Set.OclIncluding.cp0) apply(subst (2) UML_Set.OclIncluding.cp0)
                   apply(subst (2) Analysis_UML.cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<S>\<A>\<L>\<A>\<R>\<Y>)
                   apply(subst cp0_contents)  apply(subst (2) cp0_contents)
                   apply(subst (2) cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<B>\<O>\<S>\<S>) by simp
            show "\<And>self res \<tau>.
                   (res \<triangleq> if (self .boss) \<doteq> null then Set{self .salary}
                           else self .boss .contents()->including\<^sub>S\<^sub>e\<^sub>t(self .salary) endif) \<tau> =
                   ((\<lambda>_. res \<tau>) \<triangleq> if (\<lambda>_. self \<tau>) .boss \<doteq> null then Set{(\<lambda>_. self \<tau>) .salary}
                                   else(\<lambda>_. self \<tau>) .boss .contents()->including\<^sub>S\<^sub>e\<^sub>t((\<lambda>_. self \<tau>) .salary) endif) \<tau>"
           apply(subst cp_StrongEq)
           apply(subst (2) cp_StrongEq)
           apply(subst cp_OclIf)
           apply(subst (2)cp_OclIf)
           by(simp add: A B C)
         qed

text\<open>Specializing @{thm contents.unfold2}, one gets the following more practical rewrite
rule that is amenable to symbolic evaluation:\<close>
theorem unfold_contents :
   assumes "cp E"
   and     "\<tau> \<Turnstile> \<delta> self"
   shows   "(\<tau> \<Turnstile> E (self .contents())) =
            (\<tau> \<Turnstile> E (if self .boss \<doteq> null
                    then Set{self .salary}
                    else self .boss .contents()->including\<^sub>S\<^sub>e\<^sub>t(self .salary) endif))"
by(rule contents.unfold2[of _ _ _ "\<lambda> X. true"], simp_all add: assms)

text\<open>Since we have only one interpretation function, we need the corresponding
operation on the pre-state:\<close>

consts contentsATpre :: "Person \<Rightarrow> Set_Integer"  ("(1(_).contents@pre'('))" 50)

axiomatization where contentsATpre_def:
" (self).contents@pre() = (\<lambda> \<tau>.
      SOME res. let res = \<lambda> _. res in
      if \<tau> \<Turnstile> (\<delta> self)
      then ((\<tau> \<Turnstile> true) \<and>                            \<comment> \<open>pre\<close>
            (\<tau> \<Turnstile> (res \<triangleq> if (self).boss@pre \<doteq> null  \<comment> \<open>post\<close>
                         then Set{(self).salary@pre}
                         else (self).boss@pre .contents@pre()
                                    ->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre)
                         endif)))
      else \<tau> \<Turnstile> res \<triangleq> invalid)"
and cp0_contents_at_pre:"(X .contents@pre()) \<tau> = ((\<lambda>_. X \<tau>) .contents@pre()) \<tau>"

interpretation contentsATpre : contract0 "contentsATpre" "\<lambda> self. true"
                          "\<lambda> self res.  res \<triangleq> if (self .boss@pre \<doteq> null)
                                                               then (Set{self .salary@pre})
                                                               else (self .boss@pre .contents@pre()
                                                                        ->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre))
                                                               endif"
         proof (unfold_locales)
            show "\<And>self \<tau>. true \<tau> = true \<tau>" by auto
         next
            show "\<And>self. \<forall>\<sigma> \<sigma>' \<sigma>''. ((\<sigma>, \<sigma>') \<Turnstile> true) = ((\<sigma>, \<sigma>'') \<Turnstile> true)" by auto
         next
            show "\<And>self. self .contents@pre() \<equiv>
                         \<lambda>\<tau>. SOME res. let res = \<lambda> _. res in
                             if \<tau> \<Turnstile> \<delta> self
                             then \<tau> \<Turnstile> true \<and>
                                  \<tau> \<Turnstile> res \<triangleq> (if self .boss@pre \<doteq> null then Set{self .salary@pre}
                                              else self .boss@pre .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre)
                                              endif)
                             else \<tau> \<Turnstile> res \<triangleq> invalid"
                  by(auto simp: contentsATpre_def)
         next
            have A:"\<And>self \<tau>. ((\<lambda>_. self \<tau>) .boss@pre \<doteq> null) \<tau> = (\<lambda>_. (self .boss@pre \<doteq> null) \<tau>) \<tau>"
            by (metis StrictRefEq\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n cp_StrictRefEq\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<B>\<O>\<S>\<S>_at_pre)
            have B:"\<And>self \<tau>. (\<lambda>_. Set{(\<lambda>_. self \<tau>) .salary@pre} \<tau>) = (\<lambda>_. Set{self .salary@pre} \<tau>)"
                   apply(subst UML_Set.OclIncluding.cp0)
                   apply(subst (2) UML_Set.OclIncluding.cp0)
                   apply(subst (2) Analysis_UML.cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<S>\<A>\<L>\<A>\<R>\<Y>_at_pre) by simp
            have C:"\<And>self \<tau>. ((\<lambda>_. self \<tau>).boss@pre .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t((\<lambda>_. self \<tau>).salary@pre) \<tau>) =
                              (self .boss@pre .contents@pre() ->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre) \<tau>)"
                   apply(subst UML_Set.OclIncluding.cp0) apply(subst (2) UML_Set.OclIncluding.cp0)
                   apply(subst (2) Analysis_UML.cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<S>\<A>\<L>\<A>\<R>\<Y>_at_pre)
                   apply(subst cp0_contents_at_pre)  apply(subst (2) cp0_contents_at_pre)
                   apply(subst (2) cp_dot\<^sub>P\<^sub>e\<^sub>r\<^sub>s\<^sub>o\<^sub>n\<B>\<O>\<S>\<S>_at_pre) by simp
           show "\<And>self res \<tau>.
                   (res \<triangleq> if (self .boss@pre) \<doteq> null then Set{self .salary@pre}
                           else self .boss@pre .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre) endif) \<tau> =
                   ((\<lambda>_. res \<tau>) \<triangleq> if (\<lambda>_. self \<tau>) .boss@pre \<doteq> null then Set{(\<lambda>_. self \<tau>) .salary@pre}
                                   else(\<lambda>_. self \<tau>) .boss@pre .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t((\<lambda>_. self \<tau>) .salary@pre) endif) \<tau>"
           apply(subst cp_StrongEq)
           apply(subst (2) cp_StrongEq)
           apply(subst cp_OclIf)
           apply(subst (2)cp_OclIf)
           by(simp add: A B C)
         qed

text\<open>Again, we derive via @{thm [source] contents.unfold2} a Knaster-Tarski like Fixpoint rule
that is amenable to symbolic evaluation:\<close>
theorem unfold_contentsATpre :
   assumes "cp E"
   and     "\<tau> \<Turnstile> \<delta> self"
   shows   "(\<tau> \<Turnstile> E (self .contents@pre())) =
            (\<tau> \<Turnstile> E (if self .boss@pre \<doteq> null
                    then Set{self .salary@pre}
                    else self .boss@pre .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t(self .salary@pre) endif))"
by(rule contentsATpre.unfold2[of _ _ _ "\<lambda> X. true"], simp_all add: assms)

text\<open>Note that these \inlineocl{@pre} variants on methods are only available on queries, \ie,
operations without side-effect.\<close>

section\<open>OCL Part: The Contract of a User-defined Method\<close>
text\<open>
The example specification in high-level OCL input syntax reads as follows:
\begin{ocl}
context Person::insert(x:Integer)
pre: true
post: contents():Set(Integer)
contents() = contents@pre()->including(x)
\end{ocl}

This boils down to:
\<close>

definition insert :: "Person \<Rightarrow>Integer \<Rightarrow> Void"  ("(1(_).insert'(_'))" 50)
where "self .insert(x) \<equiv>
            (\<lambda> \<tau>. SOME res. let res = \<lambda> _. res in
                  if (\<tau> \<Turnstile> (\<delta> self)) \<and>  (\<tau> \<Turnstile> \<upsilon> x)
                  then (\<tau> \<Turnstile> true \<and>
                       (\<tau> \<Turnstile> ((self).contents() \<triangleq> (self).contents@pre()->including\<^sub>S\<^sub>e\<^sub>t(x))))
                  else \<tau> \<Turnstile> res \<triangleq> invalid)"

text\<open>The semantic consequences of this definition were computed inside this locale interpretation:\<close>
interpretation insert : contract1 "insert" "\<lambda> self x. true"
                                  "\<lambda> self x res. ((self .contents()) \<triangleq>
                                                       (self .contents@pre()->including\<^sub>S\<^sub>e\<^sub>t(x)))"
         apply unfold_locales  apply(auto simp:insert_def)
         apply(subst cp_StrongEq) apply(subst (2) cp_StrongEq)
         apply(subst contents.cp0)
         apply(subst UML_Set.OclIncluding.cp0)
         apply(subst (2) UML_Set.OclIncluding.cp0)
         apply(subst contentsATpre.cp0)
         by(simp)  (* an extremely hacky proof that cries for reformulation and automation - bu *)

text\<open>The result of this locale interpretation for our @{term insert}  contract is the following
set of properties, which serves as basis for automated deduction on them:

\begin{table}[htbp]
   \centering
   \begin{tabu}{lX[,c,]}
      \toprule
      Name & Theorem \\
      \midrule
      @{thm [source] insert.strict0}  & @{thm  [display=false] insert.strict0} \\
      @{thm [source] insert.nullstrict0}  & @{thm  [display=false] insert.nullstrict0} \\
      @{thm [source] insert.strict1}  & @{thm  [display=false] insert.strict1} \\
      @{thm [source] insert.cp\<^sub>P\<^sub>R\<^sub>E}  & @{thm  [display=false] insert.cp\<^sub>P\<^sub>R\<^sub>E} \\
      @{thm [source] insert.cp\<^sub>P\<^sub>O\<^sub>S\<^sub>T}  & @{thm  [display=false] insert.cp\<^sub>P\<^sub>O\<^sub>S\<^sub>T} \\
      @{thm [source] insert.cp_pre}  & @{thm  [display=false] insert.cp_pre} \\
      @{thm [source] insert.cp_post}  & @{thm [display=false] insert.cp_post} \\
      @{thm [source] insert.cp}   & @{thm  [display=false] insert.cp} \\
      @{thm [source] insert.cp0}   & @{thm  [display=false] insert.cp0} \\
      @{thm [source] insert.def_scheme}   & @{thm  [display=false] insert.def_scheme} \\
      @{thm [source] insert.unfold} & @{thm [display=false] insert.unfold} \\
      @{thm [source] insert.unfold2} & @{thm [display=false] insert.unfold2} \\
      \bottomrule
   \end{tabu}
   \caption{Semantic properties resulting from a user-defined operation contract.}
   \label{tab:sem_operation_contract}
\end{table}

\<close>

end