(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, algorithms for iterators, min, max, to_sorted_list

*)

section \<open>\isaheader{Generic Algorithms for Maps}\<close>
theory MapGA
imports SetIteratorCollectionsGA
begin

text_raw \<open>\label{thy:MapGA}\<close>

record ('k,'v,'s) map_basic_ops =
  bmap_op_\<alpha> :: "('k,'v,'s) map_\<alpha>"
  bmap_op_invar :: "('k,'v,'s) map_invar"
  bmap_op_empty :: "('k,'v,'s) map_empty"
  bmap_op_lookup :: "('k,'v,'s) map_lookup"
  bmap_op_update :: "('k,'v,'s) map_update"
  bmap_op_update_dj :: "('k,'v,'s) map_update_dj"
  bmap_op_delete :: "('k,'v,'s) map_delete"
  bmap_op_list_it :: "('k,'v,'s) map_list_it"

record ('k,'v,'s) omap_basic_ops = "('k,'v,'s) map_basic_ops" +
  bmap_op_ordered_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
  bmap_op_rev_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"

locale StdBasicMapDefs =
  poly_map_iteratei_defs "bmap_op_list_it ops"
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == bmap_op_\<alpha> ops"
  abbreviation invar where "invar == bmap_op_invar ops"
  abbreviation empty where "empty == bmap_op_empty ops"
  abbreviation lookup where "lookup == bmap_op_lookup ops"
  abbreviation update where "update == bmap_op_update ops"
  abbreviation update_dj where "update_dj == bmap_op_update_dj ops"
  abbreviation delete where "delete == bmap_op_delete ops"
  abbreviation list_it where "list_it == bmap_op_list_it ops"
end

locale StdBasicOMapDefs = StdBasicMapDefs ops
  + poly_map_iterateoi_defs "bmap_op_ordered_list_it ops"
  + poly_map_rev_iterateoi_defs "bmap_op_rev_list_it ops"
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
  abbreviation ordered_list_it where "ordered_list_it
    \<equiv> bmap_op_ordered_list_it ops"
  abbreviation rev_list_it where "rev_list_it
    \<equiv> bmap_op_rev_list_it ops"
end

locale StdBasicMap = StdBasicMapDefs ops +
  map \<alpha> invar +
  map_empty \<alpha> invar empty +
  map_lookup \<alpha> invar lookup  +
  map_update \<alpha> invar update  +
  map_update_dj \<alpha> invar update_dj +
  map_delete \<alpha> invar delete  +
  poly_map_iteratei \<alpha> invar list_it
  for ops :: "('k,'v,'s,'more) map_basic_ops_scheme"
begin
  lemmas correct[simp] = empty_correct lookup_correct update_correct
    update_dj_correct delete_correct
end

locale StdBasicOMap =
  StdBasicOMapDefs ops +
  StdBasicMap ops +
  poly_map_iterateoi \<alpha> invar ordered_list_it +
  poly_map_rev_iterateoi \<alpha> invar rev_list_it
  for ops :: "('k::linorder,'v,'s,'more) omap_basic_ops_scheme"
begin
end

context StdBasicMapDefs begin
  definition "g_sng k v \<equiv> update k v (empty ())"
  definition "g_add m1 m2 \<equiv> iterate m2 (\<lambda>(k,v) \<sigma>. update k v \<sigma>) m1"

  definition
    "g_sel m P \<equiv>
      iteratei m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition "g_bex m P \<equiv> iteratei m (\<lambda>x. \<not>x) (\<lambda>kv \<sigma>. P kv) False"
  definition "g_ball m P \<equiv> iteratei m id (\<lambda>kv \<sigma>. P kv) True"

  definition "g_size m \<equiv> iterate m (\<lambda>_. Suc) (0::nat)"
  definition "g_size_abort b m \<equiv> iteratei m (\<lambda>s. s<b) (\<lambda>_. Suc) (0::nat)"

  definition "g_isEmpty m \<equiv> g_size_abort 1 m = 0"
  definition "g_isSng m \<equiv> g_size_abort 2 m = 1"

  definition "g_to_list m \<equiv> iterate m (#) []"

  definition "g_list_to_map l \<equiv> foldl (\<lambda>m (k,v). update k v m) (empty ())
    (rev l)"

  definition "g_add_dj m1 m2 \<equiv> iterate m2 (\<lambda>(k,v) \<sigma>. update_dj k v \<sigma>) m1"

  definition "g_restrict P m \<equiv> iterate m
    (\<lambda>(k,v) \<sigma>. if P (k,v) then update_dj k v \<sigma> else \<sigma>) (empty ())"

  definition dflt_ops :: "('k,'v,'s) map_ops"
    where [icf_rec_def]:
    "dflt_ops \<equiv>
      \<lparr>
        map_op_\<alpha> = \<alpha>,
        map_op_invar = invar,
        map_op_empty = empty,
        map_op_lookup = lookup,
        map_op_update = update,
        map_op_update_dj = update_dj,
        map_op_delete = delete,
        map_op_list_it = list_it,
        map_op_sng = g_sng,
        map_op_restrict = g_restrict,
        map_op_add = g_add,
        map_op_add_dj = g_add_dj,
        map_op_isEmpty = g_isEmpty,
        map_op_isSng = g_isSng,
        map_op_ball = g_ball,
        map_op_bex = g_bex,
        map_op_size = g_size,
        map_op_size_abort = g_size_abort,
        map_op_sel = g_sel,
        map_op_to_list = g_to_list,
        map_op_to_map = g_list_to_map
      \<rparr>"

  local_setup \<open>Locale_Code.lc_decl_del @{term dflt_ops}\<close>

end

lemma update_dj_by_update:
  assumes "map_update \<alpha> invar update"
  shows "map_update_dj \<alpha> invar update"
proof -
  interpret map_update \<alpha> invar update by fact
  show ?thesis
    apply (unfold_locales)
    apply (auto simp add: update_correct)
    done
qed

lemma map_iterator_linord_is_it:
  "map_iterator_linord m it \<Longrightarrow> map_iterator m it"
  unfolding set_iterator_def set_iterator_map_linord_def
  apply (erule set_iterator_genord.set_iterator_weaken_R)
  ..

context StdBasicMap
begin

  lemma g_add_impl: "map_add \<alpha> invar g_add"
  proof
    fix m1 m2
    assume "invar m1" "invar m2"

    have A: "g_add m1 m2 = iterate_add_to_map m1 update (iteratei m2)"
      unfolding g_add_def iterate_add_to_map_def by simp
    have "\<alpha> (g_add m1 m2) = \<alpha> m1 ++ \<alpha> m2 \<and> invar (g_add m1 m2)"
      unfolding A
      apply (rule
        iterate_add_to_map_correct[of \<alpha> invar update m1 "iteratei m2" "\<alpha> m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      done
    thus "\<alpha> (g_add m1 m2) = \<alpha> m1 ++ \<alpha> m2" "invar (g_add m1 m2)" by auto
  qed

  lemma g_sel_impl: "map_sel' \<alpha> invar g_sel"
  proof -
    have A: "\<And>m P. g_sel m P = iterate_sel_no_map (iteratei m) P"
      unfolding g_sel_def iterate_sel_no_map_def iterate_sel_def by simp

    { fix m P
      assume I: "invar m"
      note iterate_sel_no_map_correct[OF iteratei_correct[OF I], of P]
    }
    thus ?thesis
      apply unfold_locales
      unfolding A
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      apply clarify
      apply (metis option.exhaust prod.exhaust)
      apply (simp add: Bex_def Ball_def image_iff map_to_set_def)
      done
  qed

  lemma g_bex_impl: "map_bex \<alpha> invar g_bex"
    apply unfold_locales
    unfolding g_bex_def
    apply (rule_tac I="\<lambda>it \<sigma>. \<sigma> \<longleftrightarrow> (\<exists>kv\<in>it. P kv)"
      in iteratei_rule_insert_P)
    by (auto simp: map_to_set_def)

  lemma g_size_impl: "map_size \<alpha> invar g_size"
  proof
    fix m
    assume I: "invar m"
    have A: "g_size m \<equiv> iterate_size (iteratei m)"
      unfolding g_size_def iterate_size_def by simp

    from iterate_size_correct [OF iteratei_correct[OF I]]
    show "g_size m = card (dom (\<alpha> m))"
      unfolding A
      by (simp_all add: card_map_to_set)
  qed

  lemma g_size_abort_impl: "map_size_abort \<alpha> invar g_size_abort"
  proof
    fix s m
    assume I: "invar m"
    have A: "g_size_abort s m \<equiv> iterate_size_abort (iteratei m) s"
      unfolding g_size_abort_def iterate_size_abort_def by simp

    from iterate_size_abort_correct [OF iteratei_correct[OF I]]
    show "g_size_abort s m = min s (card (dom (\<alpha> m)))"
      unfolding A
      by (simp_all add: card_map_to_set)
  qed

  lemma g_isEmpty_impl: "map_isEmpty \<alpha> invar g_isEmpty"
  proof
    fix m
    assume I: "invar m"
    interpret map_size_abort \<alpha> invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have
      "g_size_abort 1 m = min 1 (card (dom (\<alpha> m)))" .
    thus "g_isEmpty m = (\<alpha> m = Map.empty)" unfolding g_isEmpty_def
      by (auto simp: min_def card_0_eq[OF finite] I)
  qed

  lemma g_isSng_impl: "map_isSng \<alpha> invar g_isSng"
  proof
    fix m
    assume I: "invar m"
    interpret map_size_abort \<alpha> invar g_size_abort by (rule g_size_abort_impl)
    from size_abort_correct[OF I] have
      "g_size_abort 2 m = min 2 (card (dom (\<alpha> m)))" .
    thus "g_isSng m = (\<exists>k v. \<alpha> m = [k \<mapsto> v])" unfolding g_isSng_def
      by (auto simp: min_def I card_Suc_eq dom_eq_singleton_conv)
  qed

  lemma g_to_list_impl: "map_to_list \<alpha> invar g_to_list"
  proof
    fix m
    assume I: "invar m"

    have A: "g_to_list m = iterate_to_list (iteratei m)"
      unfolding g_to_list_def iterate_to_list_def by simp

    from iterate_to_list_correct [OF iteratei_correct[OF I]]
    have set_l_eq: "set (g_to_list m) = map_to_set (\<alpha> m)" and
      dist_l: "distinct (g_to_list m)" unfolding A by simp_all

    from dist_l show dist_fst_l: "distinct (map fst (g_to_list m))"
      by (simp add: distinct_map set_l_eq map_to_set_def inj_on_def)

    from map_of_map_to_set[of "(g_to_list m)" "\<alpha> m", OF dist_fst_l] set_l_eq
    show "map_of (g_to_list m) = \<alpha> m" by simp
  qed

  lemma g_list_to_map_impl: "list_to_map \<alpha> invar g_list_to_map"
  proof -
    {
      fix m0 l
      assume "invar m0"
      hence "invar (foldl (\<lambda>s (k,v). update k v s) m0 l) \<and>
        \<alpha> (foldl (\<lambda>s (k,v). update k v s) m0 l) = \<alpha> m0 ++ map_of (rev l)"
      proof (induction l arbitrary: m0)
        case Nil thus ?case by simp
      next
        case (Cons kv l)
        obtain k v where [simp]: "kv=(k,v)" by (cases kv) auto
        have "invar (foldl (\<lambda>s (k, v). update k v s) m0 (kv # l))"
          apply simp
          apply (rule conjunct1[OF Cons.IH])
          apply (simp add: update_correct Cons.prems)
          done
        moreover have "\<alpha> (foldl (\<lambda>s (k, v). update k v s) m0 (kv # l)) =
          \<alpha> m0 ++ map_of (rev (kv # l))"
          apply simp
          apply (rule trans[OF conjunct2[OF Cons.IH]])
          apply (auto
            simp: update_correct Cons.prems Map.map_add_def[abs_def]
            split: option.split
          )
          done
        ultimately show ?case
          by simp
      qed
    } thus ?thesis
      apply unfold_locales
      unfolding g_list_to_map_def
      apply (auto simp: empty_correct)
      done
  qed

  lemma g_add_dj_impl: "map_add_dj \<alpha> invar g_add_dj"
  proof
    fix m1 m2
    assume "invar m1" "invar m2" and DJ: "dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {}"

    have A: "g_add_dj m1 m2 = iterate_add_to_map m1 update_dj (iteratei m2)"
      unfolding g_add_dj_def iterate_add_to_map_def by simp
    have "\<alpha> (g_add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2 \<and> invar (g_add_dj m1 m2)"
      unfolding A
      apply (rule
        iterate_add_to_map_dj_correct[
        of \<alpha> invar update_dj m1 "iteratei m2" "\<alpha> m2"])
      apply unfold_locales []
      apply fact
      apply (rule iteratei_correct, fact)
      using DJ apply (simp add: Int_ac)
      done
    thus "\<alpha> (g_add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2" "invar (g_add_dj m1 m2)" by auto
  qed

  lemma g_restrict_impl: "map_restrict \<alpha> invar \<alpha> invar g_restrict"
  proof
    fix m P
    assume I: "invar m"

    have AUX: "\<And>k v it \<sigma>.
       \<lbrakk>it \<subseteq> {(k, v). \<alpha> m k = Some v}; \<alpha> m k = Some v; (k, v) \<notin> it;
        {(k, v). \<alpha> \<sigma> k = Some v} = it \<inter> Collect P\<rbrakk>
       \<Longrightarrow> k \<notin> dom (\<alpha> \<sigma>)"
    proof (rule ccontr, simp)
      fix k v it \<sigma>
      assume "k\<in>dom (\<alpha> \<sigma>)"
      then obtain v' where "\<alpha> \<sigma> k = Some v'" by auto
      moreover assume "{(k, v). \<alpha> \<sigma> k = Some v} = it \<inter> Collect P"
      ultimately have MEM: "(k,v')\<in>it" by auto
      moreover assume "it \<subseteq> {(k, v). \<alpha> m k = Some v}" and "\<alpha> m k = Some v"
      ultimately have "v'=v" by auto
      moreover assume "(k,v)\<notin>it"
      moreover note MEM
      ultimately show False by simp
    qed

    have "\<alpha> (g_restrict P m) = \<alpha> m |` {k. \<exists>v. \<alpha> m k = Some v \<and> P (k, v)} \<and>
      invar (g_restrict P m)"
      unfolding g_restrict_def
      apply (rule_tac I="\<lambda>it \<sigma>. invar \<sigma>
        \<and> map_to_set (\<alpha> \<sigma>) = it \<inter> Collect P"
        in iterate_rule_insert_P)
      apply (auto simp: I empty_correct update_dj_correct map_to_set_def AUX)
      apply (auto split: if_split_asm)
      apply (rule ext)
      apply (auto simp: Map.restrict_map_def)
      apply force
      apply (rule ccontr)
      apply force
      done
    thus "\<alpha> (g_restrict P m) = \<alpha> m |` {k. \<exists>v. \<alpha> m k = Some v \<and> P (k, v)}"
      "invar (g_restrict P m)" by auto
  qed

context StdBasicOMapDefs
begin
  definition
    "g_min m P \<equiv>
      iterateoi m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition
    "g_max m P \<equiv>
      rev_iterateoi m (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. if P x then Some x else None) None"

  definition "g_to_sorted_list m \<equiv> rev_iterateo m (#) []"
  definition "g_to_rev_list m \<equiv> iterateo m (#) []"

  definition dflt_oops :: "('k,'v,'s) omap_ops"
    where [icf_rec_def]:
    "dflt_oops \<equiv> map_ops.extend dflt_ops
      \<lparr>
        map_op_ordered_list_it = ordered_list_it,
        map_op_rev_list_it = rev_list_it,
        map_op_min = g_min,
        map_op_max = g_max,
        map_op_to_sorted_list = g_to_sorted_list,
        map_op_to_rev_list = g_to_rev_list
      \<rparr>"
  local_setup \<open>Locale_Code.lc_decl_del @{term dflt_oops}\<close>

end

context StdBasicOMap
begin
  lemma g_min_impl: "map_min \<alpha> invar g_min"
  proof
    fix m P

    assume I: "invar m"

    from iterateoi_correct[OF I]
    have iti': "map_iterator_linord (iterateoi m) (\<alpha> m)" by simp
    note sel_correct = iterate_sel_no_map_map_linord_correct[OF iti', of P]

    have A: "g_min m P = iterate_sel_no_map (iterateoi m) P"
      unfolding g_min_def iterate_sel_no_map_def iterate_sel_def by simp

    { assume "rel_of (\<alpha> m) P \<noteq> {}"
      with sel_correct
      show "g_min m P \<in> Some ` rel_of (\<alpha> m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (\<alpha> m) P = {}"
       with sel_correct show "g_min m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v) \<in> rel_of (\<alpha> m) P"
      with sel_correct show "fst (the (g_min m P)) \<le> k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_max_impl: "map_max \<alpha> invar g_max"
  proof
    fix m P

    assume I: "invar m"

    from rev_iterateoi_correct[OF I]
    have iti': "map_iterator_rev_linord (rev_iterateoi m) (\<alpha> m)" by simp
    note sel_correct = iterate_sel_no_map_map_rev_linord_correct[OF iti', of P]

    have A: "g_max m P = iterate_sel_no_map (rev_iterateoi m) P"
      unfolding g_max_def iterate_sel_no_map_def iterate_sel_def by simp

    { assume "rel_of (\<alpha> m) P \<noteq> {}"
      with sel_correct
      show "g_max m P \<in> Some ` rel_of (\<alpha> m) P"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { assume "rel_of (\<alpha> m) P = {}"
       with sel_correct show "g_max m P = None"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }

    { fix k v
      assume "(k, v) \<in> rel_of (\<alpha> m) P"
      with sel_correct show "fst (the (g_max m P)) \<ge> k"
        unfolding A
        by (auto simp add: image_iff rel_of_def)
    }
  qed

  lemma g_to_sorted_list_impl: "map_to_sorted_list \<alpha> invar g_to_sorted_list"
  proof
    fix m
    assume I: "invar m"
    note iti = rev_iterateoi_correct[OF I]
    from iterate_to_list_map_rev_linord_correct[OF iti]
    show "sorted (map fst (g_to_sorted_list m))"
         "distinct (map fst (g_to_sorted_list m))"
         "map_of (g_to_sorted_list m) = \<alpha> m"
      unfolding g_to_sorted_list_def iterate_to_list_def by simp_all
  qed

  lemma g_to_rev_list_impl: "map_to_rev_list \<alpha> invar g_to_rev_list"
  proof
    fix m
    assume I: "invar m"
    note iti = iterateoi_correct[OF I]
    from iterate_to_list_map_linord_correct[OF iti]
    show "sorted (rev (map fst (g_to_rev_list m)))"
         "distinct (map fst (g_to_rev_list m))"
         "map_of (g_to_rev_list m) = \<alpha> m"
      unfolding g_to_rev_list_def iterate_to_list_def
      by (simp_all add: rev_map)
  qed

  lemma dflt_oops_impl: "StdOMap dflt_oops"
  proof -
    interpret aux: StdMap dflt_ops by (rule dflt_ops_impl)

    show ?thesis
      apply (rule StdOMap_intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule g_min_impl)
      apply (rule g_max_impl)
      apply (rule g_to_sorted_list_impl)
      apply (rule g_to_rev_list_impl)
      done
  qed

end

locale g_image_filter_defs_loc =
  m1: StdMapDefs ops1 +
  m2: StdMapDefs ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_image_filter f m1 \<equiv> m1.iterate m1 (\<lambda>kv \<sigma>. case f kv of
      None => \<sigma>
    | Some (k',v') => m2.update_dj k' v' \<sigma>
    ) (m2.empty ())"
end

locale g_image_filter_loc = g_image_filter_defs_loc ops1 ops2 +
  m1: StdMap ops1 +
  m2: StdMap ops2
  for ops1 :: "('k1,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k2,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_image_filter_impl:
    "map_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_image_filter"
  proof
    fix m k' v' and f :: "('k1 \<times> 'v1) \<Rightarrow> ('k2 \<times> 'v2) option"
    assume invar_m: "m1.invar m" and
           unique_f: "transforms_to_unique_keys (m1.\<alpha> m) f"

    have A: "g_image_filter f m =
      iterate_to_map m2.empty m2.update_dj (
        set_iterator_image_filter f (m1.iteratei m))"
      unfolding g_image_filter_def iterate_to_map_alt_def
        set_iterator_image_filter_def case_prod_beta
      by simp

    from m1.iteratei_correct[OF invar_m]
    have iti_m: "map_iterator (m1.iteratei m) (m1.\<alpha> m)" by simp

    from unique_f have inj_on_f: "inj_on f (map_to_set (m1.\<alpha> m) \<inter> dom f)"
      unfolding transforms_to_unique_keys_def inj_on_def Ball_def map_to_set_def
      by auto (metis option.inject)

    define vP where "vP k v \<longleftrightarrow> (\<exists>k' v'. m1.\<alpha> m k' = Some v' \<and> f (k', v') = Some (k, v))" for k v
    have vP_intro: "\<And>k v. (\<exists>k' v'. m1.\<alpha> m k' = Some v'
        \<and> f (k', v') = Some (k, v)) \<longleftrightarrow> vP k v"
      unfolding vP_def by simp
    { fix k v
      have "Eps_Opt (vP k) = Some v \<longleftrightarrow> vP k v"
        using unique_f unfolding vP_def transforms_to_unique_keys_def
        apply (rule_tac Eps_Opt_eq_Some)
        apply (metis prod.inject option.inject)
      done
    } note Eps_vP_elim[simp] = this
    have map_intro: "{y. \<exists>x. x \<in> map_to_set (m1.\<alpha> m) \<and> f x = Some y}
      = map_to_set (\<lambda>k. Eps_Opt (vP k))"
      by (simp add: map_to_set_def vP_intro set_eq_iff split: prod.splits)

    from set_iterator_image_filter_correct [OF iti_m, OF inj_on_f,
      unfolded map_intro]
    have iti_filter: "map_iterator (set_iterator_image_filter f (m1.iteratei m))
          (\<lambda>k. Eps_Opt (vP k))" by auto

    have upd: "map_update_dj m2.\<alpha> m2.invar m2.update_dj" by unfold_locales
    have emp: "map_empty m2.\<alpha> m2.invar m2.empty" by unfold_locales

    from iterate_to_map_correct[OF upd emp iti_filter] show
      "map_op_invar ops2 (g_image_filter f m) \<and>
          (map_op_\<alpha> ops2 (g_image_filter f m) k' = Some v') =
          (\<exists>k v. map_op_\<alpha> ops1 m k = Some v \<and> f (k, v) = Some (k', v'))"
      unfolding A vP_def[symmetric]
      by (simp add: vP_intro)

  qed
end

sublocale g_image_filter_loc
  < map_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_image_filter
  by (rule g_image_filter_impl)

locale g_value_image_filter_defs_loc =
  m1: StdMapDefs ops1 +
  m2: StdMapDefs ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  definition "g_value_image_filter f m1 \<equiv> m1.iterate m1 (\<lambda>(k,v) \<sigma>.
    case f k v of
      None => \<sigma>
    | Some v' => m2.update_dj k v' \<sigma>
    ) (m2.empty ())"

end

(* TODO: Move to Misc *)
lemma restrict_map_dom_subset: "\<lbrakk> dom m \<subseteq> R\<rbrakk> \<Longrightarrow> m|`R = m"
  apply (rule ext)
  apply (auto simp: restrict_map_def)
  apply (case_tac "m x")
  apply auto
  done

locale g_value_image_filter_loc = g_value_image_filter_defs_loc ops1 ops2 +
  m1: StdMap ops1 +
  m2: StdMap ops2
  for ops1 :: "('k,'v1,'s1,'m1) map_ops_scheme"
  and ops2 :: "('k,'v2,'s2,'m2) map_ops_scheme"
begin
  lemma g_value_image_filter_impl:
    "map_value_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_value_image_filter"
    apply unfold_locales
    unfolding g_value_image_filter_def
    apply (rule_tac I="\<lambda>it \<sigma>. m2.invar \<sigma>
      \<and> m2.\<alpha> \<sigma> = (\<lambda>k. Option.bind (map_op_\<alpha> ops1 m k) (f k)) |` it"
      in m1.old_iterate_rule_insert_P)

    apply auto []
    apply (auto simp: m2.empty_correct) []
    defer
    apply simp []
    apply (rule restrict_map_dom_subset)
    apply (auto) []
    apply (case_tac "m1.\<alpha> m x")
    apply (auto) [2]

    apply (auto split: option.split simp: m2.update_dj_correct intro!: ext)
    apply (auto simp: restrict_map_def)
    done
end

sublocale g_value_image_filter_loc
  < map_value_image_filter m1.\<alpha> m1.invar m2.\<alpha> m2.invar g_value_image_filter
  by (rule g_value_image_filter_impl)

end


theory Proof_1_12
  imports Proofs_1
begin

theorem proof_1_12: "VC12 inv1 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC12_def inv1_def R1_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply ((drule conjE)+)
                      prefer 36
                      apply assumption
                      prefer 35
                      apply assumption
                       prefer 34
                        apply assumption
                        prefer 33
                        apply assumption
                        prefer 32
                        apply assumption
                        prefer 31
                        apply assumption
                        prefer 30
                        apply assumption
                        prefer 29
                        apply assumption
                        prefer 28
                        apply assumption
                        prefer 27
                        apply assumption
                        prefer 26
                        apply assumption
                        prefer 25
                        apply assumption
                        prefer 24
                        apply assumption
                        prefer 23
                        apply assumption
                        prefer 22
                        apply assumption
                        prefer 21
                        apply assumption
                        prefer 20
                        apply assumption
                       prefer 19
                       apply assumption
                      prefer 18
                      apply assumption
                     prefer 17
                     apply assumption
                    prefer 16
                    apply assumption
                   prefer 15
                   apply assumption
                  prefer 14
                  apply assumption
                 prefer 13
                 apply assumption
                prefer 12
                apply assumption
               prefer 11
               apply assumption
              prefer 10
              apply assumption
             prefer 9
             apply assumption
            prefer 8
            apply assumption
           prefer 7
           apply assumption
          prefer 6
          apply assumption
         prefer 5
         apply assumption
        prefer 4
        apply assumption
       prefer 3
       apply assumption
      prefer 2
    apply assumption
  subgoal premises prems for s1 s2
    thm prems(27)
    using prems(2-10) prems(12-14) prems(17) prems(19) prems(21-22)
    apply(simp split: if_splits)
    using substate_toEnvNum_id substate_refl prems
     apply (metis One_nat_def)
 using prems(15) by auto


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* License: BSD, terms see file ./LICENSE *)

(*
  Structures supporting CTypes.
  Primarily sets up types, defines pointers and the raw heap view.
*)

theory CTypesBase
imports
  "./$L4V_ARCH/Addr_Type"
  "~~/src/HOL/Library/Prefix_Order"
  "../../../lib/Word_Lib/Signed_Words"
begin

section "Type setup"

type_synonym byte = "8 word"

class unit_class =
  assumes there_is_only_one: "x = y"

instantiation unit :: unit_class
begin
instance by (intro_classes, simp)
end

subsection "Pointers"

datatype 'a ptr = Ptr addr

abbreviation
  NULL :: "'a ptr" where
  "NULL \<equiv> Ptr 0"

primrec
  ptr_val :: "'a ptr \<Rightarrow> addr"
where
  ptr_val_def: "ptr_val (Ptr a) = a"

primrec
  ptr_coerce :: "'a ptr \<Rightarrow> 'b ptr" where
  "ptr_coerce (Ptr a) = Ptr a"

definition
  (* no ctype/memtype-class constraints on these so as to allow comparison of
     void * pointers, which are represented as Isabelle type unit ptr *)
  ptr_less :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "<\<^sub>p" 50) where
  "p <\<^sub>p q \<equiv> ptr_val p < ptr_val q"

definition
  ptr_le :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "\<le>\<^sub>p" 50) where
  "p \<le>\<^sub>p q \<equiv> ptr_val p \<le> ptr_val q"

instantiation ptr :: (type) ord
begin

definition
  ptr_less_def': "p < q \<equiv> p <\<^sub>p q"
definition
  ptr_le_def': "p \<le> q \<equiv> p \<le>\<^sub>p q"

instance ..

end

lemma ptr_val_case: "ptr_val p = (case p of Ptr v \<Rightarrow> v)"
  by (cases p) simp

instantiation ptr :: (type) linorder
begin
instance
  by (intro_classes)
     (unfold ptr_le_def' ptr_le_def ptr_less_def' ptr_less_def ptr_val_case,
      auto split: ptr.splits)
end

subsection "Raw heap"

text {* A raw map from addresses to bytes *}

type_synonym heap_mem = "addr \<Rightarrow> byte"

text {* For heap h, pointer p and nat n, (heap_list h n p) returns the list
        of bytes in the heap taken from addresses {p..+n} *}

primrec
  heap_list :: "heap_mem \<Rightarrow> nat \<Rightarrow> addr \<Rightarrow> byte list"
where
  heap_list_base: "heap_list h 0 p = []"
| heap_list_rec:  "heap_list h (Suc n) p = h p # heap_list h n (p + 1)"

section "Intervals"

text {*
  For word a and nat b, {a..+b} is the set of words x,
  with unat (x - a) < b. *}

definition
  intvl :: "'a::len word \<times> nat \<Rightarrow> 'a::len word set" where
  "intvl x \<equiv> {z. \<exists>k. z = fst x + of_nat k \<and> k < snd x}"

abbreviation
  "intvl_abbr" :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" ("{_..+_}") where
  "{a..+b} \<equiv> intvl (a,b)"

section "dt_pair: a reimplementation of 2 item tuples"

datatype (plugins del: size)
    ('a,'b) dt_pair = DTPair 'a 'b

primrec
  dt_fst :: "('a,'b) dt_pair \<Rightarrow> 'a"
where
  "dt_fst (DTPair a b) = a"

primrec
  dt_snd :: "('a,'b) dt_pair \<Rightarrow> 'b"
where
  "dt_snd (DTPair a b) = b"

type_synonym normalisor = "byte list \<Rightarrow> byte list"

section "Properties of pointers"

lemma Ptr_ptr_val [simp]:
  "Ptr (ptr_val p) = p"
  by (case_tac p) simp

lemma ptr_val_ptr_coerce [simp]:
  "ptr_val (ptr_coerce p) = ptr_val p"
  by (case_tac p) simp

lemma Ptr_ptr_coerce [simp]:
  "Ptr (ptr_val p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_coerce_id [simp]:
  "ptr_coerce p = p"
  by (case_tac p) simp

lemma ptr_coerce_idem [simp]:
  "ptr_coerce (ptr_coerce p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_val_inj [simp]:
  "(ptr_val p = ptr_val q) = (p = q)"
  by (case_tac p, case_tac q) auto

lemma ptr_coerce_NULL [simp]:
  "(ptr_coerce p = NULL) = (p = NULL)"
  by (case_tac p) simp

lemma NULL_ptr_val:
  "(p = NULL) = (ptr_val p = 0)"
  by (case_tac p) simp

instantiation ptr :: (type) finite
begin
instance
  by (intro_classes)
     (auto intro!: finite_code finite_imageD [where f=ptr_val] injI)
end

section "Properties of the raw heap"

lemma heap_list_length [simp]:
  "length (heap_list h n p) = n"
  by (induct n arbitrary: p) auto

lemma heap_list_split:
  shows "k \<le> n \<Longrightarrow> heap_list h n x = heap_list h k x @ heap_list h (n - k) (x + of_nat k)"
proof (induct n arbitrary: k x)
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case
    by (cases k, auto simp: ac_simps)
qed

lemma heap_list_split2:
  "heap_list h (x + y) p = heap_list h x p @ heap_list h y (p + of_nat x)"
  by (subst heap_list_split [where k=x], auto)

section "Properties of intervals"

lemma intvlI:
  "x < n \<Longrightarrow> p + of_nat x \<in> {p..+n}"
  by (force simp: intvl_def)

lemma intvlD:
  "q \<in> {p..+n} \<Longrightarrow> \<exists>k. q = p + of_nat k \<and> k < n"
  by (force simp: intvl_def)

lemma intvl_empty [simp]:
  "{p..+0} = {}"
  by (fast dest: intvlD)

lemma intvl_Suc:
  "q \<in> {p..+Suc 0} \<Longrightarrow> p = q"
  by (force dest: intvlD)

lemma intvl_self:
  "0 < n \<Longrightarrow> x \<in> {x..+n}"
  by (force simp: intvl_def)

lemma intvl_start_inter:
  "\<lbrakk> 0 < m; 0 < n \<rbrakk> \<Longrightarrow> {p..+m} \<inter> {p..+n} \<noteq> {}"
  by (force simp: disjoint_iff_not_equal dest: intvl_self)

lemma intvl_overflow:
  assumes "2^len_of TYPE('a) \<le> n"
  shows "{(p::'a::len word)..+n} = UNIV"
proof -
  have witness:
    "\<And>x. x = p + of_nat (unat (x - p)) \<and> unat (x - p) < n"
    using assms by simp unat_arith
  show ?thesis unfolding intvl_def by (auto intro!: witness)
qed

declare of_nat_diff [simp]

lemma intvl_self_offset:
  fixes p::"'a::len word"
  assumes a: "2^len_of TYPE('a) - n < x" and b: "x < 2^len_of TYPE('a)" and
      c: "(p::'a::len word) \<notin> {p + of_nat x..+n}"
  shows False
proof -
  let ?j = "2^len_of TYPE('a) - x"
  from b have b': "of_nat x + of_nat ?j  = (0::'a::len word)" using of_nat_2p by auto
  moreover from a b have "?j < n" by arith
  with b b' c show  ?thesis by (force simp: intvl_def)
qed

lemma intvl_mem_offset:
  "\<lbrakk> q \<in> {p..+unat x}; q \<notin> {p..+unat y}; unat y \<le> unat x \<rbrakk> \<Longrightarrow>
      q \<in> {p + y..+unat x - unat y}"
  by (clarsimp simp: intvl_def) (rule_tac x="k - unat y" in exI, auto)

lemma intvl_plus_sub_offset:
  "x \<in> {p + y..+q - unat y} \<Longrightarrow> x \<in> {p..+q}"
  by (clarsimp simp: intvl_def) (rule_tac x="k + unat y" in exI, auto)

lemma intvl_plus_sub_Suc:
  "x \<in> {p + 1..+q - Suc 0} \<Longrightarrow> x \<in> {p..+q}"
  by (rule intvl_plus_sub_offset [where y=1], simp)

lemma intvl_neq_start:
  "\<lbrakk> (q::'a::len word) \<in> {p..+n}; p \<noteq> q \<rbrakk> \<Longrightarrow> q \<in> {p + 1..+n - Suc 0}"
  by (clarsimp simp: intvl_def)
     (metis (no_types) Suc_diff_1 add.commute add_Suc_right diff_diff_left neq0_conv
                       of_nat_Suc semiring_1_class.of_nat_0 zero_less_diff)

lemmas unat_simps' =
  word_arith_nat_defs word_unat.eq_norm len_of_addr_card mod_less

lemma intvl_offset_nmem:
  "\<lbrakk> q \<in> {(p::'a::len word)..+unat x}; y \<le>  2^len_of TYPE('a) - unat x \<rbrakk> \<Longrightarrow>
      q \<notin> {p + x..+y}"
  apply (clarsimp simp: intvl_def)
  apply (simp only: unat_simps')
  apply (subst (asm) word_unat.Abs_inject)
    apply (auto simp: unats_def)
  done

lemma intvl_Suc_nmem' [simp]:
  "n < 2^len_of TYPE('a) \<Longrightarrow> (p::'a::len word) \<notin> {p + 1..+n - Suc 0}"
  by (clarsimp simp: intvl_def)
     (unat_arith, simp only: unat_simps')

lemma intvl_start_le:
  "x \<le> y \<Longrightarrow> {p..+x} \<subseteq> {p..+y}"
  by (force simp: intvl_def)

lemma intvl_sub_eq:
  assumes "x \<le> y"
  shows "{p + x..+unat (y - x)} = {p..+unat y} - {p..+unat x}"
proof -
  have "unat y - unat x \<le> 2 ^ len_of TYPE('a) - unat x"
    by (insert unat_lt2p [of y], arith)
  moreover have "x \<le> y" by fact
  moreover hence "unat (y - x) = unat y - unat x"
    by (simp add: word_le_nat_alt, unat_arith)
  ultimately show ?thesis
    by (force dest: intvl_offset_nmem intvl_mem_offset elim: intvl_plus_sub_offset
              simp: word_le_nat_alt)

qed

end


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

theory SPRViewSingle
imports
  KBPsAlg
  SPRView
  List_local
  ODList
  Trie2
  "HOL-Library.Mapping"
begin
(*>*)

subsection\<open>Perfect Recall for a Single Agent\<close>

text\<open>

\label{sec:kbps-spr-single-agent}

We capture our expectations of a single-agent scenario in the
following locale:

\<close>

locale FiniteSingleAgentEnvironment =
  FiniteEnvironment jkbp envInit envAction envTrans envVal envObs
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "('s :: {finite, linorder}) 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"
+ fixes agent :: "'a"
  assumes envSingleAgent: "a = agent"

text\<open>

As per the clock semantics of \S\ref{sec:kbps-theory-clock-view}, we
assume that the set of states is finite and linearly ordered. We give
the sole agent the name \<open>agent\<close>.

Our simulation is quite similar to the one for the clock semantics of
\S\ref{sec:kbps-theory-clock-view}: it records the set of worlds that
the agent considers possible relative to a trace and the SPR view. The
key difference is that it is path-sensitive:

\<close>

context FiniteSingleAgentEnvironment
begin

definition spr_abs :: "'s Trace \<Rightarrow> 's set" where
  "spr_abs t \<equiv>
    tLast ` { t' \<in> SPR.jkbpC . spr_jview agent t' = spr_jview agent t }"

type_synonym (in -) 's spr_simWorlds = "'s set \<times> 's"

definition spr_sim :: "'s Trace \<Rightarrow> 's spr_simWorlds" where
  "spr_sim \<equiv> \<lambda>t. (spr_abs t, tLast t)"
(*<*)

lemma spr_absI[elim]:
  "\<lbrakk> t' \<in> SPR.jkbpC; spr_jview a t' = spr_jview a t; v = tLast t' \<rbrakk>
    \<Longrightarrow> v \<in> spr_abs t"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by blast

lemma spr_abs_tLastD[simp]:
  "v \<in> spr_abs t \<Longrightarrow> envObs a v = envObs a (tLast t)"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_abs_conv:
  "v \<in> spr_abs t
    \<longleftrightarrow> (\<exists>t'. t' \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t \<and> v = tLast t')"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by blast

lemma spr_abs_eq[dest]:
  "spr_jview a t = spr_jview a t' \<Longrightarrow> spr_abs t = spr_abs t'"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_abs_refl[intro, simp]:
  "t \<in> SPR.jkbpC \<Longrightarrow> tLast t \<in> spr_abs t"
  unfolding spr_abs_def
  using envSingleAgent[where a=a] by auto

lemma spr_sim_simps[simp]:
  "fst (spr_sim t) = spr_abs t"
  unfolding spr_sim_def by simp

(*>*)
text\<open>

The Kripke structure for this simulation relates worlds for @{term
"agent"} if the sets of states it considers possible coincide, and the
observation of the final states of the trace is the same. Propositions
are evaluated at the final state.

\<close>

definition spr_simRels :: "'a \<Rightarrow> 's spr_simWorlds Relation" where
  "spr_simRels \<equiv> \<lambda>a. { ((U, u), (V, v)) |U u V v.
                         U = V \<and> {u, v} \<subseteq> U \<and> envObs a u = envObs a v }"

definition spr_simVal :: "'s spr_simWorlds \<Rightarrow> 'p \<Rightarrow> bool" where
  "spr_simVal \<equiv> envVal \<circ> snd"

abbreviation spr_simMC :: "('a, 'p, 's spr_simWorlds) KripkeStructure" where
  "spr_simMC \<equiv> mkKripke (spr_sim ` SPR.jkbpC) spr_simRels spr_simVal"
(*<*)

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

lemma spr_sim_r:
  "sim_r SPR.MC spr_simMC spr_sim"
proof
  fix a t v'
  assume t: "t \<in> worlds SPR.MC"
     and tv': "(spr_sim t, v') \<in> relations spr_simMC a"
  from tv' obtain s
    where vv': "v' = (spr_abs t, s)"
      and st: "s \<in> spr_abs t"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by auto
  from st obtain v
    where "v \<in> SPR.jkbpC"
      and "spr_jview a v = spr_jview a t"
      and "tLast v = s"
    by (auto(*<*)iff: spr_abs_conv(*>*))
  with t vv'
  have "(t, v) \<in> relations SPR.MC a"
   and "spr_sim v = v'"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by auto
  thus "\<exists>v. (t, v) \<in> relations SPR.MC a \<and> spr_sim v = v'" by blast
qed

(*>*)
text\<open>

Demonstrating that this is a simulation
(\S\ref{sec:kripke-theory-simulations}) is straightforward.

\<close>

lemma spr_sim: "sim SPR.MC spr_simMC spr_sim"
(*<*)
proof
  show "sim_f SPR.MC spr_simMC spr_sim"
    unfolding spr_simRels_def spr_sim_def mkKripke_def SPR.mkM_def
    by (rule) auto
next
  show "sim_r SPR.MC spr_simMC spr_sim"
    by (rule spr_sim_r)
qed auto

(*>*)
text\<open>\<close>
end (* context FiniteSingleAgentEnvironment *)

sublocale FiniteSingleAgentEnvironment
        < SPRsingle: SimIncrEnvironment jkbp envInit envAction envTrans envVal
                                       spr_jview envObs spr_jviewInit spr_jviewIncr
                                       spr_sim spr_simRels spr_simVal
(*<*)
  by standard (rule spr_sim)
(*>*)

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

subsubsection\<open>Representations\<close>

text\<open>

\label{sec:kbps-theory-spr-single-rep}

As in \S\ref{sec:kbps-theory-clock-view-algops}, we quotient @{typ "'s
spr_simWorlds"} by @{term "spr_simRels"}. Because there is only a
single agent, an element of this quotient corresponding to a cononical
trace @{term "t"} is isomorphic to the set of states that are possible
given the sequence of observations made by @{term "agent"} on @{term
"t"}. Therefore we have a very simple representation:

\<close>

context FiniteSingleAgentEnvironment
begin

type_synonym (in -) 's spr_simWorldsRep = "'s odlist"

text\<open>

It is very easy to map these representations back to simulated
equivalence classes:

\<close>

definition
  spr_simAbs :: "'s spr_simWorldsRep \<Rightarrow> 's spr_simWorlds set"
where
  "spr_simAbs \<equiv> \<lambda>ss. { (toSet ss, s) |s. s \<in> toSet ss }"

text\<open>

This time our representation is unconditionally canonical:

\<close>

lemma spr_simAbs_inj: "inj spr_simAbs"
(*<*)
  apply (rule injI)
  unfolding spr_simAbs_def
  apply (subgoal_tac "toSet x = toSet y")
  apply auto
  using toSet_inj
  apply (erule injD)
  done

lemma spr_sim_rep_abs[simp]:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "toSet ec = spr_abs t"
proof
  show "toSet ec \<subseteq> spr_abs t"
  proof
    fix x assume x: "x \<in> toSet ec"
    hence "(toSet ec, x) \<in> spr_simAbs ec"
      unfolding spr_simAbs_def by simp
    with ec have "(toSet ec, x) \<in> SPRsingle.sim_equiv_class a t"
      by simp
    with x envSingleAgent[where a=a] show "x \<in> spr_abs t"
      unfolding spr_sim_def spr_abs_def by auto
  qed
next
  show "spr_abs t \<subseteq> toSet ec"
  proof
    fix x assume x: "x \<in> spr_abs t"
    with ec envSingleAgent[where a=a] show "x \<in> toSet ec"
      unfolding spr_simAbs_def spr_sim_def spr_abs_def by auto
  qed
qed

lemma spr_sim_rep_abs_syn[simp]:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (toList ec) = spr_abs t"
  using spr_sim_rep_abs[OF ec] unfolding toSet_def by simp

lemma spr_simAbs_list:
  "spr_simAbs ` fromList ` X = (\<lambda>ss. { (ss, s) |s. s \<in> ss }) ` set ` X"
  unfolding spr_simAbs_def Set.image_def by auto

(*>*)
text\<open>

We again make use of the following Kripke structure, where the worlds
are the final states of the subset of the temporal slice that @{term
"agent"} believes possible:

\<close>

definition spr_repRels :: "'a \<Rightarrow> ('s \<times> 's) set" where
  "spr_repRels \<equiv> \<lambda>a. { (s, s'). envObs a s' = envObs a s }"

abbreviation spr_repMC :: "'s set \<Rightarrow> ('a, 'p, 's) KripkeStructure" where
  "spr_repMC \<equiv> \<lambda>X. mkKripke X spr_repRels envVal"

text\<open>

Similarly we show that this Kripke structure is adequate by
introducing an intermediate structure and connecting them all with a
tower of simulations:

\<close>

abbreviation spr_jkbpCSt :: "'s Trace \<Rightarrow> 's spr_simWorlds set" where
  "spr_jkbpCSt t \<equiv> SPRsingle.sim_equiv_class agent t"

abbreviation
  spr_simMCt :: "'s Trace \<Rightarrow> ('a, 'p, 's spr_simWorlds) KripkeStructure"
where
  "spr_simMCt t \<equiv> mkKripke (spr_jkbpCSt t) spr_simRels spr_simVal"

definition spr_repSim :: "'s spr_simWorlds \<Rightarrow> 's" where
  "spr_repSim \<equiv> snd"
(*<*)

lemma spr_repMC_kripke[intro, simp]: "kripke (spr_repMC X)"
  by (rule kripkeI) simp

lemma spr_repMC_S5n[intro, simp]: "S5n (spr_repMC X)"
  unfolding spr_repRels_def
  by (intro S5nI equivI refl_onI symI transI) auto

lemma jkbpCSt_jkbpCS_subset:
  "SPRsingle.sim_equiv_class agent t \<subseteq> spr_sim ` SPR.jkbpC"
  by auto

lemma spr_simRep_sim_simps[simp]:
  "spr_repSim ` spr_sim ` T = tLast ` T"
  "spr_repSim (spr_sim t) = tLast t"
  unfolding spr_repSim_def spr_sim_def Set.image_def by auto

(*>*)
text\<open>\<close>

lemma spr_repSim:
  assumes tC: "t \<in> SPR.jkbpC"
  shows "sim (spr_simMCt t)
             ((spr_repMC \<circ> fst) (spr_sim t))
             spr_repSim"
(*<*) (is "sim ?M ?M' ?f")
proof
  show "sim_range ?M ?M' ?f"
  proof
    show "worlds ?M' = ?f ` worlds ?M"
      unfolding spr_sim_def spr_repSim_def spr_abs_def Set.image_def
      by auto
  next
    fix a
    show "relations ?M' a \<subseteq> worlds ?M' \<times> worlds ?M'"
      unfolding spr_sim_def spr_repSim_def by simp
  qed
next
  show "sim_val ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def by auto
next
  from tC
  show "sim_f ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def
    apply -
    apply rule
    apply (cut_tac a=a in envSingleAgent)
    apply (auto iff: spr_sim_def spr_repRels_def)
    apply (rule spr_tLast)
    apply auto
    done
next
  show "sim_r ?M ?M' ?f"
    unfolding spr_sim_def spr_simVal_def spr_repSim_def
    apply -
    apply rule
    apply (cut_tac a=a in envSingleAgent)
    unfolding spr_abs_def spr_sim_def spr_repRels_def spr_simRels_def Set.image_def
    apply auto
    done
qed

(*>*)
text\<open>

As before, the following sections discharge the requirements of the
\<open>Algorithm\<close> locale of Figure~\ref{fig:kbps-alg-alg-locale}.

\<close>

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

subsubsection\<open>Initial states\<close>

text\<open>

The initial states of the automaton for @{term "agent"} is simply the
partition of @{term "envInit"} under @{term "agent"}'s observation.

\<close>

definition (in -)
  spr_simInit :: "('s :: linorder) list \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                     \<Rightarrow> 'a \<Rightarrow> 'obs \<Rightarrow> 's spr_simWorldsRep"
where
  "spr_simInit envInit envObs \<equiv> \<lambda>a iobs.
    ODList.fromList [ s. s \<leftarrow> envInit, envObs a s = iobs ]"
(*<*)

abbreviation
  spr_simInit :: "'a \<Rightarrow> 'obs \<Rightarrow> 's spr_simWorldsRep"
where
  "spr_simInit \<equiv> SPRViewSingle.spr_simInit envInit envObs"

(*>*)
text\<open>\<close>

lemma spr_simInit:
  assumes "iobs \<in> envObs a ` set envInit"
  shows "spr_simAbs (spr_simInit a iobs)
       = spr_sim ` { t' \<in> SPR.jkbpC. spr_jview a t' = spr_jviewInit a iobs }"
(*<*)
  using assms
  unfolding spr_simInit_def
  using envSingleAgent[where a=a]
  unfolding spr_simAbs_def spr_sim_def [abs_def] spr_abs_def
  apply (auto iff: spr_jview_def SPR.jviewInit)
   apply (rule_tac x="tInit s" in image_eqI)
    apply (auto iff: spr_jview_def)[1]
    apply (rule_tac x="tInit xa" in image_eqI)
    apply auto[1]
   apply simp
   apply simp
  apply (rule_tac x="tInit xb" in image_eqI)
  apply auto
  done
(*>*)

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

subsubsection\<open>Simulated observations\<close>

text\<open>

As the agent makes the same observation on the entire equivalence
class, we arbitrarily choose the first element of the representation:

\<close>

definition (in -)
  spr_simObs :: "('a \<Rightarrow> 's \<Rightarrow> 'obs)
               \<Rightarrow> 'a \<Rightarrow> ('s :: linorder) spr_simWorldsRep \<Rightarrow> 'obs"
where
  "spr_simObs envObs \<equiv> \<lambda>a. envObs a \<circ> ODList.hd"
(*<*)

abbreviation
  spr_simObs :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'obs"
where
  "spr_simObs \<equiv> SPRViewSingle.spr_simObs envObs"

(*>*)
text\<open>\<close>

lemma spr_simObs:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "spr_simObs a ec = envObs a (tLast t)"
(*<*)
proof -
  have A: "\<forall>s \<in> set (toList ec). envObs a s = envObs a (tLast t)"
    using spr_sim_rep_abs[OF ec] by (simp add: toSet_def)
  from tC ec have B: "tLast t \<in> set (toList ec)"
    using envSingleAgent[where a=a] by simp
  show ?thesis
    unfolding spr_simObs_def
    by (simp add: list_choose_hd[OF A B] ODList.hd_def)
qed
(*>*)

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

subsubsection\<open>Evaluation\<close>

text\<open>

\label{sec:kbps-spr-single-agent-eval}

As the single-agent case is much simpler than the multi-agent ones, we
define an evaluation function specialised to its representation.

Intuitively @{term "eval"} yields the subset of @{term "X"} where the
formula holds, where @{term "X"} is taken to be a representation of a
canonical equivalence class for @{term "agent"}.

\<close>

fun (in -)
  eval :: "(('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
        \<Rightarrow> 's odlist \<Rightarrow> ('a, 'p) Kform \<Rightarrow> 's odlist"
where
  "eval val X (Kprop p)      = ODList.filter (\<lambda>s. val s p) X"
| "eval val X (Knot \<phi>)       = ODList.difference X (eval val X \<phi>)"
| "eval val X (Kand \<phi> \<psi>)     = ODList.intersect (eval val X \<phi>) (eval val X \<psi>)"
| "eval val X (Kknows a \<phi>)   = (if eval val X \<phi> = X then X else ODList.empty)"
| "eval val X (Kcknows as \<phi>) =
                     (if as = [] \<or> eval val X \<phi> = X then X else ODList.empty)"

text\<open>

In general this is less efficient than the tableau approach of
\citet[Proposition~3.2.1]{FHMV:1995}, which labels all states with all
formulas. However it is often the case that the set of relevant worlds
is much smaller than the set of all system states.

Showing that this corresponds with the standard models relation is
routine.

\<close>
(*<*)

lemma eval_ec_subseteq:
  shows "toSet (eval envVal ec \<phi>) \<subseteq> toSet ec"
  by (induct \<phi>) auto

lemma eval_models_aux:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  assumes s: "s \<in> toSet ec"
  shows "s \<in> toSet (eval envVal ec \<phi>) \<longleftrightarrow> spr_repMC (toSet ec), s \<Turnstile> \<phi>"
using s
proof(induct \<phi> arbitrary: s)
  case (Kknows a \<phi> s) with ec envSingleAgent[where a=a] show ?case
    unfolding spr_repRels_def
    by (auto simp: inj_eq[OF toSet_inj, symmetric] dest: subsetD[OF eval_ec_subseteq])
next
  case (Kcknows as \<phi> s)
  from ec show ?case
  proof(cases as)
    case Nil with Kcknows show ?thesis by clarsimp
  next
    case (Cons x xs)
    hence "set as = {agent}"
      by (induct as) (auto simp: envSingleAgent)
    moreover
    have "(spr_repRels agent \<inter> toSet ec \<times> toSet ec)\<^sup>+ = (spr_repRels agent \<inter> toSet ec \<times> toSet ec)"
      by (rule trancl_id) (simp add: spr_repRels_def trans_def)
    moreover note Kcknows ec
    ultimately show ?thesis
      unfolding spr_repRels_def
      by (auto simp: inj_eq[OF toSet_inj, symmetric] dest: subsetD[OF eval_ec_subseteq])
  qed
qed simp_all

lemma eval_all_or_nothing:
  assumes subj_phi: "subjective agent \<phi>"
  shows "toSet (eval envVal ec \<phi>) = {} \<or> toSet (eval envVal ec \<phi>) = toSet ec"
  using subj_phi by (induct \<phi> rule: subjective.induct) auto
(*>*)

lemma eval_models:
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  assumes subj: "subjective agent \<phi>"
  assumes s: "s \<in> toSet ec"
  shows "toSet (eval envVal ec \<phi>) \<noteq> {} \<longleftrightarrow> spr_repMC (toSet ec), s \<Turnstile> \<phi>"
(*<*)
  using eval_models_aux[OF ec s, symmetric] eval_all_or_nothing[OF subj] s
  by auto
(*>*)

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

subsubsection\<open>Simulated actions\<close>

text\<open>

The actions enabled on a canonical equivalence class are those for
which @{term "eval"} yields a non-empty set of states:

\<close>

definition (in -)
  spr_simAction :: "('a, 'p, 'aAct) KBP \<Rightarrow> (('s :: linorder) \<Rightarrow> 'p \<Rightarrow> bool)
                     \<Rightarrow> 'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'aAct list"
where
  "spr_simAction kbp envVal \<equiv> \<lambda>a X.
    [ action gc. gc \<leftarrow> kbp, eval envVal X (guard gc) \<noteq> ODList.empty ]"
(*<*)

abbreviation
  spr_simAction :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 'aAct list"
where
  "spr_simAction \<equiv> SPRViewSingle.spr_simAction (jkbp agent) envVal"

(*>*)
text\<open>

The key lemma relates the agent's behaviour on an equivalence class to
that on its representation:

\<close>

lemma spr_simAction_jAction:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (spr_simAction agent ec)
       = set (jAction (spr_repMC (toSet ec)) (tLast t) agent)"
(*<*)
proof -
  have "\<And>P. (set (jkbp agent) \<inter> {gc. P gc})
      = { gc \<in> set (jkbp agent). P gc }"
    by blast
  then
  show ?thesis
    unfolding spr_simAction_def jAction_def
    apply clarsimp
    apply (rule SUP_cong)
     apply simp_all
     apply (rule Collect_cong)
     apply rule
      apply clarsimp
      apply (subst eval_models[OF ec, symmetric])
        apply (simp_all add: toSet_eq_iff)
       using subj tC ec
       apply (fastforce+)[2]
    apply clarsimp
    apply (subst (asm) eval_models[OF ec, symmetric])
    using subj tC ec
    apply fastforce+
    done (* FIXME improve *)
qed

lemma spr_submodel_aux:
  assumes tC: "t \<in> SPR.jkbpC"
      and s: "s \<in> worlds (spr_simMCt t)"
  shows "gen_model SPRsingle.MCS s = gen_model (spr_simMCt t) s"
proof(rule gen_model_subset[where T="SPRsingle.sim_equiv_class agent t"])
  fix a
  let ?X = "SPRsingle.sim_equiv_class agent t"
  show "relations SPRsingle.MCS a \<inter> ?X \<times> ?X
      = relations (spr_simMCt t) a \<inter> ?X \<times> ?X"
    by (simp add: Int_ac Int_absorb1
                  relation_mono[OF jkbpCSt_jkbpCS_subset jkbpCSt_jkbpCS_subset])
next
  let ?X = "SPRsingle.sim_equiv_class agent t"
  from s show "(\<Union>a. relations (spr_simMCt t) a)\<^sup>* `` {s} \<subseteq> ?X"
    apply (clarsimp simp del: mkKripke_simps)
    apply (erule kripke_rels_trc_worlds)
    apply auto
    done
next
  let ?Y = "{ t' \<in> SPR.jkbpC . spr_jview agent t' = spr_jview agent t }"
  let ?X = "spr_sim ` ?Y"
  from s obtain t'
    where st': "s = spr_sim t'"
      and t'C: "t' \<in> SPR.jkbpC"
      and t'O: "spr_jview agent t = spr_jview agent t'"
    by fastforce
  { fix t''
    assume tt': "(t', t'') \<in> (\<Union>a. relations SPR.MC a)\<^sup>*"
    from t'C tt' have t''C: "t'' \<in> SPR.jkbpC"
      by - (erule kripke_rels_trc_worlds, simp_all)
    from tt' t'O have t''O: "spr_jview agent t = spr_jview agent t''"
      apply induct
      unfolding SPR.mkM_def
      apply auto
      apply (cut_tac a=x in envSingleAgent)
      apply simp
      done
    from t''C t''O have "t'' \<in> ?Y" by simp }
  hence "(\<Union>a. relations SPR.MC a)\<^sup>* `` {t'} \<subseteq> ?Y"
    by clarsimp
  hence "spr_sim ` ((\<Union>a. relations SPR.MC a)\<^sup>* `` {t'}) \<subseteq> ?X"
    by (rule image_mono)
  with st' t'C
  show "(\<Union>a. relations SPRsingle.MCS a)\<^sup>* `` {s} \<subseteq> ?X"
    using sim_trc_commute[OF SPR.mkM_kripke spr_sim, where t=t'] by simp
qed (insert s, auto)

(*>*)
text\<open>

The \<open>Algorithm\<close> locale requires the following lemma, which is
a straightforward chaining of the above simulations.

\<close>

lemma spr_simAction:
  assumes tC: "t \<in> SPR.jkbpC"
      and ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "set (spr_simAction a ec) = set (jAction SPR.MC t a)"
(*<*)
proof -
  from ec
  have ec': "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
    by (simp only: envSingleAgent[where a=a])
  have "set (spr_simAction a ec) = set (spr_simAction agent ec)"
    by (simp only: envSingleAgent[where a=a])
  also from tC ec' have "... = set (jAction (spr_repMC (toSet ec)) (tLast t) agent)"
    by (rule spr_simAction_jAction)
  also from tC ec' have "... = set (jAction (spr_simMCt t) (spr_sim t) agent)"
    by (simp add: simulation_jAction_eq[OF _ spr_repSim])
  also from tC have "... = set (jAction SPRsingle.MCS (spr_sim t) agent)"
    using gen_model_jAction_eq[OF spr_submodel_aux[OF tC, where s="spr_sim t"], where w'="spr_sim t"]
          gen_model_world_refl[where w="spr_sim t" and M="spr_simMCt t"]
    by simp
  also from tC have "... = set (jAction SPR.MC t agent)"
    by (simp add: simulation_jAction_eq[OF _ spr_sim])
  finally show ?thesis by (simp only: envSingleAgent[where a=a])
qed
(*>*)

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

subsubsection\<open>Simulated transitions\<close>

text\<open>

It is straightforward to determine the possible successor states of a
given canonical equivalence class @{term "X"}:

\<close>

definition (in -)
  spr_trans :: "('a, 'p, 'aAct) KBP
              \<Rightarrow> ('s \<Rightarrow> 'eAct list)
              \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
              \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
              \<Rightarrow> 'a \<Rightarrow> ('s :: linorder) spr_simWorldsRep \<Rightarrow> 's list"
where
  "spr_trans kbp envAction envTrans val \<equiv> \<lambda>a X.
    [ envTrans eact (\<lambda>a'. aact) s .
       s \<leftarrow> toList X, eact \<leftarrow> envAction s, aact \<leftarrow> spr_simAction kbp val a X ]"
(*<*)

abbreviation
  spr_trans :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's list"
where
  "spr_trans \<equiv> SPRViewSingle.spr_trans (jkbp agent) envAction envTrans envVal"

(*>*)
text\<open>

Using this function we can determine the set of possible successor
equivalence classes from @{term "X"}:

\<close>

abbreviation (in -) envObs_rel :: "('s \<Rightarrow> 'obs) \<Rightarrow> 's \<times> 's \<Rightarrow> bool" where
  "envObs_rel envObs \<equiv> \<lambda>(s, s'). envObs s' = envObs s"

definition (in -)
  spr_simTrans :: "('a, 'p, 'aAct) KBP
                 \<Rightarrow> (('s::linorder) \<Rightarrow> 'eAct list)
                 \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                 \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                 \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                 \<Rightarrow> 'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's spr_simWorldsRep list"
where
  "spr_simTrans kbp envAction envTrans val envObs \<equiv> \<lambda>a X.
    map ODList.fromList (partition (envObs_rel (envObs a))
                                   (spr_trans kbp envAction envTrans val a X))"
(*<*)

abbreviation
  spr_simTrans :: "'a \<Rightarrow> 's spr_simWorldsRep \<Rightarrow> 's spr_simWorldsRep list"
where
  "spr_simTrans \<equiv> SPRViewSingle.spr_simTrans (jkbp agent) envAction envTrans envVal envObs"

lemma envObs_rel_equiv:
  "equiv UNIV (rel_ext (envObs_rel (envObs agent)))"
  by (intro equivI refl_onI symI transI) auto

lemma spr_trans:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
  shows "set (spr_trans agent ec)
       = { s |t' s. t' \<leadsto> s \<in> SPR.jkbpC \<and> spr_jview agent t' = spr_jview agent t }" (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
  proof
    fix x assume x: "x \<in> ?lhs"
    with assms show "x \<in> ?rhs"
      unfolding spr_trans_def
      apply (clarsimp simp del: split_paired_Ex split_paired_All)
      apply (frule spr_sim_rep_abs)
      unfolding toSet_def
      apply clarsimp

      apply (simp only: spr_abs_conv[where a=agent])
      apply clarify

      apply (rule_tac x="t'" in exI)
      apply simp
      apply (rule_tac n="Suc (tLength t')" in SPR.jkbpCn_jkbpC_inc)
      apply (auto iff: Let_def simp del: split_paired_Ex split_paired_All)

      apply (rule_tac x=xa in exI)
      apply (rule_tac x="\<lambda>a'. aact" in exI)
      apply auto
      apply (subst envSingleAgent)
      apply (simp add: spr_simAction[where a=agent])
      apply (subst SPR.jkbpC_jkbpCn_jAction_eq[symmetric])
      apply auto
      apply (subst S5n_jAction_eq[where w'=t])
      apply simp_all
      unfolding SPR.mkM_def
      apply simp
      done
  qed
next
  show "?rhs \<subseteq> ?lhs"
  proof
    fix s assume s: "s \<in> ?rhs"
    then obtain t'
      where t'sC: "t' \<leadsto> s \<in> SPR.jkbpC"
        and tt': "spr_jview agent t' = spr_jview agent t"
      by blast
    from t'sC have t'Cn: "t' \<in> SPR.jkbpCn (tLength t')" by blast
    from t'sC 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 s: "s = envTrans eact aact (tLast t')"
      using SPR.jkbpC_tLength_inv[where t="t' \<leadsto> s" and n="Suc (tLength t')"]
      by (auto iff: Let_def)
    from tC ec s eact aact tt' t'sC
    show "s \<in> ?lhs"
      unfolding spr_trans_def
      apply (clarsimp)
      apply (rule bexI[where x="tLast t'"])
      apply (rule bexI[where x=eact])
      apply simp_all
       prefer 2
       apply (blast intro: spr_absI)
      apply (simp add: spr_simAction[where a=agent])
      apply (rule image_eqI[where x="aact agent"])
       apply (subgoal_tac "(\<lambda>a'. aact agent) = aact")
        apply simp
       apply (rule ext)
       apply (cut_tac a=a' in envSingleAgent)
       apply simp
      apply (erule allE[where x=agent])
      apply (subst SPR.jkbpC_jkbpCn_jAction_eq)
      apply auto
      apply (subst S5n_jAction_eq[where w=t and w'=t'])
        apply simp
       apply (unfold SPR.mkM_def)[1]
       apply simp
       apply (blast dest: SPR.sync[rule_format])
      apply (auto dest: SPR.sync[rule_format])
      done
  qed
qed

(*>*)
text\<open>

The \<open>partition\<close> function splits a list into equivalence
classes under the given equivalence relation.

The property asked for by the \<open>Algorithm\<close> locale follows from
the properties of \<open>partition\<close> and \<open>spr_trans\<close>:

\<close>

lemma spr_simTrans:
  assumes tC: "t \<in> SPR.jkbpC"
  assumes ec: "spr_simAbs ec = SPRsingle.sim_equiv_class a t"
  shows "spr_simAbs ` set (spr_simTrans a ec)
      = { SPRsingle.sim_equiv_class a (t' \<leadsto> s)
          |t' s. t' \<leadsto> s \<in> SPR.jkbpC \<and> spr_jview a t' = spr_jview a t}"
(*<*) (is "?lhs a = ?rhs a")
proof -
  from ec have ec': "spr_simAbs ec = SPRsingle.sim_equiv_class agent t"
    by (simp only: envSingleAgent[where a=a])
  from ec' have "?lhs agent = ?rhs agent"
    unfolding spr_simTrans_def
    apply clarsimp
    apply (simp only: spr_simAbs_list partition[OF envObs_rel_equiv subset_UNIV] spr_trans[OF tC ec'])
    apply clarsimp
    apply rule

     (* left to right *)

     apply clarsimp
     apply (erule quotientE)
     apply clarsimp
     apply (rule_tac x=t' in exI)
     apply (rule_tac x=x in exI)
     apply clarsimp
     apply rule
      apply clarsimp
      apply (rule_tac x="t'a \<leadsto> s" in image_eqI)
       apply (unfold spr_sim_def [abs_def] spr_abs_def)[1]
       apply clarsimp
       apply (auto iff: spr_jview_def)[1]
        apply (rule_tac x="t'c \<leadsto> xa" in image_eqI)
         apply simp
        apply simp
       apply (simp add: spr_jview_def)
     apply clarsimp
     apply (frule spr_jview_tStep_eq_inv)
     apply clarsimp
     apply (rule_tac x=s' in exI)
     apply (unfold spr_sim_def [abs_def] spr_abs_def)[1]
     apply clarsimp
     apply (auto iff: spr_jview_def)[1]
      apply (rule_tac x="t'b \<leadsto> xa" in image_eqI)
       apply simp
       apply simp

     (* right to left *)

     apply clarsimp
     apply (rule_tac x="spr_abs (t' \<leadsto> s)" in image_eqI)
      apply rule
       apply clarsimp
       apply (frule spr_jview_tStep_eq_inv)
       apply clarsimp
       apply (unfold spr_sim_def [abs_def])[1]
       apply clarsimp
       apply rule
        apply (erule spr_abs_eq)
       apply (erule spr_absI[where a=agent]) back
        apply simp
       apply simp
      apply clarsimp
      apply (simp only: spr_abs_conv[where a=agent])
      apply clarsimp
      apply (frule spr_jview_tStep_eq_inv)
      apply clarsimp
      apply (rule_tac x="t'' \<leadsto> s'" in image_eqI)
       apply (unfold spr_sim_def [abs_def])[1]
       apply clarsimp
       apply blast
      apply blast
     apply (rule_tac x=s in quotientI2)
      apply auto[1]
     apply rule
      apply clarsimp
      apply rule
       apply blast
      apply (cut_tac v=x and t="t' \<leadsto> s" in spr_abs_conv[where a=agent])
      apply clarsimp
      apply (frule spr_jview_tStep_eq_inv)
      apply clarsimp
      apply (rule_tac x=t'' in exI)
      apply (simp add: Let_def spr_jview_def)
     apply clarsimp
     apply (erule spr_absI[where a=agent]) back back
     apply (auto iff: spr_jview_def)
     done
   thus "?lhs a = ?rhs a" by (simp only: envSingleAgent[where a=a])
qed

(*>*)
text\<open>\<close>

end (* context FiniteSingleAgentEnvironment *)

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

subsubsection\<open>Maps\<close>

text\<open>

\label{sec:kbps-theory-spr-single-maps}

As in \S\ref{sec:kbps-theory-clock-view-maps}, we use a pair of tries
and an association list to handle the automata representation. Recall
that the keys of these tries are lists of system states.

\<close>

type_synonym ('s, 'obs) spr_trans_trie = "('s, ('obs, 's odlist) mapping) trie"
type_synonym ('s, 'aAct) spr_acts_trie = "('s, ('s, 'aAct) trie) trie"
(*<*)

definition
  trans_MapOps_lookup :: "('s::linorder, 'obs) spr_trans_trie
                        \<Rightarrow> 's odlist \<times> 'obs \<rightharpoonup> 's odlist"
where
  "trans_MapOps_lookup \<equiv> \<lambda>m k.
     Option.bind (trie_odlist_lookup m (fst k)) (\<lambda>m'. Mapping.lookup m' (snd k))"

definition
  trans_MapOps_update :: "'s odlist \<times> 'obs \<Rightarrow> ('s :: linorder) odlist
                        \<Rightarrow> ('s, ('obs, 's odlist) mapping) trie
                        \<Rightarrow> ('s, ('obs, 's odlist) mapping) trie"
where
  "trans_MapOps_update \<equiv> \<lambda>k v m.
     trie_odlist_update_with (fst k) m Mapping.empty
      (\<lambda>m. Mapping.update (snd k) v m)"

definition
  trans_MapOps :: "(('s :: linorder, ('obs, 's odlist) mapping) trie, 's odlist \<times> 'obs, 's odlist) MapOps"
where
  "trans_MapOps \<equiv>
     \<lparr> MapOps.empty = empty_trie,
       lookup = trans_MapOps_lookup,
       update = trans_MapOps_update \<rparr>"

lemma (in FiniteSingleAgentEnvironment) trans_MapOps[intro, simp]:
  "MapOps (\<lambda>k. (spr_simAbs (fst k), snd k)) (SPRsingle.jkbpSEC \<times> UNIV) trans_MapOps"
proof
  fix k show "MapOps.lookup trans_MapOps (MapOps.empty trans_MapOps) k = None"
    unfolding trans_MapOps_def trans_MapOps_lookup_def trie_odlist_lookup_def
    by (auto split: prod.split)
next
  fix e k k' M
  assume k: "(spr_simAbs (fst k), snd k) \<in> SPRsingle.jkbpSEC \<times> (UNIV :: 'z set)"
     and k': "(spr_simAbs (fst k'), snd k') \<in> SPRsingle.jkbpSEC \<times> (UNIV :: 'z set)"
  show "MapOps.lookup trans_MapOps (MapOps.update trans_MapOps k e M) k'
         = (if (spr_simAbs (fst k'), snd k') = (spr_simAbs (fst k), snd k)
             then Some e else MapOps.lookup trans_MapOps M k')"
  proof(cases "(spr_simAbs (fst k'), snd k') = (spr_simAbs (fst k), snd k)")
    case True hence "k = k'"
      using injD[OF spr_simAbs_inj] k k' by (auto iff: prod_eqI)
    thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
      by (simp add: lookup_trie_update_with lookup_update split: option.split prod.split)
  next
    case False thus ?thesis
      unfolding trans_MapOps_def trans_MapOps_lookup_def trans_MapOps_update_def trie_odlist_lookup_def trie_odlist_update_with_def
      by (auto simp: lookup_empty lookup_update_neq lookup_trie_update_with split: option.split prod.split)
  qed
qed

(*>*)

subsubsection\<open>Locale instantiation\<close>

text\<open>

The above is sufficient to instantiate the @{term "Algorithm"} locale.

\<close>

sublocale FiniteSingleAgentEnvironment
        < SPRsingle: Algorithm
            jkbp envInit envAction envTrans envVal
            spr_jview envObs spr_jviewInit spr_jviewIncr
            spr_sim spr_simRels spr_simVal
            spr_simAbs spr_simObs spr_simInit spr_simTrans spr_simAction
            trie_odlist_MapOps trans_MapOps
(*<*)
  apply (unfold_locales)

  using spr_simInit
  apply auto[1]

  using spr_simObs
  apply auto[1]

  using spr_simAction
  apply blast

  using spr_simTrans
  apply blast

  apply (rule trie_odlist_MapOps[OF subset_inj_on[OF spr_simAbs_inj subset_UNIV]])
  apply (rule trans_MapOps)

  done

definition
  mkSPRSingleAuto :: "('a, 'p, 'aAct) KBP
                    \<Rightarrow> ('s :: linorder) list
                    \<Rightarrow> ('s \<Rightarrow> 'eAct list)
                    \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                    \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                    \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                    \<Rightarrow> 'a \<Rightarrow> ('obs, 'aAct, 's odlist) Protocol"
where
  "mkSPRSingleAuto \<equiv> \<lambda>kbp envInit envAction envTrans envVal envObs.
    mkAlgAuto trie_odlist_MapOps
              trans_MapOps
              (spr_simObs envObs)
              (spr_simInit envInit envObs)
              (spr_simTrans kbp envAction envTrans envVal envObs)
              (spr_simAction kbp envVal)
              (\<lambda>a. map (spr_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteSingleAgentEnvironment) mkSPRSingleAuto_implements:
  "SPR.implements (mkSPRSingleAuto (jkbp agent) envInit envAction envTrans envVal envObs)"
  using SPRsingle.k_mkAlgAuto_implements
  unfolding mkSPRSingleAuto_def mkAlgAuto_def alg_dfs_def SPRsingle.KBP.k_ins_def SPRsingle.KBP.k_empt_def SPRsingle.k_frontier_def SPRsingle.KBP.k_memb_def SPRsingle.KBP.transUpdate_def SPRsingle.KBP.actsUpdate_def
  apply simp
  done

(*

We actually run this unfolding of the algorithm. The lemma is keeping
us honest.

*)

type_synonym (in -)
  ('aAct, 'obs, 's) SPRSingleAutoDFS = "(('s, 'aAct list) trie, (('s, ('obs, 's odlist) mapping) trie)) AlgState"

definition
  SPRSingleAutoDFS :: "('a, 'p, 'aAct) KBP
                     \<Rightarrow> ('s :: linorder) list
                     \<Rightarrow> ('s \<Rightarrow> 'eAct list)
                     \<Rightarrow> ('eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's)
                     \<Rightarrow> ('s \<Rightarrow> 'p \<Rightarrow> bool)
                     \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> 'obs)
                     \<Rightarrow> 'a \<Rightarrow> ('aAct, 'obs, 's) SPRSingleAutoDFS"
where
  "SPRSingleAutoDFS \<equiv> \<lambda>kbp envInit envAction envTrans envVal envObs. \<lambda>a.
    alg_dfs trie_odlist_MapOps
            trans_MapOps
            (spr_simObs envObs a)
            (spr_simTrans kbp envAction envTrans envVal envObs a)
            (spr_simAction kbp envVal a)
            (map (spr_simInit envInit envObs a \<circ> envObs a) envInit)"

lemma (in FiniteSingleAgentEnvironment)
  "mkSPRSingleAuto kbp envInit envAction envTrans envVal envObs
 = (\<lambda>a. alg_mk_auto trie_odlist_MapOps trans_MapOps (spr_simInit a) (SPRSingleAutoDFS kbp envInit envAction envTrans envVal envObs a))"
  unfolding mkSPRSingleAuto_def SPRSingleAutoDFS_def mkAlgAuto_def alg_mk_auto_def by (simp add: Let_def)

(*>*)
text\<open>

We use this theory to synthesise a solution to the robot of
\S\ref{sec:kbps-robot-intro} in \S\ref{sec:kbps-theory-robot}.

\<close>
(*<*)

end
(*>*)


section {* Set Based Leakage Model (sketch)*}

theory Wasm_Leakage imports Wasm_Secret begin

datatype arith_leakage =
  Unop_i32_leakage unop_i
| Unop_i64_leakage unop_i
| Unop_f32_leakage unop_f f32
| Unop_f64_leakage unop_f f64
| Binop_i32_Some_safe_leakage binop_i
| Binop_i32_None_safe_leakage binop_i
| Binop_i64_Some_safe_leakage binop_i
| Binop_i64_None_safe_leakage binop_i
| Binop_i32_Some_leakage binop_i i32 i32
| Binop_i32_None_leakage binop_i i32 i32
| Binop_i64_Some_leakage binop_i i64 i64
| Binop_i64_None_leakage binop_i i64 i64
| Binop_f32_Some_leakage binop_f f32 f32
| Binop_f32_None_leakage binop_f f32 f32
| Binop_f64_Some_leakage binop_f f64 f64
| Binop_f64_None_leakage binop_f f64 f64
| Testop_i32_leakage testop
| Testop_i64_leakage testop
| Relop_i32_leakage relop_i
| Relop_i64_leakage relop_i
| Relop_f32_leakage relop_f f32 f32
| Relop_f64_leakage relop_f f64 f64

datatype host_leakage =
  Callcl_host_Some_leakage "mem list"
| Callcl_host_None_leakage "mem list"

datatype leakage =
  Arith_leakage arith_leakage
| Host_leakage host_leakage
| Empty_leakage
| Convert_Some_int_leakage t t
| Convert_None_int_leakage t t
| Convert_Some_leakage t t v
| Convert_None_leakage t t v
| Select_leakage "i32 option"
| If_false_leakage i32
| If_true_leakage i32
| Br_if_false_leakage i32
| Br_if_true_leakage i32
| Br_table_leakage i32
| Br_table_length_leakage i32
| Call_indirect_Some_leakage i32
| Call_indirect_None_leakage i32
| Callcl_native_leakage nat
| Load_Some_leakage t nat a off
| Load_None_leakage t nat a off
| Load_packed_Some_leakage tp sx nat a off
| Load_packed_None_leakage tp sx nat a off
| Store_Some_leakage t nat a off
| Store_None_leakage t nat a off
| Store_packed_Some_leakage t tp nat a off
| Store_packed_None_leakage t tp nat a off
| Current_memory_leakage nat
| Grow_memory_Some_leakage nat nat
| Grow_memory_None_leakage nat nat

definition action_leakage :: "action \<Rightarrow> leakage" where
"action_leakage a =
  (case a of
  Unop_i32_action op' \<Rightarrow> Arith_leakage (Unop_i32_leakage op')
| Unop_i64_action op' \<Rightarrow> Arith_leakage (Unop_i64_leakage op')
| Unop_f32_action op' c \<Rightarrow> Arith_leakage (Unop_f32_leakage op' c)
| Unop_f64_action op' c \<Rightarrow> Arith_leakage (Unop_f64_leakage op' c)
| Binop_i32_Some_action op' c1 c2 \<Rightarrow> Arith_leakage (if (safe_binop_i op')
                                                     then Binop_i32_Some_safe_leakage op'
                                                     else Binop_i32_Some_leakage op' c1 c2)
| Binop_i32_None_action op' c1 c2 \<Rightarrow> Arith_leakage (if (safe_binop_i op')
                                                     then Binop_i32_None_safe_leakage op'
                                                     else Binop_i32_None_leakage op' c1 c2)
| Binop_i64_Some_action op' c1 c2 \<Rightarrow> Arith_leakage (if (safe_binop_i op')
                                                     then Binop_i64_Some_safe_leakage op'
                                                     else Binop_i64_Some_leakage op' c1 c2)
| Binop_i64_None_action op' c1 c2 \<Rightarrow>Arith_leakage (if (safe_binop_i op')
                                                    then Binop_i64_None_safe_leakage op'
                                                    else Binop_i64_None_leakage op' c1 c2)
| Binop_f32_Some_action op' c1 c2 \<Rightarrow> Arith_leakage (Binop_f32_Some_leakage op' c1 c2)
| Binop_f32_None_action op' c1 c2 \<Rightarrow> Arith_leakage (Binop_f32_None_leakage op' c1 c2)
| Binop_f64_Some_action op' c1 c2 \<Rightarrow> Arith_leakage (Binop_f64_Some_leakage op' c1 c2)
| Binop_f64_None_action op' c1 c2 \<Rightarrow> Arith_leakage (Binop_f64_None_leakage op' c1 c2)
| Testop_i32_action op' \<Rightarrow> Arith_leakage (Testop_i32_leakage op')
| Testop_i64_action op' \<Rightarrow> Arith_leakage (Testop_i64_leakage op')
| Relop_i32_action op' \<Rightarrow> Arith_leakage (Relop_i32_leakage op')
| Relop_i64_action op' \<Rightarrow> Arith_leakage (Relop_i64_leakage op')
| Relop_f32_action  op' c1 c2 \<Rightarrow> Arith_leakage (Relop_f32_leakage  op' c1 c2)
| Relop_f64_action  op' c1 c2 \<Rightarrow> Arith_leakage (Relop_f64_leakage  op' c1 c2)
| Convert_Some_action t1 t2 c \<Rightarrow> (if is_int_t t1 \<and> is_int_t t2
                                   then Convert_Some_int_leakage t1 t2
                                   else Convert_Some_leakage t1 t2 c)
| Convert_None_action t1 t2 c \<Rightarrow> (if is_int_t t1 \<and> is_int_t t2
                                   then Convert_None_int_leakage t1 t2
                                   else Convert_None_leakage t1 t2 c)
| Reinterpret_action \<Rightarrow> Empty_leakage
| Classify_action \<Rightarrow> Empty_leakage
| Declassify_action \<Rightarrow> Empty_leakage
| Unreachable_action \<Rightarrow> Empty_leakage
| Nop_action \<Rightarrow> Empty_leakage
| Drop_action  \<Rightarrow> Empty_leakage
| Select_action sec c \<Rightarrow> if (sec = Secret) then Select_leakage None else Select_leakage (Some c)
| Block_action  \<Rightarrow> Empty_leakage
| Loop_action \<Rightarrow> Empty_leakage
| If_false_action c \<Rightarrow> If_false_leakage c
| If_true_action c \<Rightarrow> If_true_leakage c
| Label_const_action \<Rightarrow> Empty_leakage
| Label_trap_action \<Rightarrow> Empty_leakage
| Br_action \<Rightarrow> Empty_leakage
| Br_if_false_action c \<Rightarrow> Br_if_false_leakage c
| Br_if_true_action c \<Rightarrow> Br_if_true_leakage c
| Br_table_action c \<Rightarrow> Br_table_leakage c
| Br_table_length_action c \<Rightarrow> Br_table_length_leakage c
| Local_const_action \<Rightarrow> Empty_leakage
| Local_trap_action \<Rightarrow> Empty_leakage
| Return_action \<Rightarrow> Empty_leakage
| Tee_local_action \<Rightarrow> Empty_leakage
| Trap_action \<Rightarrow> Empty_leakage
| Call_action \<Rightarrow> Empty_leakage
| Call_indirect_Some_action c \<Rightarrow> Call_indirect_Some_leakage c
| Call_indirect_None_action c \<Rightarrow> Call_indirect_None_leakage c
| Callcl_native_action n \<Rightarrow> Callcl_native_leakage n
| Callcl_host_Some_action s args s' out tr tf host hs \<Rightarrow> Host_leakage (Callcl_host_Some_leakage (map fst (filter (\<lambda>(m,sec). sec = Public) (mem s))))
| Callcl_host_None_action s args tr tf host hs \<Rightarrow> Host_leakage (Callcl_host_Some_leakage (map fst (filter (\<lambda>(m,sec). sec = Public) (mem s))))
| Get_local_action \<Rightarrow> Empty_leakage
| Set_local_action \<Rightarrow> Empty_leakage
| Get_global_action \<Rightarrow> Empty_leakage
| Set_global_action \<Rightarrow> Empty_leakage
| Load_Some_action t n a off \<Rightarrow> Load_Some_leakage t n a off
| Load_None_action t n a off \<Rightarrow> Load_None_leakage t n a off
| Load_packed_Some_action tp sx n a off \<Rightarrow> Load_packed_Some_leakage tp sx n a off
| Load_packed_None_action tp sx n a off \<Rightarrow> Load_packed_None_leakage tp sx n a off
| Store_Some_action t n a off \<Rightarrow> Store_Some_leakage t n a off
| Store_None_action t n a off \<Rightarrow> Store_None_leakage t n a off
| Store_packed_Some_action t tp n a off \<Rightarrow> Store_packed_Some_leakage t tp n a off
| Store_packed_None_action t tp n a off \<Rightarrow> Store_packed_None_leakage t tp n a off
| Current_memory_action l \<Rightarrow> Current_memory_leakage l
| Grow_memory_Some_action l c \<Rightarrow> Grow_memory_Some_leakage l c
| Grow_memory_None_action l c \<Rightarrow> Grow_memory_None_leakage l c
| Label_action \<Rightarrow> Empty_leakage
| Local_action \<Rightarrow> Empty_leakage)"

lemma memory_agree_filter:
  assumes "memory_public_agree m m'"
  shows "(\<lambda>(m,sec). sec = Public) m = (\<lambda>(m,sec). sec = Public) m'"
  using assms
  unfolding memory_public_agree_def
  by (cases m; cases m') auto

lemma memories_agree_filter:
  assumes "memories_public_agree ms ms'"
  shows "filter (\<lambda>(m,sec). sec = Public) ms = filter (\<lambda>(m,sec). sec = Public) ms'"
  using assms
proof (induction ms arbitrary: ms')
  case Nil
  thus ?case
    by simp
next
  case (Cons a ms)
  obtain a' ms'' where "ms' = a'#ms''"
                       "memory_public_agree a a'"
                       "memories_public_agree ms ms''"
    using Cons(2)
    by (metis list_all2_Cons1)
  thus ?case
    using Cons(1) memory_agree_filter
    by (fastforce simp add: memory_public_agree_def)
qed

lemma action_indistinguishable_imp_action_leakage_eq:
  assumes "a \<sim>_a a'"
          "action_leakage a = obs"
  shows "action_leakage a' = obs"
  using assms
proof (induction rule: action_indistinguishable.induct)
  case (host_Some s s' vcs vcs' s_o s'_o vcs_o vcs'_o tf f hs hs')
  have "filter (\<lambda>(m,sec). sec = Public) (mem s) = filter (\<lambda>(m,sec). sec = Public) (mem s')"
    using host_Some(1) store_public_agree_def memories_agree_filter
    by simp
  thus ?case
    using host_Some(5)
    by (auto simp add: action_leakage_def)
next
  case (host_None s s' vcs vcs' tf f hs hs')
  have "filter (\<lambda>(m,sec). sec = Public) (mem s) = filter (\<lambda>(m,sec). sec = Public) (mem s')"
    using host_None(1) store_public_agree_def memories_agree_filter
    by simp
  thus ?case
    using host_None(3)
    by (auto simp add: action_leakage_def)
qed (auto simp add: action_leakage_def)

end


chapter\<open>Output\<close>
text\<open>This chapter provides two different output formats for EFSMs.\<close>

section\<open>Graphical Output\<close>
text\<open>It is often more intuitive and aesthetically pleasing to view EFSMs graphically. DOT is a graph
layout engine which converts textual representations of graphs to more useful formats, such as SVG
or PNG representations. This theory defines functions to convert arbitrary EFSMs to DOT for easier
viewing. Here, transitions use the syntactic sugar presented in \cite{foster2018} such that they
take the form $\textit{label}:\textit{arity}[g_1, \ldots, g_g]/f_1, \ldots, f_f[u_1, \ldots, u_u]$.\<close>

theory EFSM_Dot
imports Inference
begin

fun string_of_digit :: "nat \<Rightarrow> String.literal" where
  "string_of_digit n = (
         if n = 0 then (STR ''0'')
    else if n = 1 then (STR ''1'')
    else if n = 2 then (STR ''2'')
    else if n = 3 then (STR ''3'')
    else if n = 4 then (STR ''4'')
    else if n = 5 then (STR ''5'')
    else if n = 6 then (STR ''6'')
    else if n = 7 then (STR ''7'')
    else if n = 8 then (STR ''8'')
    else (STR ''9''))"

abbreviation newline :: String.literal where
  "newline \<equiv> STR ''\010''"

abbreviation quote :: String.literal where
  "quote \<equiv> STR ''\"''"

definition shows_string :: "String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal"
where
  "shows_string = (+)"

fun showsp_nat :: "String.literal \<Rightarrow> nat \<Rightarrow> String.literal \<Rightarrow> String.literal"
where
  "showsp_nat p n =
    (if n < 10 then shows_string (string_of_digit n)
    else showsp_nat p (n div 10) o shows_string (string_of_digit (n mod 10)))"
declare showsp_nat.simps [simp del]

definition showsp_int :: "String.literal \<Rightarrow> int \<Rightarrow> String.literal \<Rightarrow> String.literal"
where
  "showsp_int p i =
    (if i < 0 then shows_string STR ''-'' o showsp_nat p (nat (- i)) else showsp_nat p (nat i))"

definition "show_int n  \<equiv> showsp_int ((STR '''')) n ((STR ''''))"
definition "show_nat n  \<equiv> showsp_nat ((STR '''')) n ((STR ''''))"

definition replace_backslash :: "String.literal \<Rightarrow> String.literal" where
  "replace_backslash s = String.implode (fold (@) (map (\<lambda>x. if x = CHR 0x5c then [CHR 0x5c,CHR 0x5c] else [x]) (String.explode s)) '''')"

code_printing
  constant replace_backslash \<rightharpoonup> (Scala) "_.replace(\"\\\\\", \"\\\\\\\\\")"

fun value2dot :: "value \<Rightarrow> String.literal" where
  "value2dot (value.Str s) = quote + replace_backslash s + quote" |
  "value2dot (Num n) = show_int n"

fun vname2dot :: "vname \<Rightarrow> String.literal" where
  "vname2dot (vname.I n) = STR ''i''+(show_nat (n))+STR ''''" |
  "vname2dot (R n) = STR ''r''+(show_nat n)+STR ''''"

fun aexp2dot :: "vname aexp \<Rightarrow> String.literal" where
  "aexp2dot (L v) = value2dot v" |
  "aexp2dot (V v) = vname2dot v" |
  "aexp2dot (Plus a1 a2) = (aexp2dot a1)+STR '' + ''+(aexp2dot a2)" |
  "aexp2dot (Minus a1 a2) = (aexp2dot a1)+STR '' - ''+(aexp2dot a2)" |
  "aexp2dot (Times a1 a2) = (aexp2dot a1)+STR '' × ''+(aexp2dot a2)"

fun join :: "String.literal list \<Rightarrow> String.literal \<Rightarrow> String.literal" where
  "join [] _ = (STR '''')" |
  "join [a] _ = a" |
  "join (h#t) s = h+s+(join t s)"

definition show_nats :: "nat list \<Rightarrow> String.literal" where
  "show_nats l = join (map show_nat l) STR '', ''"

fun gexp2dot :: "vname gexp \<Rightarrow> String.literal" where
  "gexp2dot (GExp.Bc True) = (STR ''True'')" |
  "gexp2dot (GExp.Bc False) = (STR ''False'')" |
  "gexp2dot (GExp.Eq a1 a2) = (aexp2dot a1)+STR '' = ''+(aexp2dot a2)" |
  "gexp2dot (GExp.Gt a1 a2) = (aexp2dot a1)+STR '' > ''+(aexp2dot a2)" |
  "gexp2dot (GExp.In v l) = (vname2dot v)+STR ''∈{''+(join (map value2dot l) STR '', '')+STR ''}''" |
  "gexp2dot (Nor g1 g2) = STR ''!(''+(gexp2dot g1)+STR ''∨''+(gexp2dot g2)+STR '')''"

primrec guards2dot_aux :: "vname gexp list \<Rightarrow> String.literal list" where
  "guards2dot_aux [] = []" |
  "guards2dot_aux (h#t) = (gexp2dot h)#(guards2dot_aux t)"

lemma gexp2dot_aux_code [code]: "guards2dot_aux l = map gexp2dot l"
  by (induct l, simp_all)

primrec updates2dot_aux :: "update_function list \<Rightarrow> String.literal list" where
  "updates2dot_aux [] = []" |
  "updates2dot_aux (h#t) = ((vname2dot (R (fst h)))+STR '' := ''+(aexp2dot (snd h)))#(updates2dot_aux t)"

lemma updates2dot_aux_code [code]:
  "updates2dot_aux l = map (\<lambda>(r, u). (vname2dot (R r))+STR '' := ''+(aexp2dot u)) l"
  by (induct l, auto)

primrec outputs2dot :: "output_function list \<Rightarrow> nat \<Rightarrow> String.literal list" where
  "outputs2dot [] _ = []" |
  "outputs2dot (h#t) n = ((STR ''o''+(show_nat n))+STR '' := ''+(aexp2dot h))#(outputs2dot t (n+1))"

fun updates2dot :: "update_function list \<Rightarrow> String.literal" where
  "updates2dot [] = (STR '''')" |
  "updates2dot a = STR ''[''+(join (updates2dot_aux a) STR '', '')+STR '']''"

fun guards2dot :: "vname gexp list \<Rightarrow> String.literal" where
  "guards2dot [] = (STR '''')" |
  "guards2dot a = STR ''[''+(join (guards2dot_aux a) STR '', '')+STR '']''"

definition latter2dot :: "transition \<Rightarrow> String.literal" where
  "latter2dot t = (let l = (join (outputs2dot (Outputs t) 1) STR '', '')+(updates2dot (Updates t)) in (if l = (STR '''') then (STR '''') else STR ''/''+l))"

definition transition2dot :: "transition \<Rightarrow> String.literal" where
  "transition2dot t = (Label t)+STR '':''+(show_nat (Arity t))+(guards2dot (Guards t))+(latter2dot t)"

definition efsm2dot :: "transition_matrix \<Rightarrow> String.literal" where
  "efsm2dot e = STR ''digraph EFSM{''+newline+
                STR ''  graph [rankdir=''+quote+(STR ''LR'')+quote+STR '', fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+
                STR ''  node [color=''+quote+(STR ''black'')+quote+STR '', fillcolor=''+quote+(STR ''white'')+quote+STR '', shape=''+quote+(STR ''circle'')+quote+STR '', style=''+quote+(STR ''filled'')+quote+STR '', fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+
                STR ''  edge [fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+newline+
                  STR ''  s0[fillcolor=''+quote+STR ''gray''+quote+STR '', label=<s0>];''+newline+
                  (join (map (\<lambda>s. STR ''  s''+show_nat s+STR ''[label=<s'' +show_nat s+ STR ''>];'') (sorted_list_of_fset (EFSM.S e - {|0|}))) (newline))+newline+newline+
                  (join ((map (\<lambda>((from, to), t). STR ''  s''+(show_nat from)+STR ''->s''+(show_nat to)+STR ''[label=<''+(transition2dot t)+STR ''>];'') (sorted_list_of_fset e))) newline)+newline+
                STR ''}''"

definition iefsm2dot :: "iEFSM \<Rightarrow> String.literal" where
  "iefsm2dot e = STR ''digraph EFSM{''+newline+
                 STR ''  graph [rankdir=''+quote+(STR ''LR'')+quote+STR '', fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+
                 STR ''  node [color=''+quote+(STR ''black'')+quote+STR '', fillcolor=''+quote+(STR ''white'')+quote+STR '', shape=''+quote+(STR ''circle'')+quote+STR '', style=''+quote+(STR ''filled'')+quote+STR '', fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+
                 STR ''  edge [fontname=''+quote+STR ''Latin Modern Math''+quote+STR ''];''+newline+newline+
                  STR ''  s0[fillcolor=''+quote+STR ''gray''+quote+STR '', label=<s0>];''+newline+
                  (join (map (\<lambda>s. STR ''  s''+show_nat s+STR ''[label=<s'' +show_nat s+ STR ''>];'') (sorted_list_of_fset (S e - {|0|}))) (newline))+newline+newline+
                  (join ((map (\<lambda>(uid, (from, to), t). STR ''  s''+(show_nat from)+STR ''->s''+(show_nat to)+STR ''[label=< [''+show_nats (sort uid)+STR '']''+(transition2dot t)+STR ''>];'') (sorted_list_of_fset e))) newline)+newline+
                STR ''}''"

abbreviation newline_str :: string where
  "newline_str \<equiv> ''\010''"

abbreviation quote_str :: string where
  "quote_str \<equiv> ''0x22''"
end


(*
 * Copyright 2018, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory Trace_Schematic_Insts_Test
imports
  Lib.Trace_Schematic_Insts
begin

text \<open>
  Trace the schematic variables and types that a method instantiates.
  This only works for the variables already in the proof goal; new
  variables introduced by the traced method are not tracked.
\<close>

experiment begin
section \<open>Examples\<close>

text \<open>Schematic variables\<close>
lemma "\<lbrakk> \<forall>x. P x \<rbrakk> \<Longrightarrow> P x"
  apply (drule spec) \<comment> \<open>introduces schematic var "?x"\<close>
  apply (trace_schematic_insts \<open>assumption\<close>)
  done

definition foo :: "'a \<Rightarrow> bool"
  where "foo x = True"

lemma fooI1:
  "foo 0 \<Longrightarrow> foo x"
  by (simp add: foo_def)

lemma fooI2:
  "foo x \<Longrightarrow> foo 0"
  by (simp add: foo_def)

lemma fooI2':
  "foo x \<Longrightarrow> foo (0 :: nat)"
  by (erule fooI2)

text \<open>Schematic type variables\<close>
lemma "foo x \<Longrightarrow> foo y"
  apply (rule fooI1) \<comment> \<open>introduces schematic type "0 :: ?'a"\<close>
  apply (trace_schematic_insts \<open>erule fooI2'\<close>)
  done

text \<open>When backtracking, every recursive invocation is traced\<close>
lemma "\<lbrakk> \<forall>x. Q x \<longrightarrow> R x; \<forall>x. P x \<longrightarrow> Q x; P x; P y \<longrightarrow> R x \<rbrakk> \<Longrightarrow> R x"
  apply (drule spec)
  apply (drule spec)
  text \<open>For more clarity, methods can be named\<close>
  apply (trace_schematic_insts impE1 \<open>erule impE\<close>,
         trace_schematic_insts impE2 \<open>erule impE\<close>,
         (trace_schematic_insts "try assumption" \<open>assumption\<close>)+; fail)
  done

section \<open>Tests\<close>

ML \<open>
fun trace_schematic_assert ctxt test_name tac expected_vars expected_tvars =
  let
    fun skip_dummy_state tac = fn st =>
        case Thm.prop_of st of
            Const (@{const_name Pure.prop}, _) $
              (Const (@{const_name Pure.term}, _) $ Const (@{const_name Pure.dummy_pattern}, _)) =>
              Seq.succeed st
          | _ => tac st

    fun check var_insts tvar_insts =
      if expected_vars = var_insts andalso expected_tvars = tvar_insts then () else
        error ("Trace_Schematic_Insts failed test: " ^ test_name)

  in Method.NO_CONTEXT_TACTIC ctxt
        (Trace_Schematic_Insts.trace_schematic_insts (SIMPLE_METHOD tac) check [])
     |> skip_dummy_state
  end
\<close>

text \<open>Schematic variables\<close>
lemma "\<lbrakk> \<forall>x. P x \<rbrakk> \<Longrightarrow> P x"
  apply (drule spec)
  apply (tactic \<open>let
      val alpha = TFree ("'a", @{sort type})
      val expected_vars = [(Var (("x", 0), alpha), Free ("x", alpha))]
      val expected_tvars = []
      in trace_schematic_assert @{context}
            "basic Var test" (assume_tac @{context} 1)
            expected_vars expected_tvars
      end\<close>)
  done

text \<open>Schematic type variables\<close>
lemma "foo x \<Longrightarrow> foo y"
  apply (rule fooI1)
  apply (tactic \<open>let
      val expected_vars = []
      val expected_tvars = [(TVar (("'a", 0), @{sort zero}), @{typ nat})]
      in trace_schematic_assert
            @{context}
            "basic TVar test"
            (eresolve_tac @{context} @{thms fooI2'} 1)
            expected_vars expected_tvars
      end\<close>)
  done

end

end