section "CRDT Specifications For Verification"
theory crdt_specs_v
  imports repliss_sem crdt_specs
begin

text "The previous CRDT are not nice to work with when composed.
The problem is, that the specifications for maps and structs transform the context
passed to embedded CRDTs.
During this transformation the reverse direction is lost, so it is hard to reconstruct the original
calls from the calls in an embedded context.
Therefore, we now use a different composition technique, where the mapping is explicitly passed down
into nested CRDTs."

text "In the following type definition we have three type parameters:

\<^enum> op is the type of operations at the top level
\<^enum> opn is the type of nested operations, on which the specification works
\<^enum> res is the type of results "

text_raw \<open>\DefineSnippet{ccrdtSpec}{\<close>
type_synonym ('op, 'opn, 'res) cOperationResultSpec =
        "callId set                  \<comment> \<open>visible calls\<close>
      \<Rightarrow> (callId \<Rightarrow>'op)              \<comment> \<open>call information\<close>
      \<Rightarrow> callId rel                  \<comment> \<open>happens-before\<close>
      \<Rightarrow> ('opn \<Rightarrow> 'op)               \<comment> \<open>mapping back\<close>
      \<Rightarrow> 'res
      \<Rightarrow> bool"

type_synonym ('op, 'opn, 'res) ccrdtSpec =
        "'opn \<Rightarrow> ('op, 'opn, 'res) cOperationResultSpec"
text_raw \<open>}%EndSnippet\<close>

definition
"extract_op c_calls c \<equiv> call_operation (the (c_calls c))"

text "The following function converts "

definition toplevel_spec :: "('op, 'op, 'res) ccrdtSpec \<Rightarrow>  ('op, 'res, 'a) operationContext_scheme \<Rightarrow> callId set \<Rightarrow> 'op \<Rightarrow> 'res  \<Rightarrow> bool" where
"toplevel_spec S ctxt vis op  \<equiv> S op vis (extract_op (calls ctxt)) (happensBefore ctxt) id"

text "There is a mapping between the composable CRDT specs above and the original specifications:"

lemma extract_op_def':
"extract_op (c_calls::('b \<Rightarrow> ('a, 'c) call option)) c
  = ( case c_calls c of Some (Call op r) \<Rightarrow> op | _ \<Rightarrow> call_operation (the (None :: ('a, 'c) call option)))"
  by (auto simp add: extract_op_def split: option.splits call.splits)

lemma extract_op_eq:
  assumes "c\<in>dom c_calls"
  shows "extract_op c_calls c = oper \<longleftrightarrow> (\<exists>res. c_calls c \<triangleq> Call oper res)"
  using assms by (auto simp add: extract_op_def' split: option.splits call.splits)

lemma extract_op_eq':
  assumes "c\<in>dom c_calls"
  shows "extract_op c_calls c = oper \<longleftrightarrow> (cOp c_calls c \<triangleq> oper)"
  unfolding extract_op_eq[OF assms]
  by (auto simp add: cOp_def)
   (metis call.collapse)

lemma calls_sub_context:
  "calls (sub_context C_in Cs ctxt) =
(\<lambda>c. (calls ctxt |` Cs) c \<bind> (\<lambda>call. case C_in (call_operation call) of None \<Rightarrow> None | Some op' \<Rightarrow> Some (Call op' (call_res call))))
"
  by (auto simp add: sub_context_def restrict_ctxt_op_def restrict_ctxt_def fmap_map_values_def ctxt_restrict_calls_def
      option_bind_def
      split: option.splits call.splits)

lemma happens_before_sub_context:
  "(x,y) \<in> happensBefore (sub_context C_in Cs ctxt)
\<longleftrightarrow> ((x,y) \<in> happensBefore ctxt \<and> x\<in>dom (calls (sub_context  C_in Cs ctxt)) \<and> y\<in>dom (calls (sub_context  C_in Cs ctxt)))
"
  by (auto simp add: sub_context_def restrict_ctxt_op_def restrict_ctxt_def fmap_map_values_def
 ctxt_restrict_calls_def restrict_map_def restrict_relation_def option_bind_def
 split: if_splits option.splits call.splits)

lemma dom_calls_sub_context_rewrite: "(dom (map_map (calls ctxt) call_operation \<ggreater> C_in) \<inter> Cs)
  = (dom (calls (sub_context C_in Cs ctxt)))"
  by (auto simp add: calls_sub_context option_bind_def map_chain_def restrict_map_def  split: option.splits if_splits)

lemma extract_op_to_call:
  assumes "is_reverse C_in C_out"
and "c\<in>dom (calls (sub_context C_in Cs ctxt))"
shows "extract_op (calls ctxt) c = C_out op
\<longleftrightarrow> (\<exists>r. calls ctxt c \<triangleq> Call (C_out op) r)"
  by (smt IntD2 assms(2) call.collapse call.sel(1) calls_sub_context domExists_simp domIff dom_calls_sub_context_rewrite extract_op_def is_none_bind is_none_simps(1) is_none_simps(2) option.sel restrict_in)

lemma extract_op_into_sub_context:
  assumes is_rev: "is_reverse C_in C_out"
and in_dom: "c\<in>dom (calls (sub_context C_in Cs ctxt))"
shows "extract_op (calls ctxt) c = C_out op
\<longleftrightarrow> (\<exists>r. calls (sub_context C_in Cs ctxt) c \<triangleq> Call op r)"
  using in_dom  by (auto simp add: calls_sub_context restrict_map_def option_bind_def
 call_operation_def extract_op_def is_rev is_reverse_2
      split: option.splits if_splits call.splits)
  (use is_rev is_reverse_1 in fastforce)

lemma extract_op_into_sub_context':
  assumes is_rev: "is_reverse C_in C_out"
and in_dom: "c\<in>dom (calls (sub_context C_in Cs ctxt))"
shows "extract_op (calls ctxt) c = C_out op
\<longleftrightarrow> Op (sub_context C_in Cs ctxt) c \<triangleq> op"
  using extract_op_into_sub_context[OF is_rev in_dom]
  by (auto simp add: cOp_def)
   (metis call.collapse)

lemma happens_before_into_sub_context:
  assumes is_rev: "is_reverse C_in C_out"
and in_dom_x: "x\<in>dom (calls (sub_context C_in Cs ctxt))"
and in_dom_y: "y\<in>dom (calls (sub_context C_in Cs ctxt))"
shows "(x,y) \<in> happensBefore ctxt
\<longleftrightarrow> (x,y) \<in> happensBefore (sub_context C_in Cs ctxt)"
  using in_dom_x in_dom_y  by (auto simp add:  restrict_map_def option_bind_def
 call_operation_def extract_op_def is_rev is_reverse_2
 happens_before_sub_context
      split: option.splits if_splits call.splits)

text_raw \<open>\DefineSnippet{crdt_spec_rel}{\<close>
definition crdt_spec_rel :: "('opn, 'res) crdtSpec \<Rightarrow> ('op, 'opn, 'res) ccrdtSpec \<Rightarrow> bool" where
"crdt_spec_rel spec cspec \<equiv>
\<forall>C_in::'op \<rightharpoonup> 'opn. \<forall>C_out::'opn \<Rightarrow> 'op.
  is_reverse C_in C_out
  \<longrightarrow>
  (\<forall>ctxt (outer_op::'op) (op::'opn) r Cs.
       C_in outer_op \<triangleq> op
    \<longrightarrow> Cs \<subseteq> (dom (calls ctxt))
    \<longrightarrow> operationContext_wf ctxt
    \<longrightarrow>
       (spec op (sub_context C_in Cs ctxt) r
    \<longleftrightarrow> cspec op Cs (extract_op (calls ctxt))  (happensBefore ctxt) C_out r))"
text_raw \<open>}%EndSnippet\<close>

lemmas use_crdt_spec_rel = crdt_spec_rel_def[unfolded atomize_eq, THEN iffD1, rule_format]
lemmas use_crdt_spec_rel1 = crdt_spec_rel_def[unfolded atomize_eq, THEN iffD1, rule_format, THEN iffD1]
lemmas use_crdt_spec_rel2 = crdt_spec_rel_def[unfolded atomize_eq, THEN iffD1, rule_format, THEN iffD2]

lemma use_crdt_spec_rel_toplevel:
  assumes rel: "crdt_spec_rel spec cspec"
    and wf: "operationContext_wf ctxt"
  shows "spec op ctxt r
 =  cspec op (dom (calls ctxt)) (extract_op (calls ctxt)) (happensBefore ctxt) id  r"
proof (fuzzy_rule use_crdt_spec_rel[OF rel])

  have hb_wf: "Field (happensBefore ctxt) \<subseteq> dom (calls ctxt)"
    by (simp add: wf operationContext_wf_hb_field)

  show "is_reverse Some id"
    by (simp add: is_reverse_def)

  show "Some op \<triangleq> op"
    by simp

  show "dom (calls ctxt) \<subseteq> dom (calls ctxt)"
    by simp

  have h1: "calls (sub_context Some UNIV ctxt) =  calls ctxt "
    by (auto simp add: calls_sub_context)

  have h2: "happensBefore (sub_context Some UNIV ctxt) =  happensBefore ctxt "
    by (auto simp add: happens_before_sub_context calls_sub_context)
      (meson FieldI1 FieldI2 domD hb_wf subsetD in_mono)+

  from h1 h2
  show "sub_context Some (dom (calls ctxt)) ctxt = ctxt"
    by (simp add: ctxt_restrict_calls_def hb_wf restrict_map_noop restrict_relation_noop sub_context_def)

  show "operationContext_wf ctxt" using `operationContext_wf ctxt` .
qed

lemma show_crdt_spec_rel:
  assumes
  a: "\<And>C_in C_out  ctxt outer_op op r Cs.
\<lbrakk>is_reverse C_in C_out;
operationContext_wf ctxt;
 C_in outer_op \<triangleq> op;
Cs \<subseteq> dom (calls ctxt)\<rbrakk> \<Longrightarrow>
     spec op (sub_context C_in Cs ctxt) r
 \<longleftrightarrow> cspec op Cs (extract_op (calls ctxt))  (happensBefore ctxt) C_out  r
"
shows "crdt_spec_rel spec cspec"
  by (simp add: crdt_spec_rel_def assms dom_calls_sub_context_rewrite inf.absorb_iff2)

lemma show_crdt_spec_rel':
  assumes
  a: "\<And>C_in C_out  ctxt outer_op op r Cs.
\<lbrakk>is_reverse C_in C_out;
operationContext_wf ctxt;
 C_in outer_op \<triangleq> op;
Cs \<subseteq> dom (calls ctxt)\<rbrakk> \<Longrightarrow>
     spec op (sub_context C_in Cs ctxt) r
 \<longleftrightarrow> cspec op Cs (extract_op (calls ctxt))  (happensBefore ctxt) C_out  r
"
shows "crdt_spec_rel spec cspec"
  by (simp add: crdt_spec_rel_def assms dom_calls_sub_context_rewrite inf.absorb_iff2)

definition convert_spec ::  "('op, 'op, 'res) ccrdtSpec \<Rightarrow> ('op, 'res) crdtSpec" where
"convert_spec cspec op ctxt res \<equiv>
  cspec op (dom (calls ctxt)) (extract_op (calls ctxt)) (happensBefore ctxt) id  res"

lemma crdt_spec_rel_convert:
  assumes rel: "crdt_spec_rel spec cspec"
    and field: "Field (happensBefore ctxt) \<subseteq> dom (calls (ctxt))"
    and "operationContext_wf ctxt"
  shows "spec op ctxt r = convert_spec cspec op ctxt r"
  unfolding convert_spec_def
proof -
  show "spec op ctxt r = cspec op (dom (calls ctxt)) (extract_op (calls ctxt)) (happensBefore ctxt) id  r"
  proof (fuzzy_rule use_crdt_spec_rel[OF rel])
    show "is_reverse Some id"
      by (simp add: is_reverse_def)
    show "Some op \<triangleq> op"
      by simp
    show "dom (calls ctxt) \<subseteq> dom (calls ctxt)"
      by (auto simp add: map_chain_def)
    have h1: "calls (sub_context Some UNIV ctxt) = calls ctxt "
      by (auto simp add: calls_sub_context)

    have h2: "happensBefore (sub_context Some UNIV ctxt) = happensBefore ctxt "
      using field by (auto simp add: happens_before_sub_context
          FieldI1 FieldI2 h1 domD subset_h1)

    from h1 h2
    show "sub_context Some (dom (calls ctxt)) ctxt = ctxt"
      by (simp add: ctxt_restrict_calls_def field restrict_map_noop restrict_relation_noop sub_context_def)

    show "operationContext_wf ctxt"
      by (simp add: assms)
  qed
qed

definition ccrdtSpec_wf :: "('op, 'opn, 'res) ccrdtSpec \<Rightarrow> bool" where
"ccrdtSpec_wf spec  \<equiv>
\<forall>opr Cs Cs' op op' hb hb' C_out r.
map_same_on Cs' op op'
\<longrightarrow> rel_same_on Cs' hb hb'
\<longrightarrow> Cs' \<subseteq> Cs
\<longrightarrow> (\<forall>c\<in>Cs. (\<exists>y. C_out y = op c) \<longrightarrow> c\<in>Cs')
\<longrightarrow> (     spec opr Cs op  hb  C_out r
     \<longleftrightarrow>  spec opr Cs' op' hb' C_out r)"

lemmas use_ccrdtSpec_wf' = ccrdtSpec_wf_def[unfolded atomize_eq, THEN iffD1, rule_format]
lemmas use_ccrdtSpec_wf'1 = use_ccrdtSpec_wf'[THEN iffD1]
lemmas use_ccrdtSpec_wf'2 = use_ccrdtSpec_wf'[THEN iffD2]

lemma use_ccrdtSpec_wf:
  assumes "ccrdtSpec_wf spec"
    and "map_same_on Cs op op'"
    and "rel_same_on Cs hb hb'"
  shows "spec opr Cs op hb C_out r = spec opr Cs op' hb' C_out r"
  using assms
  by (rule use_ccrdtSpec_wf') auto

lemmas use_ccrdtSpec_wf1 = use_ccrdtSpec_wf[THEN iffD1]
lemmas use_ccrdtSpec_wf2 = use_ccrdtSpec_wf[THEN iffD2]

end


(*  Title:      HOL/HOLCF/Powerdomains.thy
    Author:     Brian Huffman
*)

section \<open>Powerdomains\<close>

theory Powerdomains
imports ConvexPD Domain
begin

subsection \<open>Universal domain embeddings\<close>

definition "upper_emb = udom_emb (\<lambda>i. upper_map\<cdot>(udom_approx i))"
definition "upper_prj = udom_prj (\<lambda>i. upper_map\<cdot>(udom_approx i))"

definition "lower_emb = udom_emb (\<lambda>i. lower_map\<cdot>(udom_approx i))"
definition "lower_prj = udom_prj (\<lambda>i. lower_map\<cdot>(udom_approx i))"

definition "convex_emb = udom_emb (\<lambda>i. convex_map\<cdot>(udom_approx i))"
definition "convex_prj = udom_prj (\<lambda>i. convex_map\<cdot>(udom_approx i))"

lemma ep_pair_upper: "ep_pair upper_emb upper_prj"
  unfolding upper_emb_def upper_prj_def
  by (simp add: ep_pair_udom approx_chain_upper_map)

lemma ep_pair_lower: "ep_pair lower_emb lower_prj"
  unfolding lower_emb_def lower_prj_def
  by (simp add: ep_pair_udom approx_chain_lower_map)

lemma ep_pair_convex: "ep_pair convex_emb convex_prj"
  unfolding convex_emb_def convex_prj_def
  by (simp add: ep_pair_udom approx_chain_convex_map)

subsection \<open>Deflation combinators\<close>

definition upper_defl :: "udom defl \<rightarrow> udom defl"
  where "upper_defl = defl_fun1 upper_emb upper_prj upper_map"

definition lower_defl :: "udom defl \<rightarrow> udom defl"
  where "lower_defl = defl_fun1 lower_emb lower_prj lower_map"

definition convex_defl :: "udom defl \<rightarrow> udom defl"
  where "convex_defl = defl_fun1 convex_emb convex_prj convex_map"

lemma cast_upper_defl:
  "cast\<cdot>(upper_defl\<cdot>A) = upper_emb oo upper_map\<cdot>(cast\<cdot>A) oo upper_prj"
using ep_pair_upper finite_deflation_upper_map
unfolding upper_defl_def by (rule cast_defl_fun1)

lemma cast_lower_defl:
  "cast\<cdot>(lower_defl\<cdot>A) = lower_emb oo lower_map\<cdot>(cast\<cdot>A) oo lower_prj"
using ep_pair_lower finite_deflation_lower_map
unfolding lower_defl_def by (rule cast_defl_fun1)

lemma cast_convex_defl:
  "cast\<cdot>(convex_defl\<cdot>A) = convex_emb oo convex_map\<cdot>(cast\<cdot>A) oo convex_prj"
using ep_pair_convex finite_deflation_convex_map
unfolding convex_defl_def by (rule cast_defl_fun1)

subsection \<open>Domain class instances\<close>

instantiation upper_pd :: ("domain") "domain"
begin

definition
  "emb = upper_emb oo upper_map\<cdot>emb"

definition
  "prj = upper_map\<cdot>prj oo upper_prj"

definition
  "defl (t::'a upper_pd itself) = upper_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a upper_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a upper_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a upper_pd itself) = liftdefl_of\<cdot>DEFL('a upper_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a upper_pd)"
    unfolding emb_upper_pd_def prj_upper_pd_def
    by (intro ep_pair_comp ep_pair_upper ep_pair_upper_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a upper_pd) = emb oo (prj :: udom \<rightarrow> 'a upper_pd)"
    unfolding emb_upper_pd_def prj_upper_pd_def defl_upper_pd_def cast_upper_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff upper_map_map)
qed (fact liftemb_upper_pd_def liftprj_upper_pd_def liftdefl_upper_pd_def)+

end

instantiation lower_pd :: ("domain") "domain"
begin

definition
  "emb = lower_emb oo lower_map\<cdot>emb"

definition
  "prj = lower_map\<cdot>prj oo lower_prj"

definition
  "defl (t::'a lower_pd itself) = lower_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a lower_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a lower_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a lower_pd itself) = liftdefl_of\<cdot>DEFL('a lower_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a lower_pd)"
    unfolding emb_lower_pd_def prj_lower_pd_def
    by (intro ep_pair_comp ep_pair_lower ep_pair_lower_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a lower_pd) = emb oo (prj :: udom \<rightarrow> 'a lower_pd)"
    unfolding emb_lower_pd_def prj_lower_pd_def defl_lower_pd_def cast_lower_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff lower_map_map)
qed (fact liftemb_lower_pd_def liftprj_lower_pd_def liftdefl_lower_pd_def)+

end

instantiation convex_pd :: ("domain") "domain"
begin

definition
  "emb = convex_emb oo convex_map\<cdot>emb"

definition
  "prj = convex_map\<cdot>prj oo convex_prj"

definition
  "defl (t::'a convex_pd itself) = convex_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a convex_pd u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a convex_pd u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a convex_pd itself) = liftdefl_of\<cdot>DEFL('a convex_pd)"

instance proof
  show "ep_pair emb (prj :: udom \<rightarrow> 'a convex_pd)"
    unfolding emb_convex_pd_def prj_convex_pd_def
    by (intro ep_pair_comp ep_pair_convex ep_pair_convex_map ep_pair_emb_prj)
next
  show "cast\<cdot>DEFL('a convex_pd) = emb oo (prj :: udom \<rightarrow> 'a convex_pd)"
    unfolding emb_convex_pd_def prj_convex_pd_def defl_convex_pd_def cast_convex_defl
    by (simp add: cast_DEFL oo_def cfun_eq_iff convex_map_map)
qed (fact liftemb_convex_pd_def liftprj_convex_pd_def liftdefl_convex_pd_def)+

end

lemma DEFL_upper: "DEFL('a::domain upper_pd) = upper_defl\<cdot>DEFL('a)"
by (rule defl_upper_pd_def)

lemma DEFL_lower: "DEFL('a::domain lower_pd) = lower_defl\<cdot>DEFL('a)"
by (rule defl_lower_pd_def)

lemma DEFL_convex: "DEFL('a::domain convex_pd) = convex_defl\<cdot>DEFL('a)"
by (rule defl_convex_pd_def)

subsection \<open>Isomorphic deflations\<close>

lemma isodefl_upper:
  "isodefl d t \<Longrightarrow> isodefl (upper_map\<cdot>d) (upper_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_upper_defl cast_isodefl)
apply (simp add: emb_upper_pd_def prj_upper_pd_def)
apply (simp add: upper_map_map)
done

lemma isodefl_lower:
  "isodefl d t \<Longrightarrow> isodefl (lower_map\<cdot>d) (lower_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_lower_defl cast_isodefl)
apply (simp add: emb_lower_pd_def prj_lower_pd_def)
apply (simp add: lower_map_map)
done

lemma isodefl_convex:
  "isodefl d t \<Longrightarrow> isodefl (convex_map\<cdot>d) (convex_defl\<cdot>t)"
apply (rule isodeflI)
apply (simp add: cast_convex_defl cast_isodefl)
apply (simp add: emb_convex_pd_def prj_convex_pd_def)
apply (simp add: convex_map_map)
done

subsection \<open>Domain package setup for powerdomains\<close>

lemmas [domain_defl_simps] = DEFL_upper DEFL_lower DEFL_convex
lemmas [domain_map_ID] = upper_map_ID lower_map_ID convex_map_ID
lemmas [domain_isodefl] = isodefl_upper isodefl_lower isodefl_convex

lemmas [domain_deflation] =
  deflation_upper_map deflation_lower_map deflation_convex_map

setup \<open>
  fold Domain_Take_Proofs.add_rec_type
    [(\<^type_name>\<open>upper_pd\<close>, [true]),
     (\<^type_name>\<open>lower_pd\<close>, [true]),
     (\<^type_name>\<open>convex_pd\<close>, [true])]
\<close>

end


theory Fiction_Space
  imports "Phi_Semantics_Framework.Phi_Semantics_Framework"
begin

unspecified_type FIC \<comment> \<open>Deep representation of fictions\<close>
type_synonym fiction_kind = \<open>(FIC, resource) interp\<close>
type_synonym fiction = \<open>fiction_kind \<Rightarrow> FIC\<close>
type_synonym assn = \<open>fiction set\<close>

debt_axiomatization FIC_sort: \<open>OFCLASS(FIC, sep_algebra_class)\<close>
instance FIC :: sep_algebra using FIC_sort .

definition INTERP :: \<open>(fiction, resource) interp\<close>
  where "INTERP = \<F>_fun' id"

definition "Fic_Space (f::fiction) \<longleftrightarrow> finite (dom1 f)"

text \<open>Predicate \<open>Fic_Space\<close> characterizes instances of fictional spaces
      --- the number of fiction kinds must be finite.
      @{thm dom1_def}.
      Recall unit \<open>1\<close> represents empty and none resource. In the case of \<open>\<alpha> option\<close>,
      \<open>1 \<triangleq> None\<close>.\<close>

lemma Fic_Space_Un:
  \<open>a ## b \<Longrightarrow> Fic_Space (a*b) \<longleftrightarrow> Fic_Space a \<and> Fic_Space b\<close>
  unfolding Fic_Space_def by (simp add: dom1_sep_mult_disjoint)

lemma Fic_Space_1[simp]: \<open>Fic_Space 1\<close>
  unfolding Fic_Space_def by simp

class fiction_kind = sep_algebra +
  fixes FIC_inj :: \<open>'a::sep_algebra \<Rightarrow> FIC\<close>
    and FIC_prj :: \<open>FIC \<Rightarrow> 'a\<close>
  assumes \<open>sep_inj_proj FIC_inj FIC_prj\<close>
begin

sublocale FK: sep_inj_proj FIC_inj FIC_prj
  using fiction_kind_axioms[unfolded class.fiction_kind_def class.fiction_kind_axioms_def] by blast

end

term FIC_inj
thm FK.inject_inj

term inject

hide_const (open) inject project

interpretation xx: resource_kind_algebra name fiction_kind.inject fiction_kind.project

end


(*  Title:      HOL/MicroJava/BV/LBVJVM.thy
    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

section \<open>LBV for the JVM \label{sec:JVM}\<close>

theory LBVJVM
imports Typing_Framework_JVM
begin

type_synonym prog_cert = "cname \<Rightarrow> sig \<Rightarrow> JVMType.state list"

definition check_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> JVMType.state list \<Rightarrow> bool" where
  "check_cert G mxs mxr n cert \<equiv> check_types G mxs mxr cert \<and> length cert = n+1 \<and>
                                 (\<forall>i<n. cert!i \<noteq> Err) \<and> cert!n = OK None"

definition lbvjvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow>
             JVMType.state list \<Rightarrow> instr list \<Rightarrow> JVMType.state \<Rightarrow> JVMType.state" where
  "lbvjvm G maxs maxr rT et cert bs \<equiv>
  wtl_inst_list bs cert  (JVMType.sup G maxs maxr) (JVMType.le G maxs maxr) Err (OK None) (exec G maxs rT et bs) 0"

definition wt_lbv :: "jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             exception_table \<Rightarrow> JVMType.state list \<Rightarrow> instr list \<Rightarrow> bool" where
  "wt_lbv G C pTs rT mxs mxl et cert ins \<equiv>
   check_bounded ins et \<and>
   check_cert G mxs (1+size pTs+mxl) (length ins) cert \<and>
   0 < size ins \<and>
   (let start  = Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err));
        result = lbvjvm G mxs (1+size pTs+mxl) rT et cert ins (OK start)
    in result \<noteq> Err)"

definition wt_jvm_prog_lbv :: "jvm_prog \<Rightarrow> prog_cert \<Rightarrow> bool" where
  "wt_jvm_prog_lbv G cert \<equiv>
  wf_prog (\<lambda>G C (sig,rT,(maxs,maxl,b,et)). wt_lbv G C (snd sig) rT maxs maxl et (cert C sig) b) G"

definition mk_cert :: "jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> exception_table \<Rightarrow> instr list
              \<Rightarrow> method_type \<Rightarrow> JVMType.state list" where
  "mk_cert G maxs rT et bs phi \<equiv> make_cert (exec G maxs rT et bs) (map OK phi) (OK None)"

definition prg_cert :: "jvm_prog \<Rightarrow> prog_type \<Rightarrow> prog_cert" where
  "prg_cert G phi C sig \<equiv> let (C,rT,(maxs,maxl,ins,et)) = the (method (G,C) sig) in
                           mk_cert G maxs rT et ins (phi C sig)"

lemma wt_method_def2:
  fixes pTs and mxl and G and mxs and rT and et and bs and phi
  defines [simp]: "mxr   \<equiv> 1 + length pTs + mxl"
  defines [simp]: "r     \<equiv> sup_state_opt G"
  defines [simp]: "app0  \<equiv> \<lambda>pc. app (bs!pc) G mxs rT pc et"
  defines [simp]: "step0 \<equiv> \<lambda>pc. eff (bs!pc) G pc et"

  shows
  "wt_method G C pTs rT mxs mxl bs et phi =
  (bs \<noteq> [] \<and>
   length phi = length bs \<and>
   check_bounded bs et \<and>
   check_types G mxs mxr (map OK phi) \<and>
   wt_start G C pTs mxl phi \<and>
   wt_app_eff r app0 step0 phi)"
  by (auto simp add: wt_method_def wt_app_eff_def wt_instr_def lesub_def
           dest: check_bounded_is_bounded boundedD)

lemma check_certD:
  "check_cert G mxs mxr n cert \<Longrightarrow> cert_ok cert n Err (OK None) (states G mxs mxr)"
  apply (unfold cert_ok_def check_cert_def check_types_def)
  apply (auto simp add: list_all_iff)
  done

lemma wt_lbv_wt_step:
  assumes wf:  "wf_prog wf_mb G"
  assumes lbv: "wt_lbv G C pTs rT mxs mxl et cert ins"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  defines [simp]: "mxr \<equiv> 1+length pTs+mxl"

  shows "\<exists>ts \<in> list (size ins) (states G mxs mxr).
            wt_step (JVMType.le G mxs mxr) Err (exec G mxs rT et ins) ts
          \<and> OK (Some ([],(OK (Class C))#((map OK pTs))@(replicate mxl Err))) <=_(JVMType.le G mxs mxr) ts!0"
proof -
  let ?step = "exec G mxs rT et ins"
  let ?r    = "JVMType.le G mxs mxr"
  let ?f    = "JVMType.sup G mxs mxr"
  let ?A    = "states G mxs mxr"

  have "semilat (JVMType.sl G mxs mxr)"
    by (rule semilat_JVM_slI, rule wf_prog_ws_prog, rule wf)
  hence "semilat (?A, ?r, ?f)" by (unfold sl_triple_conv)
  moreover
  have "top ?r Err"  by (simp add: JVM_le_unfold)
  moreover
  have "Err \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  have "bottom ?r (OK None)"
    by (simp add: JVM_le_unfold bottom_def)
  moreover
  have "OK None \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  from lbv
  have "bounded ?step (length ins)"
    by (clarsimp simp add: wt_lbv_def exec_def)
       (intro bounded_lift check_bounded_is_bounded)
  moreover
  from lbv
  have "cert_ok cert (length ins) Err (OK None) ?A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover
  from wf have "pres_type ?step (length ins) ?A" by (rule exec_pres_type)
  moreover
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"
  from lbv
  have "wtl_inst_list ins cert ?f ?r Err (OK None) ?step 0 ?start \<noteq> Err"
    by (simp add: wt_lbv_def lbvjvm_def)
  moreover
  from C pTs have "?start \<in> ?A"
    by (unfold JVM_states_unfold) (auto intro: list_appendI, force)
  moreover
  from lbv have "0 < length ins" by (simp add: wt_lbv_def)
  ultimately
  show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed

lemma wt_lbv_wt_method:
  assumes wf:  "wf_prog wf_mb G"
  assumes lbv: "wt_lbv G C pTs rT mxs mxl et cert ins"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  shows "\<exists>phi. wt_method G C pTs rT mxs mxl ins et phi"
proof -
  let ?mxr   = "1 + length pTs + mxl"
  let ?step  = "exec G mxs rT et ins"
  let ?r     = "JVMType.le G mxs ?mxr"
  let ?f     = "JVMType.sup G mxs ?mxr"
  let ?A     = "states G mxs ?mxr"
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"

  from lbv have l: "ins \<noteq> []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C pTs
  obtain phi where
    list:  "phi \<in> list (length ins) ?A" and
    step:  "wt_step ?r Err ?step phi" and
    start: "?start <=_?r phi!0"
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "length phi = length ins" by simp
  have "length (map ok_val phi) = length ins" by simp
  moreover
  from l have 0: "0 < length phi" by simp
  with step obtain phi0 where "phi!0 = OK phi0"
    by (unfold wt_step_def) blast
  with start 0
  have "wt_start G C pTs mxl (map ok_val phi)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def)
  moreover
  from lbv  have chk_bounded: "check_bounded ins et"
    by (simp add: wt_lbv_def)
  moreover {
    from list
    have "check_types G mxs ?mxr phi"
      by (simp add: check_types_def)
    also from step
    have [symmetric]: "map OK (map ok_val phi) = phi"
      by (auto intro!: nth_equalityI simp add: wt_step_def)
    finally have "check_types G mxs ?mxr (map OK (map ok_val phi))" .
  }
  moreover {
    let ?app = "\<lambda>pc. app (ins!pc) G mxs rT pc et"
    let ?eff = "\<lambda>pc. eff (ins!pc) G pc et"

    from chk_bounded
    have "bounded (err_step (length ins) ?app ?eff) (length ins)"
      by (blast dest: check_bounded_is_bounded boundedD intro: bounded_err_stepI)
    moreover
    from step
    have "wt_err_step (sup_state_opt G) ?step phi"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately
    have "wt_app_eff (sup_state_opt G) ?app ?eff (map ok_val phi)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def)
  }
  ultimately
  have "wt_method G C pTs rT mxs mxl ins et (map ok_val phi)"
    by - (rule wt_method_def2 [THEN iffD2], simp)
  thus ?thesis ..
qed

lemma wt_method_wt_lbv:
  assumes wf:  "wf_prog wf_mb G"
  assumes wt:  "wt_method G C pTs rT mxs mxl ins et phi"
  assumes C:   "is_class G C"
  assumes pTs: "set pTs \<subseteq> types G"

  defines [simp]: "cert \<equiv> mk_cert G mxs rT et ins phi"

  shows "wt_lbv G C pTs rT mxs mxl et cert ins"
proof -
  let ?mxr  = "1 + length pTs + mxl"
  let ?step = "exec G mxs rT et ins"
  let ?app  = "\<lambda>pc. app (ins!pc) G mxs rT pc et"
  let ?eff  = "\<lambda>pc. eff (ins!pc) G pc et"
  let ?r    = "JVMType.le G mxs ?mxr"
  let ?f    = "JVMType.sup G mxs ?mxr"
  let ?A    = "states G mxs ?mxr"
  let ?phi  = "map OK phi"
  let ?cert = "make_cert ?step ?phi (OK None)"

  from wt have
    0:          "0 < length ins" and
    length:     "length ins = length ?phi" and
    ck_bounded: "check_bounded ins et" and
    ck_types:   "check_types G mxs ?mxr ?phi" and
    wt_start:   "wt_start G C pTs mxl phi" and
    app_eff:    "wt_app_eff (sup_state_opt G) ?app ?eff phi"
    by (simp_all add: wt_method_def2)

  have "semilat (JVMType.sl G mxs ?mxr)"
    by (rule semilat_JVM_slI) (rule wf_prog_ws_prog [OF wf])
  hence "semilat (?A, ?r, ?f)" by (unfold sl_triple_conv)
  moreover
  have "top ?r Err"  by (simp add: JVM_le_unfold)
  moreover
  have "Err \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  have "bottom ?r (OK None)"
    by (simp add: JVM_le_unfold bottom_def)
  moreover
  have "OK None \<in> ?A" by (simp add: JVM_states_unfold)
  moreover
  from ck_bounded
  have bounded: "bounded ?step (length ins)"
    by (clarsimp simp add: exec_def)
       (intro bounded_lift check_bounded_is_bounded)
  with wf
  have "mono ?r ?step (length ins) ?A"
    by (rule wf_prog_ws_prog [THEN exec_mono])
  hence "mono ?r ?step (length ?phi) ?A" by (simp add: length)
  moreover
  from wf have "pres_type ?step (length ins) ?A" by (rule exec_pres_type)
  hence "pres_type ?step (length ?phi) ?A" by (simp add: length)
  moreover
  from ck_types
  have "set ?phi \<subseteq> ?A" by (simp add: check_types_def)
  hence "\<forall>pc. pc < length ?phi \<longrightarrow> ?phi!pc \<in> ?A \<and> ?phi!pc \<noteq> Err" by auto
  moreover
  from bounded
  have "bounded (exec G mxs rT et ins) (length ?phi)" by (simp add: length)
  moreover
  have "OK None \<noteq> Err" by simp
  moreover
  from bounded length app_eff
  have "wt_err_step (sup_state_opt G) ?step ?phi"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def)
  hence "wt_step ?r Err ?step ?phi"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  let ?start = "OK (Some ([],(OK (Class C))#(map OK pTs)@(replicate mxl Err)))"
  from 0 length have "0 < length phi" by auto
  hence "?phi!0 = OK (phi!0)" by simp
  with wt_start have "?start <=_?r ?phi!0"
    by (clarsimp simp add: wt_start_def lesub_def JVM_le_Err_conv)
  moreover
  from C pTs have "?start \<in> ?A"
    by (unfold JVM_states_unfold) (auto intro: list_appendI, force)
  moreover
  have "?start \<noteq> Err" by simp
  moreover
  note length
  ultimately
  have "wtl_inst_list ins ?cert ?f ?r Err (OK None) ?step 0 ?start \<noteq> Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover
  from 0 length have "phi \<noteq> []" by auto
  moreover
  from ck_types
  have "check_types G mxs ?mxr ?cert"
    by (auto simp add: make_cert_def check_types_def JVM_states_unfold)
  moreover
  note ck_bounded 0 length
  ultimately
  show ?thesis
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def
      check_cert_def make_cert_def nth_append)
qed

theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv G Cert \<Longrightarrow> \<exists>Phi. wt_jvm_prog G Phi"
proof -
  let ?Phi = "\<lambda>C sig. let (C,rT,(maxs,maxl,ins,et)) = the (method (G,C) sig) in
              SOME phi. wt_method G C (snd sig) rT maxs maxl ins et phi"

  assume "wt_jvm_prog_lbv G Cert"
  hence "wt_jvm_prog G ?Phi"
    apply (unfold wt_jvm_prog_def wt_jvm_prog_lbv_def)
    apply (erule jvm_prog_lift)
    apply (auto dest: wt_lbv_wt_method intro: someI)
    done
  thus ?thesis by blast
qed

theorem jvm_lbv_complete:
  "wt_jvm_prog G Phi \<Longrightarrow> wt_jvm_prog_lbv G (prg_cert G Phi)"
  apply (unfold wt_jvm_prog_def wt_jvm_prog_lbv_def)
  apply (erule jvm_prog_lift)
  apply (auto simp add: prg_cert_def intro: wt_method_wt_lbv)
  done

end


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

  Project: Development of Security Protocols by Refinement

  Module:   Key_establish/m1_keydist_iirn.thy (Isabelle/HOL 2016-1)
  ID:       $Id: m1_keydist_inrn.thy 133854 2017-03-20 17:53:50Z csprenge $
  Author:   Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Key distribution protocols
  Level 1, 1st refinement: Abstract server-based key transport protocol with
  initiator and responder roles. Provides non-injective server authentication
  to the initiator and responder.

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

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

section \<open>Abstract (n/n)-authenticated key transport (L1)\<close>

theory m1_keydist_inrn imports m1_keydist "../Refinement/a0i_agree"
begin

text \<open>We add authentication for the initiator and responder to the basic
server-based key transport protocol:
\begin{enumerate}
\item the initiator injectively agrees with the server on the key and some
additional data
\item the responder non-injectively agrees with the server on the key and
some additional data.
\end{enumerate}
The "additional data" is a parameter of this model.\<close>

declare option.split [split]
(* declare option.split_asm [split] *)

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

text \<open>The state type remains the same, but in this model we will record
nonces and timestamps in the run frame.\<close>

type_synonym m1a_state = "m1x_state"
type_synonym m1a_obs = "m1x_obs"

type_synonym 'x m1a_pred = "'x m1x_pred"
type_synonym 'x m1a_trans = "'x m1x_trans"

text \<open>We need some parameters regarding the list of freshness values
stored by the server. These should be defined in further refinements.\<close>

consts
  is_len :: "nat"   \<comment> \<open>num of agreeing list elements for initiator-server\<close>
  rs_len :: "nat"   \<comment> \<open>num of agreeing list elements for responder-server\<close>

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

definition         \<comment> \<open>by @{term "A"}, refines @{term "m1x_step1"}\<close>
  m1a_step1 :: "[rid_t, agent, agent] \<Rightarrow> 'x m1r_trans"
where
  "m1a_step1 \<equiv> m1x_step1"

definition       \<comment> \<open>by @{term "B"}, refines @{term "m1x_step2"}\<close>
  m1a_step2 :: "[rid_t, agent, agent] \<Rightarrow> 'x m1r_trans"
where
  "m1a_step2 \<equiv> m1x_step2"

definition       \<comment> \<open>by @{term "Server"}, refines @{term m1x_step3}\<close>
  m1a_step3 :: "[rid_t, agent, agent, key, atom list] \<Rightarrow> 'x m1r_trans"
where
  "m1a_step3 Rs A B Kab al \<equiv> {(s, s1).
     \<comment> \<open>guards:\<close>
     Rs \<notin> dom (runs s) \<and>                 \<comment> \<open>fresh run id\<close>
     Kab = sesK (Rs$sk) \<and>                 \<comment> \<open>generate session key\<close>

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

definition         \<comment> \<open>by @{text "A"}, refines @{term m1x_step4}\<close>
  m1a_step4 :: "[rid_t, agent, agent, key, atom list] \<Rightarrow> 'x m1a_trans"
where
  "m1a_step4 Ra A B Kab nla \<equiv> {(s, s').
     \<comment> \<open>guards:\<close>
     runs s Ra = Some (Init, [A, B], []) \<and>
     (Kab \<notin> leak s \<longrightarrow> (Kab, A) \<in> azC (runs s)) \<and>      \<comment> \<open>authorization guard\<close>

     \<comment> \<open>new guard for non-injective agreement with server on \<open>(Kab, B, isl)\<close>,\<close>
     \<comment> \<open>where \<open>isl = take is_len nla\<close>\<close>
     (A \<notin> bad \<longrightarrow> (\<exists>Rs. Kab = sesK (Rs$sk) \<and>
        runs s Rs = Some (Serv, [A, B], take is_len nla))) \<and>

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

definition         \<comment> \<open>by @{term "B"}, refines @{term m1x_step5}\<close>
  m1a_step5 :: "[rid_t, agent, agent, key, atom list] \<Rightarrow> 'x m1a_trans"
where
  "m1a_step5 Rb A B Kab nlb \<equiv> {(s, s1).
     \<comment> \<open>guards:\<close>
     runs s Rb = Some (Resp, [A, B], []) \<and>
     (Kab \<notin> leak s \<longrightarrow> (Kab, B) \<in> azC (runs s)) \<and>         \<comment> \<open>authorization guard\<close>

     \<comment> \<open>guard for non-injective agreement with server on \<open>(Kab, A, rsl)\<close>\<close>
     \<comment> \<open>where \<open>rsl = take rs_len nlb\<close>\<close>
     (B \<notin> bad \<longrightarrow> (\<exists>Rs. Kab = sesK (Rs$sk) \<and>
        runs s Rs = Some (Serv, [A, B], take rs_len nlb))) \<and>

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

definition     \<comment> \<open>by attacker, refines @{term m1x_leak}\<close>
  m1a_leak :: "rid_t \<Rightarrow> 'x m1x_trans"
where
  "m1a_leak = m1x_leak"

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

definition
  m1a_init :: "m1a_state set"
where
  "m1a_init \<equiv> m1x_init"

definition
  m1a_trans :: "'x m1a_trans" where
  "m1a_trans \<equiv> (\<Union>A B Ra Rb Rs Kab nls nla nlb.
     m1a_step1 Ra A B \<union>
     m1a_step2 Rb A B \<union>
     m1a_step3 Rs A B Kab nls \<union>
     m1a_step4 Ra A B Kab nla \<union>
     m1a_step5 Rb A B Kab nlb \<union>
     m1a_leak Rs \<union>
     Id
  )"

definition
  m1a :: "(m1a_state, m1a_obs) spec" where
  "m1a \<equiv> \<lparr>
     init = m1a_init,
     trans = m1a_trans,
     obs = id
  \<rparr>"

lemma init_m1a: "init m1a = m1a_init"
by (simp add: m1a_def)

lemma trans_m1a: "trans m1a = m1a_trans"
by (simp add: m1a_def)

lemma obs_m1a [simp]: "obs m1a = id"
by (simp add: m1a_def)

lemmas m1a_loc_defs =
  m1a_def m1a_init_def m1a_trans_def
  m1a_step1_def m1a_step2_def m1a_step3_def m1a_step4_def m1a_step5_def
  m1a_leak_def

lemmas m1a_defs = m1a_loc_defs m1x_defs

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

subsubsection \<open>inv0: Finite domain\<close>
(*inv**************************************************************************)

text \<open>There are only finitely many runs. This is needed to establish
the responder/initiator agreement.\<close>

definition
  m1a_inv0_fin :: "'x m1r_pred"
where
  "m1a_inv0_fin \<equiv> {s. finite (dom (runs s))}"

lemmas m1a_inv0_finI = m1a_inv0_fin_def [THEN setc_def_to_intro, rule_format]
lemmas m1a_inv0_finE [elim] = m1a_inv0_fin_def [THEN setc_def_to_elim, rule_format]
lemmas m1a_inv0_finD = m1a_inv0_fin_def [THEN setc_def_to_dest, rule_format]

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

lemma PO_m1a_inv0_fin_init [iff]:
  "init m1a \<subseteq> m1a_inv0_fin"
by (auto simp add: m1a_defs intro!: m1a_inv0_finI)

lemma PO_m1a_inv0_fin [iff]: "reach m1a \<subseteq> m1a_inv0_fin"
by (rule inv_rule_incr, auto del: subsetI)

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

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

text \<open>Define run abstraction.\<close>

fun
  rm1x1a :: "role_t \<Rightarrow> atom list \<Rightarrow> atom list"
where
  "rm1x1a Init = take 1"         \<comment> \<open>take \<open>Kab\<close> from \<open>Kab # nla\<close>\<close>
| "rm1x1a Resp = take 1"         \<comment> \<open>take \<open>Kab\<close> from \<open>Kab # nlb\<close>\<close>
| "rm1x1a Serv = take 0"         \<comment> \<open>drop all from \<open>nls\<close>\<close>

abbreviation
  runs1x1a :: "runs_t \<Rightarrow> runs_t" where
  "runs1x1a \<equiv> map_runs rm1x1a"

text \<open>med1x1: The mediator function maps a concrete observation to an
abstract one.\<close>

definition
  med1x1a :: "m1a_obs \<Rightarrow> m1x_obs" where
  "med1x1a t \<equiv> \<lparr> runs = runs1x1a (runs t), leak = leak t \<rparr>"

text \<open>R1x1a: The simulation relation is defined in terms of the mediator
function.\<close>

definition
  R1x1a :: "(m1x_state \<times> m1a_state) set" where
  "R1x1a \<equiv> {(s, t). s = med1x1a t}"

lemmas R1x1a_defs =
  R1x1a_def med1x1a_def

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

lemma PO_m1a_step1_refines_m1x_step1:
  "{R1x1a}
     (m1x_step1 Ra A B), (m1a_step1 Ra A B)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs)

lemma PO_m1a_step2_refines_m1x_step2:
  "{R1x1a}
     (m1x_step2 Rb A B), (m1a_step2 Rb A B)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs)

lemma PO_m1a_step3_refines_m1x_step3:
  "{R1x1a}
     (m1x_step3 Rs A B Kab), (m1a_step3 Rs A B Kab nls)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs)

lemma PO_m1a_step4_refines_m1x_step4:
  "{R1x1a}
     (m1x_step4 Ra A B Kab), (m1a_step4 Ra A B Kab nla)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs map_runs_def)

lemma PO_m1a_step5_refines_m1x_step5:
  "{R1x1a}
     (m1x_step5 Rb A B Kab), (m1a_step5 Rb A B Kab nlb)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs map_runs_def)

lemma PO_m1a_leak_refines_m1x_leak:
  "{R1x1a}
     (m1x_leak Rs), (m1a_leak Rs)
   {> R1x1a}"
by (auto simp add: PO_rhoare_defs R1x1a_defs m1a_defs map_runs_def)

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

lemmas PO_m1a_trans_refines_m1x_trans =
  PO_m1a_step1_refines_m1x_step1 PO_m1a_step2_refines_m1x_step2
  PO_m1a_step3_refines_m1x_step3 PO_m1a_step4_refines_m1x_step4
  PO_m1a_step5_refines_m1x_step5 PO_m1a_leak_refines_m1x_leak

lemma PO_m1a_refines_init_m1x [iff]:
  "init m1a \<subseteq>  R1x1a``(init m1x)"
by (auto simp add: R1x1a_defs m1a_defs)

lemma PO_m1a_refines_trans_m1x [iff]:
  "{R1x1a}
     (trans m1x), (trans m1a)
   {> R1x1a}"
apply (auto simp add: m1a_def m1a_trans_def m1x_def m1x_trans_def
         intro!: PO_m1a_trans_refines_m1x_trans)
apply (force intro!: PO_m1a_trans_refines_m1x_trans)+
done

text \<open>Observation consistency.\<close>

lemma obs_consistent_med1x1a [iff]:
  "obs_consistent R1x1a med1x1a m1x m1a"
by (auto simp add: obs_consistent_def R1x1a_def m1a_defs)

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

lemma PO_m1a_refines_m1x [iff]:
  "refines R1x1a med1x1a m1x m1a"
by (rule Refinement_basic) (auto del: subsetI)

lemma  m1a_implements_m1x [iff]: "implements med1x1a m1x m1a"
by (rule refinement_soundness) (fast)

(******************************************************************************)
subsection \<open>Refinement of \<open>a0n\<close> for initiator/server\<close>
(******************************************************************************)

text \<open>For the initiator, we get an non-injective agreement with the server on
the session key, the responder name, and the atom list @{term "isl"}.\<close>

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

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

type_synonym
  issig = "key \<times> agent \<times> atom list"

abbreviation
  is_commit :: "[runs_t, agent, agent, key, atom list] \<Rightarrow> rid_t set"
where
  "is_commit runz A B Kab sl \<equiv> {Ra. \<exists>nla.
     runz Ra = Some (Init, [A, B], aKey Kab # nla) \<and> take is_len nla = sl
  }"

fun
  is_runs2sigs :: "runs_t \<Rightarrow> issig signal \<Rightarrow> nat"
where
  "is_runs2sigs runz (Running [A, Sv] (Kab, B, sl)) =
     (if \<exists>Rs nls. Kab = sesK (Rs$sk) \<and>
         runz Rs = Some (Serv, [A, B], nls) \<and> take is_len nls = sl
      then 1 else 0)"

| "is_runs2sigs runz (Commit [A, Sv] (Kab, B, sl)) =
     card (is_commit runz A B Kab sl)"

| "is_runs2sigs runz _ = 0"

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

definition
  med_a0m1a_is :: "m1a_obs \<Rightarrow> issig a0i_obs" where
  "med_a0m1a_is o1 \<equiv> \<lparr> signals = is_runs2sigs (runs o1), corrupted = {} \<rparr>"

definition
  R_a0m1a_is :: "(issig a0i_state \<times> m1a_state) set" where
  "R_a0m1a_is \<equiv> {(s, t). signals s = is_runs2sigs (runs t) \<and> corrupted s = {} }"

lemmas R_a0m1a_is_defs = R_a0m1a_is_def med_a0m1a_is_def

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

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

lemma is_commit_finite [simp, intro]:
  "finite (dom runz) \<Longrightarrow> finite (is_commit runz A B Kab nls)"
by (auto intro: finite_subset dest: dom_lemmas)

text \<open>Update lemmas\<close>

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

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

lemma is_runs2sigs_upd_serv [simp]:
  "\<lbrakk> Rs \<notin> dom runz \<rbrakk>
  \<Longrightarrow> is_runs2sigs (runz(Rs \<mapsto> (Serv, [A, B], nls))) =
     (is_runs2sigs runz)(Running [A, Sv] (sesK (Rs$sk), B, take is_len nls) := 1)"
by (rule ext, erule rev_mp)
   (rule is_runs2sigs.induct, auto dest: dom_lemmas)

lemma is_runs2sigs_upd_init_some [simp]:
  "\<lbrakk> runz Ra = Some (Init, [A, B], []); finite (dom runz);
     ils = take is_len nla \<rbrakk>
  \<Longrightarrow> is_runs2sigs (runz(Ra \<mapsto> (Init, [A, B], aKey Kab # nla))) =
     (is_runs2sigs runz)(
        Commit [A, Sv] (Kab, B, ils) :=
          Suc (card (is_commit runz A B Kab ils)))"
apply (rule ext, erule rev_mp, erule rev_mp, erule rev_mp)
apply (rename_tac s)
apply (rule_tac ?a0.0=runz and ?a1.0=s in is_runs2sigs.induct, auto)
\<comment> \<open>1 subgoal\<close>
apply (rename_tac runz)
apply (rule_tac s="card (insert Ra (is_commit runz A B Kab (take is_len nla)))"
      in trans, fast, auto)
done

lemma is_runs2sigs_upd_resp_some [simp]:
  "\<lbrakk> runz Rb = Some (Resp, [A, B], []) \<rbrakk>
  \<Longrightarrow> is_runs2sigs (runz(Rb \<mapsto> (Resp, [A, B], aKey Kab # nlb))) =
     is_runs2sigs runz"
by (rule ext, erule rev_mp)
   (rule is_runs2sigs.induct, auto dest: dom_lemmas)

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

lemma PO_m1a_step1_refines_a0_is_skip:
  "{R_a0m1a_is}
     Id, (m1a_step1 Ra A B)
   {> R_a0m1a_is}"
by (auto simp add: PO_rhoare_defs R_a0m1a_is_defs m1a_defs)

lemma PO_m1a_step2_refines_a0_is_skip:
  "{R_a0m1a_is}
     Id, (m1a_step2 Rb A B)
   {> R_a0m1a_is}"
by (auto simp add: PO_rhoare_defs R_a0m1a_is_defs m1a_defs)

lemma PO_m1a_step3_refines_a0_is_running:
  "{R_a0m1a_is}
     (a0n_running [A, Sv] (Kab, B, take is_len nls)),
     (m1a_step3 Rs A B Kab nls)
   {> R_a0m1a_is}"
by (auto simp add: PO_rhoare_defs R_a0m1a_is_defs a0i_defs m1a_defs
         dest: dom_lemmas)

lemma PO_m1a_step4_refines_a0_is_commit:
  "{R_a0m1a_is \<inter> UNIV \<times> m1a_inv0_fin}
     (a0n_commit [A, Sv] (Kab, B, take is_len nla)),
     (m1a_step4 Ra A B Kab nla)
   {> R_a0m1a_is}"
by (simp add: PO_rhoare_defs R_a0m1a_is_defs a0i_defs m1a_defs, safe, auto)

lemma PO_m1a_step5_refines_a0_is_skip:
  "{R_a0m1a_is}
     Id, (m1a_step5 Rb A B Kab nlb)
   {> R_a0m1a_is}"
by (simp add: PO_rhoare_defs R_a0m1a_is_defs m1a_defs, safe, auto)

lemma PO_m1a_leak_refines_a0_is_skip:
  "{R_a0m1a_is}
     Id, (m1a_leak Rs)
   {> R_a0m1a_is}"
by (simp add: PO_rhoare_defs R_a0m1a_is_defs m1a_defs, safe, auto)

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

lemmas PO_m1a_trans_refines_a0_is_trans =
  PO_m1a_step1_refines_a0_is_skip PO_m1a_step2_refines_a0_is_skip
  PO_m1a_step3_refines_a0_is_running PO_m1a_step4_refines_a0_is_commit
  PO_m1a_step5_refines_a0_is_skip PO_m1a_leak_refines_a0_is_skip

lemma PO_m1a_refines_init_a0_is [iff]:
  "init m1a \<subseteq>  R_a0m1a_is``(init a0n)"
by (auto simp add: R_a0m1a_is_defs a0n_defs m1a_defs)

lemma PO_m1a_refines_trans_a0_is [iff]:
  "{R_a0m1a_is \<inter> UNIV \<times> m1a_inv0_fin}
     (trans a0n), (trans m1a)
   {> R_a0m1a_is}"
by (auto simp add: m1a_def m1a_trans_def a0n_def a0n_trans_def
         intro!: PO_m1a_trans_refines_a0_is_trans)

lemma obs_consistent_med_a0m1a_is [iff]:
  "obs_consistent R_a0m1a_is med_a0m1a_is a0n m1a"
by (auto simp add: obs_consistent_def R_a0m1a_is_def med_a0m1a_is_def
                   a0n_def m1a_def)

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

lemma PO_m1a_refines_a0_is [iff]:
  "refines (R_a0m1a_is \<inter> UNIV \<times> m1a_inv0_fin) med_a0m1a_is a0n m1a"
by (rule Refinement_using_invariants) (auto del: subsetI)

lemma  m1a_implements_a0_is: "implements med_a0m1a_is a0n m1a"
by (rule refinement_soundness) (fast)

(******************************************************************************)
subsection \<open>Refinement of \<open>a0n\<close> for responder/server\<close>
(******************************************************************************)

text \<open>For the responder, we get a non-injective agreement with the server on
the session key, the initiator's name, and additional data.\<close>

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

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

type_synonym
  rssig = "key \<times> agent \<times> atom list"

abbreviation
  rs_commit :: "[runs_t, agent, agent, key, atom list] \<Rightarrow> rid_t set"
where
  "rs_commit runz A B Kab rsl \<equiv> {Rb. \<exists>nlb.
     runz Rb = Some (Resp, [A, B], aKey Kab # nlb) \<and> take rs_len nlb = rsl
  }"

fun
  rs_runs2sigs :: "runs_t \<Rightarrow> rssig signal \<Rightarrow> nat"
where
  "rs_runs2sigs runz (Running [B, Sv] (Kab, A, rsl)) =
     (if \<exists>Rs nls. Kab = sesK (Rs$sk) \<and>
         runz Rs = Some (Serv, [A, B], nls) \<and> take rs_len nls = rsl
      then 1 else 0)"

| "rs_runs2sigs runz (Commit [B, Sv] (Kab, A, rsl)) =
     card (rs_commit runz A B Kab rsl)"

| "rs_runs2sigs runz _ = 0"

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

definition
  med_a0m1a_rs :: "m1a_obs \<Rightarrow> rssig a0n_obs" where
  "med_a0m1a_rs o1 \<equiv> \<lparr> signals = rs_runs2sigs (runs o1), corrupted = {} \<rparr>"

definition
  R_a0m1a_rs :: "(rssig a0n_state \<times> m1a_state) set" where
  "R_a0m1a_rs \<equiv> {(s, t). signals s = rs_runs2sigs (runs t) \<and> corrupted s = {} }"

lemmas R_a0m1a_rs_defs = R_a0m1a_rs_def med_a0m1a_rs_def

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

text \<open>Other lemmas\<close>

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

lemma rs_commit_finite [simp, intro]:
  "finite (dom runz) \<Longrightarrow> finite (rs_commit runz A B Kab nls)"
by (auto intro: finite_subset dest: dom_lemmas)

text \<open>Update lemmas\<close>

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

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

lemma rs_runs2sigs_upd_serv [simp]:
  "\<lbrakk> Rs \<notin> dom runz \<rbrakk>
  \<Longrightarrow> rs_runs2sigs (runz(Rs \<mapsto> (Serv, [A, B], nls))) =
     (rs_runs2sigs runz)(Running [B, Sv] (sesK (Rs$sk), A, take rs_len nls) := 1)"
by (rule ext, erule rev_mp)
   (rule rs_runs2sigs.induct, auto dest: dom_lemmas)

lemma rs_runs2sigs_upd_init_some [simp]:
  "\<lbrakk> runz Ra = Some (Init, [A, B], []) \<rbrakk>
  \<Longrightarrow> rs_runs2sigs (runz(Ra \<mapsto> (Init, [A, B], aKey Kab # nl))) =
     rs_runs2sigs runz"
by (rule ext, erule rev_mp)
   (rule rs_runs2sigs.induct, auto dest: dom_lemmas)

lemma rs_runs2sigs_upd_resp_some [simp]:
  "\<lbrakk> runz Rb = Some (Resp, [A, B], []); finite (dom runz);
     rsl = take rs_len nlb \<rbrakk>
 \<Longrightarrow> rs_runs2sigs (runz(Rb \<mapsto> (Resp, [A, B], aKey Kab # nlb))) =
   (rs_runs2sigs runz)(
      Commit [B, Sv] (Kab, A, rsl) := Suc (card (rs_commit runz A B Kab rsl)))"
apply (rule ext, erule rev_mp, erule rev_mp, erule rev_mp)
apply (rule rs_runs2sigs.induct, auto dest: dom_lemmas)
\<comment> \<open>1 subgoal\<close>
apply (rename_tac runz)
apply (rule_tac s="card (insert Rb (rs_commit runz A B Kab (take rs_len nlb)))"
       in trans, fast, auto)
done

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

lemma PO_m1a_step1_refines_a0_rs_skip:
  "{R_a0m1a_rs}
     Id, (m1a_step1 Ra A B)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs m1a_defs)

lemma PO_m1a_step2_refines_a0_rs_skip:
  "{R_a0m1a_rs}
     Id, (m1a_step2 Rb A B)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs m1a_defs)

lemma PO_m1a_step3_refines_a0_rs_running:
  "{R_a0m1a_rs}
     (a0n_running [B, Sv] (Kab, A, take rs_len nls)),
     (m1a_step3 Rs A B Kab nls)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs a0n_defs m1a_defs
         dest: dom_lemmas)

lemma PO_m1a_step4_refines_a0_rs_skip:
  "{R_a0m1a_rs}
     Id, (m1a_step4 Ra A B Kab nla)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs m1a_defs)

lemma PO_m1a_step5_refines_a0_rs_commit:
  "{R_a0m1a_rs \<inter> UNIV \<times> m1a_inv0_fin}
     (a0n_commit [B, Sv] (Kab, A, take rs_len nlb)),
     (m1a_step5 Rb A B Kab nlb)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs a0n_defs m1a_defs)

lemma PO_m1a_leak_refines_a0_rs_skip:
  "{R_a0m1a_rs}
     Id, (m1a_leak Rs)
   {> R_a0m1a_rs}"
by (auto simp add: PO_rhoare_defs R_a0m1a_rs_defs a0i_defs m1a_defs)

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

lemmas PO_m1a_trans_refines_a0_rs_trans =
  PO_m1a_step1_refines_a0_rs_skip PO_m1a_step2_refines_a0_rs_skip
  PO_m1a_step3_refines_a0_rs_running PO_m1a_step4_refines_a0_rs_skip
  PO_m1a_step5_refines_a0_rs_commit PO_m1a_leak_refines_a0_rs_skip

lemma PO_m1a_refines_init_ra0n [iff]:
  "init m1a \<subseteq>  R_a0m1a_rs``(init a0n)"
by (auto simp add: R_a0m1a_rs_defs a0n_defs m1a_defs)

lemma PO_m1a_refines_trans_ra0n [iff]:
  "{R_a0m1a_rs \<inter> UNIV \<times> m1a_inv0_fin}
     (trans a0n), (trans m1a)
   {> R_a0m1a_rs}"
by (auto simp add: m1a_def m1a_trans_def a0n_def a0n_trans_def
         intro!: PO_m1a_trans_refines_a0_rs_trans)

lemma obs_consistent_med_a0m1a_rs [iff]:
  "obs_consistent (R_a0m1a_rs \<inter> UNIV \<times> m1a_inv0_fin) med_a0m1a_rs a0n m1a"
by (auto simp add: obs_consistent_def R_a0m1a_rs_def med_a0m1a_rs_def
                   a0n_def m1a_def)

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

lemma PO_m1a_refines_a0_rs [iff]:
  "refines (R_a0m1a_rs \<inter> UNIV \<times> m1a_inv0_fin) med_a0m1a_rs a0n m1a"
by (rule Refinement_using_invariants) (auto)

lemma  m1a_implements_ra0n: "implements med_a0m1a_rs a0n m1a"
by (rule refinement_soundness) (fast)

end


(*<*)
theory KBPsAlg
imports KBPsAuto DFS MapOps
begin
(*>*)

subsection\<open>An algorithm for automata synthesis\<close>

text\<open>

\label{sec:kbps-alg}

We now show how to construct the automaton defined by @{term
"mkAutoSim"} (\S\ref{sec:kbps-automata-synthesis-alg}) using the DFS
of \S\ref{sec:dfs}.

From here on we assume that the environment consists of only a finite
set of states:

\<close>

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

text_raw\<open>
\begin{figure}[p]
\begin{isabellebody}%
\<close>
locale Algorithm =
  FiniteEnvironment jkbp envInit envAction envTrans envVal envObs
+ AlgSimIncrEnvironment jkbp envInit envAction envTrans envVal jview envObs
               jviewInit jviewIncr
               simf simRels simVal simAbs simObs simInit simTrans simAction
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "('s :: finite) list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tobs) JointView"

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

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

    and simAbs :: "'rep \<Rightarrow> 'ss set"

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

+ fixes aOps :: "('ma, 'rep, 'aAct list) MapOps"
    and tOps :: "('mt, 'rep \<times> 'obs, 'rep) MapOps"

  assumes aOps: "MapOps simAbs jkbpSEC aOps"
      and tOps: "MapOps (\<lambda>k. (simAbs (fst k), snd k)) (jkbpSEC \<times> UNIV) tOps"
text_raw\<open>
  \end{isabellebody}%
  \caption{The \<open>Algorithm\<close> locale.}
  \label{fig:kbps-alg-alg-locale}
\end{figure}
\<close>

text (in Algorithm) \<open>

The @{term "Algorithm"} locale, shown in
Figure~\ref{fig:kbps-alg-alg-locale}, also extends the @{term
"AlgSimIncrEnvironment"} locale with a pair of finite map operations:
@{term "aOps"} is used to map automata states to lists of actions, and
@{term "tOps"} handles simulated transitions. In both cases the maps
are only required to work on the abstract domain of simulated
canonical traces. Note also that the space of simulated equivalence
classes of type @{typ "'ss"} must be finite, but there is no
restriction on the representation type @{typ "'rep"}.

We develop the algorithm for a single, fixed agent, which requires us
to define a new locale @{term "AlgorithmForAgent"} that extends \<open>Algorithm\<close> with an extra parameter designating the agent:

\<close>

locale AlgorithmForAgent =
  Algorithm jkbp envInit envAction envTrans envVal jview envObs
            jviewInit jviewIncr
            simf simRels simVal simAbs simObs simInit simTrans simAction
            aOps tOps(*<*)
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "('s :: finite) list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
    and jview :: "('a, 's, 'tobs) JointView"

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

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

    and simAbs :: "'rep \<Rightarrow> 'ss set"

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

    and aOps :: "('ma, 'rep, 'aAct list) MapOps"
    and tOps :: "('mt, 'rep \<times> 'obs, 'rep) MapOps"
(*>*)

  \<comment> \<open>...\<close>
+ fixes a :: "'a"

subsubsection\<open>DFS operations\<close>

text\<open>

We represent the automaton under construction using a record:

\<close>

record ('ma, 'mt) AlgState =
  aActs :: "'ma"
  aTrans :: "'mt"

context AlgorithmForAgent
begin

text\<open>

We instantiate the DFS theory with the following functions.

A node is an equivalence class of represented simulated traces.

\<close>

definition k_isNode :: "'rep \<Rightarrow> bool" where
  "k_isNode ec \<equiv> simAbs ec \<in> sim_equiv_class a ` jkbpC"

text\<open>

The successors of a node are those produced by the simulated
transition function.

\<close>

abbreviation k_succs :: "'rep \<Rightarrow> 'rep list" where
  "k_succs \<equiv> simTrans a"

text\<open>

The initial automaton has no transitions and no actions.

\<close>

definition k_empt :: "('ma, 'mt) AlgState" where
  "k_empt \<equiv> \<lparr> aActs = empty aOps, aTrans = empty tOps \<rparr>"

text\<open>

We use the domain of the action map to track the set of nodes the DFS
has visited.

\<close>

definition k_memb :: "'rep \<Rightarrow> ('ma, 'mt) AlgState \<Rightarrow> bool" where
  "k_memb s A \<equiv> isSome (lookup aOps (aActs A) s)"

text\<open>

We integrate a new equivalence class into the automaton by updating
the action and transition maps:

\<close>

definition actsUpdate :: "'rep \<Rightarrow> ('ma, 'mt) AlgState \<Rightarrow> 'ma" where
  "actsUpdate ec A \<equiv> update aOps ec (simAction a ec) (aActs A)"

definition transUpdate :: "'rep \<Rightarrow> 'rep \<Rightarrow> 'mt \<Rightarrow> 'mt" where
  "transUpdate ec ec' at \<equiv> update tOps (ec, simObs a ec') ec' at"

definition k_ins :: "'rep \<Rightarrow> ('ma, 'mt) AlgState \<Rightarrow> ('ma, 'mt) AlgState" where
  "k_ins ec A \<equiv> \<lparr> aActs = actsUpdate ec A,
                   aTrans = foldr (transUpdate ec) (k_succs ec) (aTrans A) \<rparr>"

text\<open>

The required properties are straightforward to show.

\<close>

(*<*)

lemma k_isNode_cong:
  "simAbs ec' = simAbs ec \<Longrightarrow> k_isNode ec' \<longleftrightarrow> k_isNode ec"
  unfolding k_isNode_def by simp

lemma alg_MapOps_empty[simp]:
  "k_isNode ec \<Longrightarrow> lookup aOps (empty aOps) ec = None"
  "k_isNode (fst k) \<Longrightarrow> lookup tOps (empty tOps) k = None"
  unfolding k_isNode_def
  using MapOps_emptyD[OF _ aOps] MapOps_emptyD[OF _ tOps] by blast+

lemma alg_aOps_lookup_update[simp]:
  "\<lbrakk> k_isNode ec; k_isNode ec' \<rbrakk> \<Longrightarrow> lookup aOps (update aOps ec e M) ec' = (if simAbs ec' = simAbs ec then Some e else lookup aOps M ec')"
  unfolding k_isNode_def
  using MapOps_lookup_updateD[OF _ _ aOps] by blast

lemma alg_tOps_lookup_update[simp]:
  "\<lbrakk> k_isNode (fst k); k_isNode (fst k') \<rbrakk> \<Longrightarrow> lookup tOps (update tOps k e M) k' = (if (simAbs (fst k'), snd k') = (simAbs (fst k), snd k) then Some e else lookup tOps M k')"
  unfolding k_isNode_def
  using MapOps_lookup_updateD[OF _ _ tOps] by blast

lemma k_succs_is_node[intro, simp]:
  assumes x: "k_isNode x"
  shows "list_all k_isNode (k_succs x)"
proof -
  from x obtain t
    where tC: "t \<in> jkbpC"
      and sx: "simAbs x = sim_equiv_class a t"
    unfolding k_isNode_def by blast
  have F: "\<And>y. y \<in> set (k_succs x) \<Longrightarrow> simAbs y \<in> simAbs ` set (k_succs x)" by simp
  show ?thesis
    using simTrans[rule_format, where a=a and t=t] tC sx
    unfolding k_isNode_def [abs_def]
    apply (auto iff: list_all_iff)
    apply (frule F)
    apply (auto)
    done
qed

lemma k_memb_empt[simp]:
  "k_isNode x \<Longrightarrow> \<not>k_memb x k_empt"
  unfolding k_memb_def k_empt_def by simp

(*>*)

subsubsection\<open>Algorithm invariant\<close>

text\<open>

The invariant for the automata construction is straightforward, viz
that at each step of the process the state represents an automaton
that concords with @{term "mkAutoSim"} on the visited equivalence
classes. We also need to know that the state has preserved the @{term
"MapOps"} invariants.

\<close>

definition k_invariant :: "('ma, 'mt) AlgState \<Rightarrow> bool" where
  "k_invariant A \<equiv>
      (\<forall>ec ec'. k_isNode ec \<and> k_isNode ec' \<and> simAbs ec' = simAbs ec
        \<longrightarrow> lookup aOps (aActs A) ec = lookup aOps (aActs A) ec')
    \<and> (\<forall>ec ec' obs. k_isNode ec \<and> k_isNode ec' \<and> simAbs ec' = simAbs ec
        \<longrightarrow> lookup tOps (aTrans A) (ec, obs) = lookup tOps (aTrans A) (ec', obs))
    \<and> (\<forall>ec. k_isNode ec \<and> k_memb ec A
        \<longrightarrow> (\<exists>acts. lookup aOps (aActs A) ec = Some acts
                   \<and> set acts = set (simAction a ec)))
    \<and> (\<forall>ec obs. k_isNode ec \<and> k_memb ec A
              \<and> obs \<in> simObs a ` set (simTrans a ec)
        \<longrightarrow> (\<exists>ec'. lookup tOps (aTrans A) (ec, obs) = Some ec'
                  \<and> simAbs ec' \<in> simAbs ` set (simTrans a ec)
                  \<and> simObs a ec' = obs))"
(*<*)

lemma k_invariantI[intro]:
  "\<lbrakk> \<And>ec ec'. \<lbrakk> k_isNode ec; k_isNode ec'; simAbs ec' = simAbs ec \<rbrakk>
       \<Longrightarrow> lookup aOps (aActs A) ec = lookup aOps (aActs A) ec';
     \<And>ec ec' obs. \<lbrakk> k_isNode ec; k_isNode ec'; simAbs ec' = simAbs ec \<rbrakk>
       \<Longrightarrow> lookup tOps (aTrans A) (ec, obs) = lookup tOps (aTrans A) (ec', obs);
     \<And>ec. \<lbrakk> k_isNode ec; k_memb ec A \<rbrakk>
       \<Longrightarrow> \<exists>acts. lookup aOps (aActs A) ec = Some acts \<and> set acts = set (simAction a ec);
     \<And>ec obs ecs'. \<lbrakk> k_isNode ec; k_memb ec A; obs \<in> simObs a ` set (simTrans a ec) \<rbrakk>
       \<Longrightarrow> \<exists>ec'. lookup tOps (aTrans A) (ec, obs) = Some ec'
               \<and> simAbs ec' \<in> simAbs ` set (simTrans a ec)
               \<and> simObs a ec' = obs \<rbrakk>
  \<Longrightarrow> k_invariant A"
  unfolding k_invariant_def by (simp (no_asm_simp))

lemma k_invariantAOD:
  "\<lbrakk> k_isNode ec; k_isNode ec'; simAbs ec' = simAbs ec; k_invariant A \<rbrakk>
     \<Longrightarrow> lookup aOps (aActs A) ec = lookup aOps (aActs A) ec'"
  unfolding k_invariant_def by blast

lemma k_invariantTOD:
  "\<lbrakk> k_isNode ec; k_isNode ec'; simAbs ec' = simAbs ec; k_invariant A \<rbrakk>
     \<Longrightarrow> lookup tOps (aTrans A) (ec, obs) = lookup tOps (aTrans A) (ec', obs)"
  unfolding k_invariant_def by blast

lemma k_invariantAD:
  "\<lbrakk> k_isNode ec; k_memb ec A; k_invariant A \<rbrakk>
     \<Longrightarrow> \<exists>acts. lookup aOps (aActs A) ec = Some acts \<and> set acts = set (simAction a ec)"
  unfolding k_invariant_def by blast

lemma k_invariantTD:
  "\<lbrakk> k_isNode ec; k_memb ec A; obs \<in> simObs a ` set (simTrans a ec); k_invariant A \<rbrakk>
     \<Longrightarrow> \<exists>ec'. lookup tOps (aTrans A) (ec, obs) = Some ec'
             \<and> simAbs ec' \<in> simAbs ` set (simTrans a ec)
             \<and> simObs a ec' = obs"
  unfolding k_invariant_def by blast

lemma k_invariant_empt[simp]:
  "k_invariant k_empt"
  apply rule
  apply auto
  apply (auto iff: k_empt_def)
  done

lemma k_invariant_step_new_aux:
  assumes X: "set X \<subseteq> set (k_succs x)"
      and x: "k_isNode x"
      and ec: "k_isNode ec"
      and ec': "simAbs ec' \<in> simAbs ` set X"
      and S: "simAbs ec = simAbs x"
  shows "\<exists>r. lookup tOps (foldr (transUpdate x) X Y) (ec, simObs a ec') = Some r
           \<and> simAbs r \<in> simAbs ` set (k_succs ec)
           \<and> simObs a r = simObs a ec'"
using X ec'
proof(induct X arbitrary: Y)
  case Nil thus ?case by simp
next
  case (Cons y ys) show ?case
  proof(cases "simAbs ec' = simAbs y")
    case False with x ec S Cons show ?thesis
      unfolding transUpdate_def
      apply clarsimp
      unfolding k_isNode_def
      apply (erule imageE)+
      apply (cut_tac a=a and t=ta and ec=x and ec'=ec in simTrans_simAbs_cong[symmetric])
      apply simp_all
      done
  next
    case True
    with Cons have F: "simAbs y \<in> simAbs ` set (k_succs x)"
      by auto
    from x obtain t
      where tC: "t \<in> jkbpC"
        and x': "simAbs x = sim_equiv_class a t"
      unfolding k_isNode_def by blast
    from F obtain t' s
      where "simAbs y = sim_equiv_class a (t' \<leadsto> s)"
        and tsC: "t' \<leadsto> s \<in> jkbpC"
        and tt': "jview a t = jview a t'"
      using simTrans[rule_format, where a=a and t=t] tC x' by auto
    with Cons.hyps[where Y11=Y] Cons(2) Cons(3) True S x ec show ?thesis
      unfolding transUpdate_def
      apply auto
      apply (subst simTrans_simAbs_cong[where t=t' and ec'=x])
       apply blast

       using x' tt'
       apply auto[1]

       apply simp

       apply (rule image_eqI[where x=y])
       apply simp
       apply simp
      using simObs[rule_format, where a=a and t="t'\<leadsto>s"]
      apply simp
      done
  qed
qed

lemma k_invariant_step_new:
  assumes x: "k_isNode x"
      and ec: "k_isNode ec"
      and ec': "ec' \<in> set (k_succs ec)"
      and S: "simAbs ec = simAbs x"
  shows "\<exists>ec''. lookup tOps (aTrans (k_ins x A)) (ec, simObs a ec') = Some ec''
              \<and> simAbs ec'' \<in> simAbs ` set (k_succs ec)
              \<and> simObs a ec'' = simObs a ec'"
proof -
  from x ec'
  have ec': "simAbs ec' \<in> simAbs ` set (k_succs x)"
    unfolding k_isNode_def
    apply clarsimp
    apply (subst simTrans_simAbs_cong[OF _ _ S, symmetric])
    using S
    apply auto
    done
  thus ?thesis
    using k_invariant_step_new_aux[OF subset_refl x ec _ S, where ec'=ec']
    unfolding k_ins_def
    apply auto
    done
qed

lemma k_invariant_step_old_aux:
  assumes x: "k_isNode x"
      and ec: "k_isNode ec"
      and S: "simAbs ec \<noteq> simAbs x"
  shows "lookup tOps (foldr (transUpdate x) X Y) (ec, obs)
       = lookup tOps Y (ec, obs)"
proof(induct X)
  case (Cons z zs) with x ec S show ?case
    by (cases "lookup tOps Y (ec, obs)") (simp_all add: transUpdate_def)
qed simp

lemma k_invariant_step_old:
  assumes x: "k_isNode x"
      and ec: "k_isNode ec"
      and S: "simAbs ec \<noteq> simAbs x"
  shows "lookup tOps (aTrans (k_ins x A)) (ec, obs)
       = lookup tOps (aTrans A) (ec, obs)"
  unfolding k_ins_def
  using k_invariant_step_old_aux[OF x ec S]
  by simp

lemma k_invariant_frame:
  assumes B: "lookup tOps Y (ec, obs) = lookup tOps Y (ec', obs)"
      and x: "k_isNode x"
      and ec: "k_isNode ec"
      and ec': "k_isNode ec'"
      and S: "simAbs ec' = simAbs ec"
  shows "lookup tOps (foldr (transUpdate x) X Y) (ec, obs) = lookup tOps (foldr (transUpdate x) X Y) (ec', obs)"
  apply (induct X)
  unfolding transUpdate_def
   using B
   apply simp
  using x ec ec' S
  apply simp
  done

lemma k_invariant_step[simp]:
  assumes N: "k_isNode x"
      and I: "k_invariant A"
      and M: "\<not> k_memb x A"
  shows "k_invariant (k_ins x A)"
(*<*)
proof
  fix ec ec'
  assume ec: "k_isNode ec" and ec': "k_isNode ec'" and X: "simAbs ec' = simAbs ec"
  with N show "lookup aOps (aActs (k_ins x A)) ec = lookup aOps (aActs (k_ins x A)) ec'"
    unfolding k_ins_def actsUpdate_def
    using k_invariantAOD[OF ec ec' X I]
    apply simp
    done
next
  fix ec ec' obs
  assume ec: "k_isNode ec" and ec': "k_isNode ec'" and X: "simAbs ec' = simAbs ec"
  show "lookup tOps (aTrans (k_ins x A)) (ec, obs) = lookup tOps (aTrans (k_ins x A)) (ec', obs)"
    unfolding k_ins_def
    using k_invariant_frame[OF k_invariantTOD[OF ec ec' X I] N ec ec' X]
    apply simp
    done
next
  fix ec obs ecs'
  assume n: "k_isNode ec"
    and ec: "k_memb ec (k_ins x A)"
    and obs: "obs \<in> simObs a ` set (simTrans a ec)"
  show "\<exists>ec'. lookup tOps (aTrans (k_ins x A)) (ec, obs) = Some ec'
            \<and> simAbs ec' \<in> simAbs ` set (k_succs ec)
            \<and> simObs a ec' = obs"
  proof(cases "simAbs ec = simAbs x")
    case True with N n obs show ?thesis
      using k_invariant_step_new by auto
  next
    case False with I N n ec obs show ?thesis
      apply (simp add: k_invariant_step_old)
      apply (rule k_invariantTD)
      apply simp_all
      unfolding k_ins_def k_memb_def actsUpdate_def
      apply simp
      done
  qed
next
  fix ec
  assume n: "k_isNode ec"
     and ec: "k_memb ec (k_ins x A)"
  show "\<exists>acts. lookup aOps (aActs (k_ins x A)) ec = Some acts \<and> set acts = set (simAction a ec)"
  proof(cases "simAbs ec = simAbs x")
    case True with aOps N n show ?thesis
      unfolding k_ins_def actsUpdate_def
      apply clarsimp
      unfolding k_isNode_def
      apply clarsimp
      apply (erule jAction_simAbs_cong)
      apply auto
      done
  next
    case False with aOps N I M n ec show ?thesis
      unfolding k_ins_def actsUpdate_def
      apply simp
      apply (rule k_invariantAD)
      unfolding k_memb_def
      apply simp_all
      done
  qed
qed
(*>*)

(*>*)

text\<open>

Showing that the invariant holds of @{term "k_empt"} and is respected
by @{term "k_ins"} is routine.

The initial frontier is the partition of the set of initial states
under the initial observation function.

\<close>

definition (in Algorithm) k_frontier :: "'a \<Rightarrow> 'rep list" where
  "k_frontier a \<equiv> map (simInit a \<circ> envObs a) envInit"
(*<*)

lemma k_frontier_is_node[intro, simp]:
  "list_all k_isNode (k_frontier a)"
  unfolding k_frontier_def
  by (auto iff: simInit list_all_iff k_isNode_def jviewInit jviewIncr)
(*>*)

end (* context AlgorithmForAgent *)

text\<open>

We now instantiate the @{term "DFS"} locale with respect to the @{term
"AlgorithmForAgent"} locale. The instantiated lemmas are given the
mandatory prefix \<open>KBPAlg\<close> in the @{term "AlgorithmForAgent"}
locale.

\<close>

sublocale AlgorithmForAgent
        < KBPAlg: DFS k_succs k_isNode k_invariant k_ins k_memb k_empt simAbs

(*<*)
  apply (unfold_locales)
  apply simp_all

  unfolding k_memb_def k_ins_def actsUpdate_def
  using aOps
  apply (auto iff: isSome_eq)[1]

  unfolding k_isNode_def
  apply clarsimp
  apply (erule simTrans_simAbs_cong)
  apply auto
  done
(*>*)

text_raw\<open>
\begin{figure}
\begin{isabellebody}%
\<close>
definition
  alg_dfs :: "('ma, 'rep, 'aAct list) MapOps
         \<Rightarrow> ('mt, 'rep \<times> 'obs, 'rep) MapOps
         \<Rightarrow> ('rep \<Rightarrow> 'obs)
         \<Rightarrow> ('rep \<Rightarrow> 'rep list)
         \<Rightarrow> ('rep \<Rightarrow> 'aAct list)
         \<Rightarrow> 'rep list
         \<Rightarrow> ('ma, 'mt) AlgState"
where
  "alg_dfs aOps tOps simObs simTrans simAction \<equiv>
    let k_empt = \<lparr> aActs = empty aOps, aTrans = empty tOps \<rparr>;
       k_memb = (\<lambda>s A. isSome (lookup aOps (aActs A) s));
       k_succs = simTrans;
       actsUpdate = \<lambda>ec A. update aOps ec (simAction ec) (aActs A);
       transUpdate = \<lambda>ec ec' at. update tOps (ec, simObs ec') ec' at;
       k_ins = \<lambda>ec A. \<lparr> aActs = actsUpdate ec A,
                         aTrans = foldr (transUpdate ec) (k_succs ec) (aTrans A) \<rparr>
     in gen_dfs k_succs k_ins k_memb k_empt"

text\<open>\<close>

definition
  mkAlgAuto :: "('ma, 'rep, 'aAct list) MapOps
            \<Rightarrow> ('mt, 'rep \<times> 'obs, 'rep) MapOps
            \<Rightarrow> ('a \<Rightarrow> 'rep \<Rightarrow> 'obs)
            \<Rightarrow> ('a \<Rightarrow> 'obs \<Rightarrow> 'rep)
            \<Rightarrow> ('a \<Rightarrow> 'rep \<Rightarrow> 'rep list)
            \<Rightarrow> ('a \<Rightarrow> 'rep \<Rightarrow> 'aAct list)
            \<Rightarrow> ('a \<Rightarrow> 'rep list)
            \<Rightarrow> ('a, 'obs, 'aAct, 'rep) JointProtocol"
where
  "mkAlgAuto aOps tOps simObs simInit simTrans simAction frontier \<equiv> \<lambda>a.
    let auto = alg_dfs aOps tOps (simObs a) (simTrans a) (simAction a)
                       (frontier a)
     in \<lparr> pInit = simInit a,
          pTrans = \<lambda>obs ec. the (lookup tOps (aTrans auto) (ec, obs)),
          pAct = \<lambda>ec. the (lookup aOps (aActs auto) ec) \<rparr>"

text_raw\<open>
  \end{isabellebody}%
  \caption{The algorithm. The function @{term "the"} projects a value from the
    @{typ "'a option"} type, diverging on @{term "None"}.}
  \label{fig:kbps-alg-algorithm}
\end{figure}
\<close>
(*<*)
lemma mkAutoSim_simps[simp]:
  "pInit (mkAlgAuto aOps tOps simObs simInit simTrans simAction frontier a) = simInit a"
  "pTrans (mkAlgAuto aOps tOps simObs simInit simTrans simAction frontier a)
 = (\<lambda>obs ec. the (lookup tOps (aTrans (alg_dfs aOps tOps (simObs a) (simTrans a) (simAction a) (frontier a))) (ec, obs)))"
  "pAct (mkAlgAuto aOps tOps simObs simInit simTrans simAction frontier a)
 = (\<lambda>ec. the (lookup aOps (aActs (alg_dfs aOps tOps (simObs a) (simTrans a) (simAction a) (frontier a))) ec))"
  unfolding mkAlgAuto_def
  apply (simp_all add: Let_def)
  done

(* Later we want to show that a particular DFS implementation does the
right thing. *)

definition
  alg_mk_auto :: "('ma, 'rep, 'aAct list) MapOps
                \<Rightarrow> ('mt, 'rep \<times> 'obs, 'rep) MapOps
                \<Rightarrow> ('obs \<Rightarrow> 'rep)
                \<Rightarrow> ('ma, 'mt) AlgState
                \<Rightarrow> ('obs, 'aAct, 'rep) Protocol"
where
  "alg_mk_auto aOps tOps simInit k_dfs \<equiv>
    \<lparr> pInit = simInit,
      pTrans = \<lambda>obs ec. the (lookup tOps (aTrans k_dfs) (ec, obs)),
      pAct = \<lambda>ec. the (lookup aOps (aActs k_dfs) ec)
    \<rparr>"

(*>*)
context AlgorithmForAgent
begin

text\<open>

The final algorithm, with the constants inlined, is shown in
Figure~\ref{fig:kbps-alg-algorithm}. The rest of this section shows
its correctness.

Firstly it follows immediately from \<open>dfs_invariant\<close> that the
invariant holds of the result of the DFS:

\<close>
(*<*)

abbreviation
  "k_dfs \<equiv> KBPsAlg.alg_dfs aOps tOps (simObs a) (simTrans a) (simAction a) (k_frontier a)"

(* This is a syntactic nightmare. *)

lemma k_dfs_gen_dfs_unfold[simp]:
  "k_dfs = gen_dfs k_succs k_ins k_memb k_empt (k_frontier a)"
  unfolding alg_dfs_def
  apply (fold k_empt_def k_memb_def actsUpdate_def transUpdate_def)
  apply (simp add: k_ins_def[symmetric])
  done

(*>*)
lemma k_dfs_invariant: "k_invariant k_dfs"
(*<*)
  using KBPAlg.dfs_invariant[where S="k_empt" and xs="k_frontier a"]
  by simp

(*>*)
text\<open>

Secondly we can see that the set of reachable equivalence classes
coincides with the partition of @{term "jkbpC"} under the simulation
and representation functions:

\<close>

lemma k_reachable:
  "simAbs ` KBPAlg.reachable (set (k_frontier a)) = sim_equiv_class a ` jkbpC"
(*<*)(is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
  proof
    fix sx assume "sx \<in> ?lhs"
    then obtain x
      where x: "x \<in> KBPAlg.reachable (set (k_frontier a))"
        and sx: "simAbs x = sx"
      by auto
    hence "x \<in> ({ (x, y). y \<in> set (k_succs x) })\<^sup>*
                 `` set (map (simInit a \<circ> envObs a) envInit)"
      unfolding KBPAlg.reachable_def k_frontier_def by simp
    then obtain s iobs
      where R: "(simInit a iobs, x) \<in> ({ (x, y). y \<in> set (k_succs x)})\<^sup>*"
        and sI: "s \<in> set envInit"
        and iobs: "envObs a s = iobs"
      by auto
    from R x have "simAbs x \<in> ?rhs"
    proof(induct arbitrary: sx rule: rtrancl_induct)
      case base
      with sI iobs show ?case by (auto simp: jviewInit simInit)
    next
      case (step x y)
      with sI iobs
      have "simAbs x \<in> sim_equiv_class a ` jkbpC"
        unfolding KBPAlg.reachable_def Image_def k_frontier_def
        by auto
      then obtain t
        where tC: "t \<in> jkbpC"
          and F: "simAbs x = sim_equiv_class a t"
        by auto
      from step
      have "simAbs y \<in> simAbs ` set (k_succs x)" by auto
      thus  ?case
        using simTrans[rule_format, where a=a and t=t] tC F by auto
    qed
    with sx show "sx \<in> ?rhs" by simp
  qed
next
  show "?rhs \<subseteq> ?lhs"
  proof
    fix ec assume "ec \<in> ?rhs"
    then obtain t
      where tC: "t \<in> jkbpC"
        and ec: "ec = sim_equiv_class a t"
      by auto
    thus "ec \<in> ?lhs"
    proof(induct t arbitrary: ec)
      case (tInit s) thus ?case
        unfolding KBPAlg.reachable_def (* FIXME ouch this is touchy *)
        unfolding k_frontier_def
        apply simp
        apply (rule image_eqI[where x="simInit a (envObs a s)"])
         apply (simp add: simInit jviewInit)
        apply (rule ImageI[where a="simInit a (envObs a s)"])
        apply auto
        done
    next
      case (tStep t s)
      hence tsC: "t \<leadsto> s \<in> jkbpC"
        and ec: "ec = sim_equiv_class a (t \<leadsto> s)"
        and "sim_equiv_class a t
           \<in> simAbs ` DFS.reachable k_succs (set (k_frontier a))"
        by auto
      then obtain rect
        where rect: "rect \<in> DFS.reachable k_succs (set (k_frontier a))"
          and srect: "simAbs rect = sim_equiv_class a t"
        by auto
      from tsC ec srect
      have "ec \<in> simAbs ` set (simTrans a rect)"
        using simTrans[rule_format, where a=a and t="t" and ec="rect"] srect by auto
      then obtain rec
        where rec: "ec = simAbs rec"
          and F: "rec \<in> set (simTrans a rect)"
        by auto
      from rect obtain rec0
        where rec0: "rec0 \<in> set (k_frontier a)"
          and rec0rect: "(rec0, rect) \<in> ({ (x, y). y \<in> set (k_succs x)})\<^sup>*"
        unfolding KBPAlg.reachable_def by auto
      show ?case
        apply -
        apply (rule image_eqI[where x="rec"])
         apply (rule rec)
        unfolding KBPAlg.reachable_def
        apply (rule ImageI[where a="rec0"])
         apply (rule rtrancl_into_rtrancl[where b="rect"])
          apply (rule rec0rect)
         apply clarsimp
         apply (rule F)
         apply (rule rec0)
         done
     qed
   qed
qed
(*>*)
text\<open>

Left to right follows from an induction on the reflexive, transitive
closure, and right to left by induction over canonical traces.

This result immediately yields the same result at the level of
representations:

\<close>

lemma k_memb_rep:
  assumes N: "k_isNode rec"
  shows "k_memb rec k_dfs"
(*<*)
proof -
  from N obtain rec'
    where r: "rec' \<in> DFS.reachable k_succs (set (k_frontier a))"
      and rec': "simAbs rec = simAbs rec'"
    unfolding k_isNode_def by (auto iff: k_reachable[symmetric])

  from N k_isNode_cong[OF rec', symmetric]
  have N': "k_isNode rec'"
    unfolding k_isNode_def by auto

  show "k_memb rec k_dfs"
    using KBPAlg.reachable_imp_dfs[OF N' k_frontier_is_node r]
    apply clarsimp
    apply (subst k_memb_def)
    apply (subst (asm) k_memb_def)
    using k_invariantAOD[OF N' N rec' k_dfs_invariant, symmetric]
    apply (cut_tac ec=y' and ec'=rec' in k_invariantAOD[OF _ _ _ k_dfs_invariant, symmetric])
     apply simp_all

     apply (cut_tac ec=rec' and ec'=y' in k_isNode_cong)
     apply simp
     using N'
     apply simp
     apply (rule N')
     done
qed
(*>*)

end (* context AlgorithmForAgent *)

text\<open>

This concludes our agent-specific reasoning; we now show that the
algorithm works for all agents. The following command generalises all
our lemmas in the @{term "AlgorithmForAgent"} to the @{term
"Algorithm"} locale, giving them the mandatory prefix \<open>KBP\<close>:

\<close>

sublocale Algorithm
        < KBP: AlgorithmForAgent
            jkbp envInit envAction envTrans envVal jview envObs
            jviewInit jviewIncr simf simRels simVal simAbs simObs
            simInit simTrans simAction aOps tOps a for a
(*<*)
  by unfold_locales
(*>*)

context Algorithm
begin

abbreviation
  "k_mkAlgAuto \<equiv>
    mkAlgAuto aOps tOps simObs simInit simTrans simAction k_frontier"
(*<*)

lemma k_mkAlgAuto_mkAutoSim_equiv:
  assumes tC: "t \<in> jkbpC"
  shows "simAbs (runJP k_mkAlgAuto t a) = simAbs (runJP mkAutoSim t a)"
using tC
proof(induct t)
  case (tInit s) thus ?case by simp
next
  case (tStep t s)
  hence tC: "t \<in> jkbpC" by blast

  from tStep
  have N: "KBP.k_isNode a (runJP k_mkAlgAuto t a)"
    unfolding KBP.k_isNode_def
    by (simp only: mkAutoSim_ec) auto

  from tStep
  have ect: "simAbs (runJP k_mkAlgAuto t a) = sim_equiv_class a t"
    by (simp only: mkAutoSim_ec) auto

  from tStep
  have "sim_equiv_class a (t \<leadsto> s) \<in> simAbs ` set (simTrans a (runJP k_mkAlgAuto t a))"
    using simTrans[rule_format, where a=a and t=t] tC ect by auto
  then obtain ec
    where ec: "ec \<in> set (simTrans a (runJP k_mkAlgAuto t a))"
      and sec: "simAbs ec = sim_equiv_class a (t \<leadsto> s)"
    by auto

  from tStep
  have F: "envObs a s \<in> simObs a ` set (simTrans a (runJP k_mkAlgAuto t a))"
    using simObs[rule_format, where a=a and t="t\<leadsto>s", symmetric] sec ec by auto
  from KBP.k_memb_rep[OF N]
  have E: "KBP.k_memb (runJP k_mkAlgAuto t a) (KBP.k_dfs a)" by blast

  have G: "simAbs (runJP k_mkAlgAuto (t \<leadsto> s) a) = sim_equiv_class a (t \<leadsto> s)"
    using KBP.k_invariantTD[OF N E F KBP.k_dfs_invariant]
    apply (clarsimp simp: jviewIncr)
    using simTrans[rule_format, where a=a and t=t and ec="runJP k_mkAlgAuto t a"] tC ect
    apply (subgoal_tac "simAbs x \<in> simAbs ` set (simTrans a (runJP k_mkAlgAuto t a))")
     apply (clarsimp simp: jviewIncr)
     apply (cut_tac a=a and ec=ec' and t="t'\<leadsto>sa" in simObs[rule_format])
      apply (simp add: jviewIncr)
     apply simp
    apply blast
    done

  from tStep show ?case by (simp only: G mkAutoSim_ec)
qed

(*>*)
text\<open>

Running the automata produced by the DFS on a canonical trace @{term
"t"} yields some representation of the expected equivalence class:

\<close>

lemma k_mkAlgAuto_ec:
  assumes tC: "t \<in> jkbpC"
  shows "simAbs (runJP k_mkAlgAuto t a) = sim_equiv_class a t"
(*<*)
  using k_mkAlgAuto_mkAutoSim_equiv[OF tC] mkAutoSim_ec[OF tC]
  by simp

(*>*)
text\<open>

This involves an induction over the canonical trace @{term "t"}.

That the DFS and @{term "mkAutoSim"} yield the same actions on
canonical traces follows immediately from this result and the
invariant:

\<close>

lemma k_mkAlgAuto_mkAutoSim_act_eq:
  assumes tC: "t \<in> jkbpC"
  shows "set \<circ> actJP k_mkAlgAuto t = set \<circ> actJP mkAutoSim t"
(*<*)
proof
  fix a
  let ?ec = "sim_equiv_class a t"
  let ?rec = "runJP k_mkAlgAuto t a"

  from tC have E: "?ec \<in> sim_equiv_class a ` jkbpC"
    by auto

  from tC E have N: "KBP.k_isNode a (runJP k_mkAlgAuto t a)"
    unfolding KBP.k_isNode_def by (simp add: k_mkAlgAuto_ec[OF tC])

  from KBP.k_memb_rep[OF N]
  have E: "KBP.k_memb ?rec (KBP.k_dfs a)" by blast

  obtain acts
    where "lookup aOps (aActs (KBP.k_dfs a)) ?rec = Some acts"
      and "set acts = set (simAction a ?rec)"
    using KBP.k_invariantAD[OF N E KBP.k_dfs_invariant] by blast

  thus "(set \<circ> actJP k_mkAlgAuto t) a = (set \<circ> actJP mkAutoSim t) a"
    by (auto intro!: jAction_simAbs_cong[OF tC]
               simp: k_mkAlgAuto_ec[OF tC] mkAutoSim_ec[OF tC])
qed
(*>*)

text\<open>

Therefore these two constructions are behaviourally equivalent, and so
the DFS generates an implementation of @{term "jkbp"} in the given
environment:

\<close>

theorem k_mkAlgAuto_implements: "implements k_mkAlgAuto"
(*<*)
proof -
  have "behaviourally_equiv mkAutoSim k_mkAlgAuto"
    by rule (simp only: k_mkAlgAuto_mkAutoSim_act_eq)
  with mkAutoSim_implements show ?thesis
    by (simp add: behaviourally_equiv_implements)
qed
(*>*)

end (* context Algorithm *)

text\<open>

Clearly the automata generated by this algorithm are large. We discuss
this issue in \S\ref{sec:kbps-alg-auto-min}.

\FloatBarrier

\<close>

(*<*)
end
(*>*)