(*  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 {* \isaheader{Generic Algorithms for Maps} *}
theory MapGA
imports SetIteratorCollectionsGA
begin

text_raw {*\label{thy:MapGA}*}

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 (op #) []"

  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 {* Locale_Code.lc_decl_del @{term dflt_ops}*}

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
          thm trans[OF conjunct2[OF Cons.IH]]
          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: split_if_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 (op #) []"
  definition "g_to_rev_list m \<equiv> iterateo m (op #) []"

  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 {* Locale_Code.lc_decl_del @{term dflt_oops}*}

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)

    def vP \<equiv> "\<lambda>k v. \<exists>k' v'. m1.\<alpha> m k' = Some v' \<and> f (k', v') = Some (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


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |                    May 2005               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |               November 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_op_rep_par
imports CSP_F_op_alpha_par CSP_T.CSP_T_op_rep_par
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (notick | t = <>)                 *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*============================================================*
 |                                                            |
 |            replicated alphabetized parallel                |
 |                                                            |
 *============================================================*)

(*** Inductive_parallel ***)

lemma in_failures_Inductive_parallel_lm1:
       "Y Int insert Tick (Ev ` snd a) Un
        Union {Y Int insert Tick (Ev ` X) |X Y. EX P. ((P, X), Y) : set PXYs} =
          Union {Ya Int insert Tick (Ev ` X) |X Ya.
                 EX P. P = fst a & X = snd a & Ya = Y | ((P, X), Ya) : set PXYs}"
by (auto)

lemma in_failures_Inductive_parallel_lm2:
  "((P, X), Y) : set s ==> X <= Union (snd ` fst ` set s)"
  apply (auto)
(* not necessary for Isabelle 2017
apply (rule_tac x="((P, X), Y)" in bexI)
by (simp_all)
*)
  done

lemma in_failures_Inductive_parallel_lm3:
   "Union {Y Int insert Tick (Ev ` X) |X Y. EX P. ((P, X), Y) : set zs} <=
    insert Tick (Ev ` Union (snd ` fst ` set zs))"
apply (rule)
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (elim conjE disjE)
apply (simp)
apply (rule disjI2)
apply (auto)
apply (simp add: image_iff)
apply (rule_tac x="((P, X), Y)" in bexI)
apply (auto)
done

lemma in_failures_Inductive_parallel_lm4:
   "Union {Y Int insert Tick (Ev ` X) |X Y. EX P. ((P, X), Y) : set zs} Int
    insert Tick (Ev ` Union (snd ` fst ` set zs))
    = Union {Y Int insert Tick (Ev ` X) |X Y. EX P. ((P, X), Y) : set zs}"
  apply (rule Int_subset_eq)
(* for Isabelle 2017 *)
apply (simp add: in_failures_Inductive_parallel_lm3[simplified])
done

(* main *)

lemma in_failures_Inductive_parallel_lm:
 "PXs ~= [] --> (ALL f.
   (f :f failures([||] PXs) M) =
         (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` set PXs)) &
          (EX Z. f = (u, Z) &
          (EX PXYs. map fst PXYs = PXs &
          (Z Int insert Tick (Ev ` Union (snd ` set PXs))
           = Union {(Y Int insert Tick (Ev ` X))|X Y. EX P. ((P,X),Y) : set PXYs} &
          (ALL P X Y. ((P,X),Y) : set PXYs --> ((u rest-tr X), Y) :f failures(P) M)))))))"
apply (induct_tac PXs)

(* case 0 *)
 apply (simp)

(* case 1 *)
 apply (case_tac "list = []")
 apply (simp)
 apply (intro allI)
 apply (simp add: in_failures_Alpha_parallel)
 apply (simp add: in_failures)
 apply (rule iffI)
 (* => *)
  apply (elim conjE exE)
  apply (simp)
  apply (erule disjE)

   apply (rule_tac x="[(a,Y)]" in exI)
   apply (simp)

    apply (rule conjI)
    apply (simp add: Evset_def pair_eq_decompo)
    apply (fast)
    apply (intro allI impI)
    apply (simp add: pair_eq_decompo)

   apply (case_tac "Tick ~: Z")
    apply (rule_tac x="[(a,Y)]" in exI)
    apply (simp add: Evset_def pair_eq_decompo)
(*    apply (fast) *)
   (* Tick : Z *)
    apply (rule_tac x="[(a,insert Tick Y)]" in exI)
    apply (simp)

    apply (simp add: rest_tr_Tick_sett)
    apply (elim conjE exE)
    apply (simp add: pair_eq_decompo)
    apply (rule conjI)
    apply (fast)
    apply (rule proc_T2_T3, simp)
    apply (simp)

 (* <= *)
  apply (elim conjE exE)
  apply (simp)
  apply (subgoal_tac "EX bb. PXYs=[(a,bb)]")
  apply (elim conjE exE)
  apply (subgoal_tac "aa rest-tr {} = <> | aa rest-tr {} = <Tick>")
  apply (erule disjE)

   (* <> *)
   apply (rule_tac x="bb" in exI)
   apply (rule_tac x="{}" in exI)
   apply (simp add: pair_eq_decompo)

   (* <Tick> *)
   apply (rule_tac x="bb" in exI)
   apply (rule_tac x="{}" in exI)
   apply (simp add: pair_eq_decompo)

   apply (simp add: rest_tr_empty)
   apply (force)

(* step case *)
apply (simp add: in_failures_Alpha_parallel)
apply (intro allI impI)
apply (rule iffI)

(* => *)
 apply (elim conjE exE, simp)
 apply (rule_tac x="(a,Y) # PXYs" in exI)
 apply (simp add: pair_eq_decompo)
 apply (simp add: in_failures_Inductive_parallel_lm1)

 apply (intro allI impI)
 apply (drule_tac x="P" in spec)
 apply (drule_tac x="X" in spec)
 apply (drule_tac x="Ya" in spec)
 apply (simp)
 apply (subgoal_tac "X <= Union (snd ` set list)")
 apply (simp add: rest_tr_of_rest_tr_subset)

 apply (rotate_tac -4)
   apply (drule sym)
(* for Isabelle 2017 *)
 apply (simp add: in_failures_Inductive_parallel_lm2[simplified])

(* <= *)
 apply (simp)
 apply (elim conjE exE)

 apply (subgoal_tac "EX bb zs. PXYs = (a, bb) # zs & map fst zs = list")
 apply (elim conjE exE)
 apply (rule_tac x="bb" in exI)
 apply (rule_tac x=
    "Union {Y Int insert Tick (Ev ` X) |X Y. EX P. ((P, X), Y) : set zs}" in exI)
 apply (simp)
 apply (rule conjI)
 apply (simp add: pair_eq_decompo)
 apply (rotate_tac -1)
 apply (drule sym)
 apply (simp)
 (* Isabelle 2017 *)
 apply (simp add: in_failures_Inductive_parallel_lm4[simplified])
 apply (simp add: in_failures_Inductive_parallel_lm1[simplified])

 apply (rule_tac x="zs" in exI)
 apply (rotate_tac -1)
 apply (drule sym)
 apply (simp add: in_failures_Inductive_parallel_lm4[simplified])

 apply (intro allI impI)
 apply (subgoal_tac "X <= Union (snd ` set list)")
 apply (simp add: rest_tr_of_rest_tr_subset)
 apply (simp add: in_failures_Inductive_parallel_lm2)
apply (auto)
done

(*** remove ALL ***)

lemma in_failures_Inductive_parallel:
 "PXs ~= [] ==>
   (f :f failures([||] PXs) M) =
         (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` set PXs)) &
          (EX Z. f = (u, Z) &
          (EX PXYs. map fst PXYs = PXs &
          (Z Int insert Tick (Ev ` Union (snd ` set PXs))
           = Union {(Y Int insert Tick (Ev ` X))|X Y. EX P. ((P,X),Y) : set PXYs} &
          (ALL P X Y. ((P,X),Y) : set PXYs --> ((u rest-tr X), Y) :f failures(P) M))))))"
by (simp add: in_failures_Inductive_parallel_lm)

(*** Semantics for replicated alphabetized parallel on F ***)

lemma failures_Inductive_parallel:
  "PXs ~= []
   ==> failures([||] PXs) M =
      {f. (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` set PXs)) &
          (EX Z. f = (u, Z) &
          (EX PXYs. map fst PXYs = PXs &
          (Z Int insert Tick (Ev ` Union (snd ` set PXs))
           = Union {(Y Int insert Tick (Ev ` X))|X Y. EX P. ((P,X),Y) : set PXYs} &
          (ALL P X Y. ((P,X),Y) : set PXYs --> ((u rest-tr X), Y) :f failures(P) M))))))}f"
apply (simp add: in_failures_Inductive_parallel[THEN sym])
done

(************************************
 |              traces              |
 ************************************)

lemma sett_in_failures_Inductive_parallel:
  "[| PXs ~= [] ; (t,X) :f failures([||] PXs) M |]
   ==> sett t <= insert Tick (Ev ` Union (snd ` set PXs))"
by (simp add: in_failures_Inductive_parallel)

(*---------------------------------------------------------*
 |        another expression of Inductive_parallel_eval          |
 *---------------------------------------------------------*)

lemma in_failures_Inductive_parallel_nth:
 "PXs ~= [] ==>
   (f :f failures([||] PXs) M) =
         (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` set PXs)) &
          (EX Z. f = (u, Z) &
          (EX Ys. length PXs = length Ys &
          (Z Int insert Tick (Ev ` Union (snd ` set PXs))
           = Union {((Ys!i) Int insert Tick (Ev ` (snd (PXs!i))))|i. i < length PXs} &
          (ALL i. i < length PXs --> ((u rest-tr (snd (PXs!i))), Ys!i) :f
            failures(fst (PXs!i)) M))))))"
apply (simp add: in_failures_Inductive_parallel)
apply (simp add: set_nth)
apply (rule iffI)

(* => *)
 apply (elim conjE exE)
 apply (simp)
 apply (rule_tac x="map snd PXYs" in exI)
 apply (simp)
 apply (rotate_tac 3)
 apply (drule sym)
 apply (simp)
 apply (rule conjI)
 apply (simp add: pair_eq_decompo)

 apply (rule equalityI)
 (* <= *)
  apply (rule)
  apply (simp)
  apply (elim conjE exE)
  apply (simp)
  apply (elim conjE disjE)
   apply (simp)
   apply (rule_tac x="map snd PXYs ! i Int
                      insert Tick (Ev ` snd (map fst PXYs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

   apply (rule_tac x="map snd PXYs ! i Int
                      insert Tick (Ev ` snd (map fst PXYs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

 (* => *)
  apply (rule)
  apply (simp)
  apply (elim conjE exE)
  apply (simp)
  apply (elim conjE disjE)
   apply (simp)
   apply (rule_tac x=
     "(snd (PXYs ! i)) Int insert Tick (Ev ` snd (fst (PXYs ! i)))" in exI)
   apply (simp)
   apply (rule_tac x="snd (fst (PXYs ! i))" in exI)
   apply (rule_tac x="snd (PXYs ! i)" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

   apply (rule_tac x=
     "(snd (PXYs ! i)) Int insert Tick (Ev ` snd (fst (PXYs ! i)))" in exI)
   apply (simp)
   apply (rule_tac x="snd (fst (PXYs ! i))" in exI)
   apply (rule_tac x="snd (PXYs ! i)" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

  apply (intro allI impI)
  apply (drule_tac x="fst (fst (PXYs ! i))" in spec)
  apply (drule_tac x="snd (fst (PXYs ! i))" in spec)
  apply (drule_tac x="snd (PXYs ! i)" in spec)
  apply (simp)
  apply (fast)

 (* => *)
 apply (elim conjE exE)
 apply (simp)
 apply (rule_tac x="zip PXs Ys" in exI)
 apply (simp add: map_fst_zip_eq)

 apply (rule conjI)
 apply (simp add: pair_eq_decompo)

 apply (rule equalityI)
 (* <= *)
  apply (rule)
  apply (simp)
  apply (elim conjE exE)
  apply (simp)
  apply (elim conjE disjE)
   apply (simp)
   apply (rule_tac x="Ys ! i Int insert Tick (Ev ` snd (PXs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="snd (PXs ! i)" in exI)
   apply (rule_tac x="Ys ! i" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

   apply (rule_tac x="Ys ! i Int insert Tick (Ev ` snd (PXs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="snd (PXs ! i)" in exI)
   apply (rule_tac x="Ys ! i" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

 (* => *)
  apply (rule)
  apply (simp)
  apply (elim conjE exE)
  apply (simp)
  apply (elim conjE disjE)
   apply (simp)
   apply (rule_tac x="Ys ! i Int insert Tick (Ev ` snd (PXs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

   apply (rule_tac x="Ys ! i Int insert Tick (Ev ` snd (PXs ! i))" in exI)
   apply (simp)
   apply (rule_tac x="i" in exI)
   apply (simp)

  apply (intro allI impI)
  apply (elim conjE exE)
  apply (drule_tac x="i" in spec)
  apply (simp add: pair_eq_decompo)
done

(*============================================================*
 |                                                            |
 |              indexed alphabetized parallel                 |
 |                                                            |
 *============================================================*)

(*** failures Inductive_parallel ***)

lemma in_failures_Rep_parallel_lm1:
  "[| Is isListOf I ; length Ys = length Is |] ==>
    Union {(Ys ! i Int insert Tick (Ev ` snd (map PXf Is ! i))) |i. i < length Ys} =
    Union {(Ys ! (THE n. Is ! n = i & n < length Is) Int
            insert Tick (Ev ` snd (PXf i))) | i. i : I}"
apply (rule)

 (* <= *)
 apply (rule)
 apply (simp)
 apply (elim conjE exE)
 apply (rule_tac x=
   "Ys ! (THE n. Is ! n = (Is ! i) & n < length Is) Int
    insert Tick (Ev ` snd (PXf (Is ! i)))" in exI)
 apply (simp add: isListOf_THE_nth)
 apply (rule_tac x="(Is ! i)" in exI)
 apply (simp add: isListOf_THE_nth)
 apply (simp add: isListOf_nth_in_index)

 (* => *)
 apply (rule)
 apply (simp)
 apply (elim conjE exE)
 apply (simp)
 apply (erule isListOf_index_to_nthE)
 apply (drule_tac x="i" in bspec, simp)
 apply (elim conjE exE, simp)
 apply (simp add: isListOf_THE_nth)
 apply (rule_tac x=
   "Ys ! n Int insert Tick (Ev ` snd (PXf (Is ! n)))" in exI)
 apply (simp)
 apply (rule_tac x="n" in exI)
 apply (simp)
done

lemma in_failures_Rep_parallel_lm2:
  "Is isListOf I ==>
   Union {(Yf i Int insert Tick (Ev ` snd (PXf i))) |i. i : I} =
   Union {(map Yf Is ! i Int insert Tick (Ev ` snd (map PXf Is ! i))) |i. i < length Is}"
apply (rule)

 (* <= *)
 apply (rule)
 apply (simp)
 apply (elim conjE exE)
 apply (erule isListOf_index_to_nthE)
 apply (drule_tac x="i" in bspec, simp)
 apply (elim conjE exE, simp)
 apply (rule_tac x=
   "map Yf Is ! n Int insert Tick (Ev ` snd (map PXf Is ! n))" in exI)
 apply (simp)
 apply (rule_tac x="n" in exI)
 apply (simp)

 (* => *)
 apply (rule)
 apply (simp)
 apply (elim conjE exE)
 apply (rule_tac x= "Yf (Is!i) Int insert Tick (Ev ` snd (PXf (Is!i)))" in exI)
 apply (simp)
 apply (rule_tac x="(Is!i)" in exI)
 apply (simp add: isListOf_nth_in_index)
done

lemma in_failures_Rep_parallel:
  "[| I ~= {} ; finite I |]
   ==> (f :f failures ([||]:I PXf) M) =
         (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` PXf ` I)) &
          (EX Z. f = (u, Z) &
          (EX Yf.
          (Z Int insert Tick (Ev ` Union (snd ` PXf ` I))
           = Union {((Yf i) Int insert Tick (Ev ` (snd (PXf i))))|i. i : I} &
          (ALL i:I. ((u rest-tr (snd (PXf i))), Yf i) :f failures(fst (PXf i)) M))))))"
apply (simp add: Rep_parallel_def)
apply (subgoal_tac "EX Is. Is isListOf I")
apply (elim conjE exE)
apply (subgoal_tac "(map PXf (SOME Is. Is isListOf I)) ~= []")
apply (simp add: in_failures_Inductive_parallel_nth)
apply (rule someI2)
 apply (simp)
 apply (rule iffI)

  (* => *)
  apply (elim conjE exE)
  apply (rename_tac Is' Is u Z Ys)
  apply (rule_tac x="u" in exI)
  apply (simp add: isListOf_set_eq)
  apply (rule_tac x= "(%i. (Ys!(THE n. (Is!n) = i & n<length Is)))" in exI)
  apply (rule conjI)
  apply (simp add: in_failures_Rep_parallel_lm1)
  apply (rule ballI)

  apply (rotate_tac 4)
  apply (erule isListOf_index_to_nthE)
  apply (drule_tac x="i" in bspec, simp)
  apply (elim conjE exE, simp)

  apply (rotate_tac 2)
  apply (drule sym)
  apply (simp add: isListOf_THE_nth)

  (* <= *)
  apply (elim conjE exE)
  apply (rename_tac Is' Is u Z Yf)
  apply (rule_tac x="u" in exI)
  apply (simp add: isListOf_set_eq)
  apply (rule_tac x= "map Yf Is" in exI)
  apply (simp)
  apply (rule conjI)
  apply (rule in_failures_Rep_parallel_lm2, simp)
  apply (intro allI impI)
  apply (drule_tac x="Is ! i" in bspec)
  apply (simp add: isListOf_nth_in_index)
  apply (simp)

 apply (rule someI2)
 apply (simp)
 apply (simp add: isListOf_nonemptyset)

apply (simp add: isListOf_EX)
done

lemmas in_failures_par = in_failures_Alpha_parallel
                         in_failures_Inductive_parallel
                         in_failures_Rep_parallel

(*** Semantics for indexed alphabetized parallel on F ***)

lemma failures_Rep_parallel:
  "[| I ~= {} ; finite I |]
   ==> failures ([||]:I PXf) M =
      {f. (EX u. (sett(u) <= insert Tick (Ev ` Union (snd ` PXf ` I)) &
          (EX Z. f = (u, Z) &
          (EX Yf.
          (Z Int insert Tick (Ev ` Union (snd ` PXf ` I))
           = Union {((Yf i) Int insert Tick (Ev ` (snd (PXf i))))|i. i : I} &
          (ALL i:I. ((u rest-tr (snd (PXf i))), Yf i) :f failures(fst (PXf i)) M))))))}f"
(* for Isabelle 2017 *)
  apply (simp add: in_failures_Rep_parallel[simplified, THEN sym])
done

(************************************
 |              traces              |
 ************************************)

lemma sett_in_failures_Rep_parallel:
  "[| I ~= {} ; finite I ; (t,X) :f failures([||]:I PXf) M |]
   ==> sett t <= insert Tick (Ev ` Union (snd ` PXf ` I))"
by (simp add: in_failures_Rep_parallel)

(****************** to add it again ******************)

declare disj_not1      [simp]
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


(* @TAG(OTHER_LGPL) *)

(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Closure.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Experiments with Closures"

theory Closure
imports "../Hoare"
begin

definition
"callClosure upd cl = Seq (Basic (upd (fst cl))) (Call (snd cl))"

definition
"dynCallClosure init upd cl return c =
  DynCom (\<lambda>s. call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c)"

lemma dynCallClosure_sound:
assumes adapt:
  "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec: "\<Gamma>\<turnstile> \<langle>dynCallClosure init upd cl return c,Normal s\<rangle> =n\<Rightarrow> t"
  from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
  have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =n\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
  assume P: "s \<in> P"
  from P adapt obtain P' Q' A'
      where
      valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A'" and
      init_P': "init s \<in> P'"  and
      R: "(\<forall>t \<in> Q'. return s t \<in> R s t)" and
      A: "(\<forall>t \<in> A'. return s t \<in> A)"
      by auto
  assume t_notin_F: "t \<notin> Fault ` F"
  from exec [simplified dynCallClosure_def]
  have exec_call:
      "\<Gamma>\<turnstile>\<langle>call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c,Normal s\<rangle> =n\<Rightarrow> t"
    by cases
  then
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases rule: execn_call_Normal_elim)
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Normal t'"
    assume exec_c: "\<Gamma>\<turnstile>\<langle>c s t',Normal (return s t')\<rangle> =Suc m\<Rightarrow> t"
    assume n: "n = Suc m"
    have "\<Gamma>\<turnstile>\<langle>Basic init,Normal s\<rangle> =m\<Rightarrow> Normal (init s)"
      by (rule execn.Basic)
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Normal t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Normal t'"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> Q'"
      by auto
    with R have "return s t' \<in> R s t'"
      by auto
    from cnvalidD [OF res [rule_format] ctxt exec_c [simplified n[symmetric]] this
         t_notin_F]
    show ?thesis
      by auto
  next
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Abrupt t'"
    assume t: "t=Abrupt (return s t')"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Abrupt t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Abrupt t'"
      by (simp add: callClosure_def n)

    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> A'"
      by auto
    with A have "return s t' \<in> A"
      by auto
    with t show ?thesis
      by auto
  next
    fix bdy m f
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Fault f"
    assume t: "t=Fault f"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Fault f"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Fault f"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix bdy m
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Stuck"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
    have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =Suc m\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix m
    assume no_bdy: "\<Gamma> (snd (cl s)) = None"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from no_bdy
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.CallUndefined)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  qed
qed

lemma dynCallClosure:
assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule dynCallClosure_sound [where R=R])
  using adapt
  apply (blast intro: hoare_cnvalid)
  using res
  apply (blast intro: hoare_cnvalid)
  done

lemma dynCallClosureFix:
assumes adapt: "P \<subseteq> {s. \<exists>Z. cl'=cl s \<and>
                  init s \<in> P' Z \<and>
                  (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A' Z. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> (P' Z) (callClosure upd cl') (Q' Z),(A' Z)"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule dynCallClosure [OF _ res])
  using adapt spec
  apply clarsimp
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

lemma conseq_extract_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s}) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (rule hoarep.Conseq)
  apply clarify
  apply (rule_tac x="{s}" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma app_closure_sound:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec_e: "\<Gamma>\<turnstile> \<langle>callClosure upd (e, p),Normal s\<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume t: "t \<notin> Fault ` F"
  from P adapt obtain P' Q' A'
    where
    valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (e',p)) Q',A'" and
    init_P': "upd x s \<in> P'"  and
    Q: "Q' \<subseteq> Q" and
    A: "A' \<subseteq> A"
    by auto
  from exec_e [simplified callClosure_def] obtain s'
    where
    exec_e: "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e, p))),Normal s\<rangle> =n\<Rightarrow> s'"and
    exec_p: "\<Gamma>\<turnstile> \<langle>Call (snd (e, p)),s'\<rangle> =n\<Rightarrow> t"
    by cases
  from exec_e [simplified]
  have s': "s'=Normal (upd e s)"
    by cases simp
  from ap obtain s'' where
   s'': "upd x s = s''" and upd_e': "upd e' s''=upd e s"
    by auto
  from ap s' execn.Basic [where f="(upd (fst (e', p)))" and s="upd x s" and \<Gamma>=\<Gamma>]
  have exec_e': "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e', p))),Normal (upd x s)\<rangle> =n\<Rightarrow> s'"
    by simp
  with exec_p
  have "\<Gamma>\<turnstile> \<langle>callClosure upd (e', p),Normal (upd x s)\<rangle> =n\<Rightarrow> t"
    by (auto simp add: callClosure_def intro: execn.Seq)
  from cnvalidD [OF valid [rule_format] ctxt this init_P'] t Q A
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by auto
qed

lemma app_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule app_closure_sound [where x=x and e'=e', OF _ ap])
  using adapt
  apply (blast intro: hoare_cnvalid)
  done

lemma app_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. upd x s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure upd (e',p)) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule app_closure [OF _ ap])
  apply clarsimp
  using adapt spec
  apply -
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

text {* Implementation of closures as association lists. *}

definition "gen_upd var es s = foldl (\<lambda>s (x,i). the (var x) i s) s es"
definition "ap es c \<equiv> (es@fst c,snd c)"

lemma gen_upd_app: "\<And>es'. gen_upd var (es@es') = gen_upd var es' \<circ> gen_upd var es"
  apply (induct es)
  apply  (rule ext)
  apply  (simp add: gen_upd_def)
  apply (rule ext)
  apply (simp add: gen_upd_def)
  done

lemma gen_upd_ap:
  "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
  by (simp add: gen_upd_app ap_def)

lemma ap_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure (gen_upd var) c) Q',A' \<and>
                           gen_upd var es s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure [OF adapt [simplified c] this]
  show ?thesis
    by (simp add: c ap_def)
qed

lemma ap_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. gen_upd var es s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure (gen_upd var) c) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure_spec [OF adapt [simplified c] this spec [simplified c]]
  show ?thesis
    by (simp add: c ap_def)
qed

end


header {* Tagging of Terms *}
theory Autoref_Tagging
imports "../Lib/Refine_Lib"
begin
text {*
  We provide a mechanism to tag terms, that supports relator annotations,
  and introduces tags to protect operations, function applications, and
  abstractions from automatic beta and eta conversions.
*}

ML {*
  structure Autoref_Tag_Defs = Named_Thms (
    val name = @{binding autoref_tag_defs}
    val description = "Autoref: Definitions of internal tags"
  )
*}
setup Autoref_Tag_Defs.setup

text {* General protection tag *}
definition PROTECT where [simp, autoref_tag_defs]: "PROTECT x \<equiv> x"

text {* General annotation tag *}
typedecl annot
definition ANNOT :: "'a \<Rightarrow> annot \<Rightarrow> 'a"
  where [simp, autoref_tag_defs]: "ANNOT x a \<equiv> x"

text {* Operation-tag, Autoref does not look beyond this *}
definition OP where [simp, autoref_tag_defs]: "OP x \<equiv> x"

text {* Protected function application *}
definition APP (infixl "$" 900) where [simp, autoref_tag_defs]: "f$a \<equiv> f a"

text {* Protected abstraction *}
abbreviation ABS :: "('a\<Rightarrow>'b)\<Rightarrow>'a\<Rightarrow>'b" (binder "\<lambda>''" 10)
  where "ABS f \<equiv> PROTECT (\<lambda>x. PROTECT (f x))"

lemma ABS_beta: "(\<lambda>'x. f x)$x \<equiv> f x" by simp
lemma ABS_eta: "\<lambda>'x. (f$x) \<equiv> f" by simp

text {* This tag is used to highlight failures during operation
  identification *}
definition "ID_FAIL x \<equiv> x"
notation (output) ID_FAIL ("FAIL *** _ ***")

text {* Relator annotation *}
consts rel_annot :: "('c\<times>'a) set \<Rightarrow> annot"
abbreviation rel_ANNOT :: "'a \<Rightarrow> ('c \<times> 'a) set \<Rightarrow> 'a" (infix ":::" 10)
  where "t:::R \<equiv> ANNOT t (rel_annot R)"

lemma rel_ANNOT_eq: "t \<equiv> t:::R" by simp

text {* Indirect annotation *}
typedecl rel_name
consts ind_annot :: "rel_name \<Rightarrow> annot"
abbreviation ind_ANNOT :: "'a \<Rightarrow> rel_name \<Rightarrow> 'a" (infix "::#" 10)
  where "t::#s \<equiv> ANNOT t (ind_annot s)"

ML {*
  signature AUTOREF_TAGGING = sig
    val term_of_tagged: term -> term
    val is_valid_tagged: term -> bool

    val mk_APP: term -> term -> term
    val mk_OP: term -> term
    val lambda': string * typ -> term -> term

    val list_APP: term * term list -> term
    val strip_app: term -> term * term list

    val untag_conv: Proof.context -> conv

    val mk_APP_conv: conv
    val mk_OP_conv: conv
    val mk_ABS_conv: Proof.context -> conv
    val mk_ANNOT_conv: cterm -> conv
    val mk_rel_ANNOT_conv: cterm -> conv

    val ABS_beta_conv: Proof.context -> conv

    val rhs_conv: (Proof.context -> conv) -> Proof.context -> conv
  end

  structure Autoref_Tagging :AUTOREF_TAGGING = struct
    fun term_of_tagged (Free v) = Free v
      | term_of_tagged (Var v) = Var v
      | term_of_tagged (Bound i) = Bound i
      | term_of_tagged @{mpat "OP ?t"} = t
      | term_of_tagged @{mpat "ANNOT ?t _"} = term_of_tagged t
      | term_of_tagged @{mpat "?f$?x"} = term_of_tagged f $ term_of_tagged x
      | term_of_tagged @{mpat "PROTECT (\<lambda>x. PROTECT ?t)"}
        = Abs (x,x_T,term_of_tagged t)
      | term_of_tagged @{mpat (typs) "PROTECT (PROTECT::?'v_T\<Rightarrow>_)"}
        = Abs ("x",T,Bound 0)
      | term_of_tagged t = raise TERM ("term_of_tagged",[t])

    fun is_valid_tagged (Free _) = true
      | is_valid_tagged (Var _) = true
      | is_valid_tagged (Bound _) = true
      | is_valid_tagged @{mpat "OP _"} = true
      | is_valid_tagged @{mpat "ANNOT ?t _"} = is_valid_tagged t
      | is_valid_tagged @{mpat "?f$?x"}
        = is_valid_tagged f andalso is_valid_tagged x
      | is_valid_tagged @{mpat "PROTECT (\<lambda>_. PROTECT ?t)"} = is_valid_tagged t
      | is_valid_tagged @{mpat "PROTECT PROTECT"} = true
      | is_valid_tagged _ = false

    fun mk_APP f x = let
      val fT = fastype_of f
      val xT = fastype_of x
      val rT = range_type fT
    in
      Const (@{const_name APP},fT --> xT --> rT)$f$x
    end;

    fun mk_OP x = let
      val T = fastype_of x
    in
      Const(@{const_name OP},T-->T)$x
    end

    fun lambda' (name,T) t = let
      val tT = fastype_of t
      val t' = Const (@{const_name PROTECT},tT --> tT)$
        abstract_over (Free (name,T), t)
      val t' =
        Const (@{const_name PROTECT},(T --> tT) --> T --> tT)$Abs (name,T,t')
    in
      t'
    end

    val list_APP = Library.foldl (uncurry mk_APP)

    (* f$x1$...$xn goes to (f,[x1,...,xn]*)
    fun strip_app t = let
      fun strip_app_aux @{mpat "?f$?x"} args = strip_app_aux f (x::args)
        | strip_app_aux t args = (t,args)
    in strip_app_aux t [] end

    fun untag_conv ctxt = Raw_Simplifier.rewrite ctxt
      true (Autoref_Tag_Defs.get ctxt)

    fun ABS_beta_conv ctxt = Raw_Simplifier.rewrite ctxt
      true @{thms ABS_beta}

    val mk_PROTECT_conv = Conv.rewr_conv @{thm PROTECT_def[symmetric]}
    val mk_APP_conv = Conv.rewr_conv @{thm APP_def[symmetric]}
    val mk_OP_conv = Conv.rewr_conv @{thm OP_def[symmetric]}
    fun mk_ABS_conv ctxt = Conv.abs_conv (K mk_PROTECT_conv) ctxt
      then_conv mk_PROTECT_conv

    fun mk_ANNOT_conv a ct = let
      val Tt = ctyp_of_term ct

      val thm = Drule.instantiate' [SOME Tt] [SOME ct,SOME a]
        @{thm ANNOT_def[symmetric]}
    in
      thm
    end

    fun mk_rel_ANNOT_conv a ct = let
      val thy = theory_of_cterm ct
      val T = ctyp_of_term a |> typ_of
      val (Tc,Ta) = HOLogic.dest_setT T
        |> HOLogic.dest_prodT
        |> pairself (ctyp_of thy)
      val thm = Drule.instantiate' [SOME Ta, SOME Tc] [SOME ct,SOME a]
        @{thm rel_ANNOT_eq}
    in
      thm
    end

    (* Convert right hand side of refinement statement *)
    fun rhs_conv conv ctxt ct = let
      open Conv Refine_Util
    in
      case Logic.strip_imp_concl (term_of ct) of
        @{mpat "Trueprop ((_,_)\<in>_)"} =>
          HOL_concl_conv (fn ctxt => (arg1_conv (arg_conv (conv ctxt)))) ctxt ct
      | _ => raise CTERM ("rhs_conv",[ct])
    end
  end

*}

ML_val {*
  Autoref_Tagging.mk_ANNOT_conv @{cterm "bar::annot"} @{cterm "foo::'a::type"};
*}

ML_val {*
  Autoref_Tagging.mk_rel_ANNOT_conv
    @{cterm "bar::('c\<times>'a) set"} @{cterm "foo::'a::type"}
*}

end


(*
 * 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)
 *)

(*
  Compatibility theory to recreate syntax for NICTA developments.
*)

theory NICTACompat
imports
  "~~/src/HOL/Word/WordBitwise"
  SignedWords
  NICTATools
begin

(* all theories should import from NICTACompat rather than any ancestors *)

type_synonym word8 = "8 word"
type_synonym word16 = "16 word"
type_synonym word32 = "32 word"
type_synonym word64 = "64 word"

lemma len8: "len_of (x :: 8 itself) = 8" by simp
lemma len16: "len_of (x :: 16 itself) = 16" by simp
lemma len32: "len_of (x :: 32 itself) = 32" by simp
lemma len64: "len_of (x :: 64 itself) = 64" by simp

abbreviation
  wordNOT  :: "'a::len0 word \<Rightarrow> 'a word"      ("~~ _" [70] 71)
where
  "~~ x == NOT x"

abbreviation
  wordAND  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "&&" 64)
where
  "a && b == a AND b"

abbreviation
  wordOR   :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "||"  59)
where
  "a || b == a OR b"

abbreviation
  wordXOR  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "xor" 59)
where
  "a xor b == a XOR b"

(* testing for presence of word_bitwise *)
lemma "((x :: word32) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

(* print words in hex *)
(* mostly clagged from Num.thy *)
typed_print_translation  {*
let
  fun dest_num (Const (@{const_syntax Num.Bit0}, _) $ n) = 2 * dest_num n
    | dest_num (Const (@{const_syntax Num.Bit1}, _) $ n) = 2 * dest_num n + 1
    | dest_num (Const (@{const_syntax Num.One}, _)) = 1;

  fun dest_bin_hex_str tm =
  let
    val num = dest_num tm;
    val pre = if num < 10 then "" else "0x"
  in
    pre ^ (Int.fmt StringCvt.HEX num)
  end;

  fun num_tr' sign ctxt T [n] =
    let
      val k = dest_bin_hex_str n;
      val t' = Syntax.const @{syntax_const "_Numeral"} $
        Syntax.free (sign ^ k);
    in
      case T of
        Type (@{type_name fun}, [_, T' as Type("Word.word",_)]) =>
          if not (Config.get ctxt show_types) andalso can Term.dest_Type T'
          then t'
          else Syntax.const @{syntax_const "_constrain"} $ t' $
                            Syntax_Phases.term_of_typ ctxt T'
      | T' => if T' = dummyT then t' else raise Match
    end;
in [(@{const_syntax numeral}, num_tr' "")] end
*}

lemma neg_num_bintr:
  "(- numeral x :: 'a::len word) =
  word_of_int (bintrunc (len_of TYPE('a)) (-numeral x))"
  by (simp only: word_ubin.Abs_norm word_neg_numeral_alt)

(* normalise word numerals to the interval [0..2^len_of 'a) *)
ML {*
  fun is_refl (Const (@{const_name Pure.eq}, _) $ x $ y) = (x = y)
    | is_refl _ = false;

  fun typ_size_of t = Word_Lib.dest_wordT (type_of (term_of t));

  fun num_len (Const (@{const_name Num.Bit0}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.Bit1}, _) $ n) = num_len n + 1
    | num_len (Const (@{const_name Num.One}, _)) = 1
    | num_len (Const (@{const_name numeral}, _) $ t) = num_len t
    | num_len (Const (@{const_name uminus}, _) $ t) = num_len t
    | num_len t = raise TERM ("num_len", [t])

  fun unsigned_norm is_neg _ ctxt ct =
  (if is_neg orelse num_len (term_of ct) > typ_size_of ct then let
      val btr = if is_neg
                then @{thm neg_num_bintr} else @{thm num_abs_bintr}
      val th = [Thm.reflexive ct, mk_eq btr] MRS transitive_thm

      (* will work in context of theory Word as well *)
      val ss = simpset_of (@{context} addsimps @{thms bintrunc_numeral})
      val cnv = simplify (put_simpset ss ctxt) th
    in if is_refl (prop_of cnv) then NONE else SOME cnv end
    else NONE)
  handle TERM ("num_len", _) => NONE
       | TYPE ("dest_binT", _, _) => NONE
*}

simproc_setup
  unsigned_norm ("numeral n::'a::len word") = {* unsigned_norm false *}

simproc_setup
  unsigned_norm_neg0 ("-numeral (num.Bit0 num)::'a::len word") = {* unsigned_norm true *}

simproc_setup
  unsigned_norm_neg1 ("-numeral (num.Bit1 num)::'a::len word") = {* unsigned_norm true *}

lemma minus_one_norm:
 "(-1 :: ('a :: len) word)
    = of_nat (2 ^ len_of TYPE('a) - 1)"
  by (simp add:of_nat_diff)
lemma "f (7 :: 2 word) = f 3"
  apply simp
  done

lemma "f -2 = f (22 :: 3 word)"
  apply simp
  done

lemma "f -1 = f (13 :: 'a::len word)"
  (* apply simp *)
  oops

lemma "f -2 = f (8589934590 :: word32)"
  using [[simp_trace]]
  apply simp
  done

lemma "(-1 :: 2 word) = 3"
  apply simp
  done

lemma "f -1 = f (15 :: 4 word)"
  apply (simp add: minus_one_norm)
  done

lemma "f -1 = f (7 :: 3 word)"
  apply (simp add: minus_one_norm)
  done

lemma "f -1 = f (0xFFFF :: 16 word)"
  by (simp add: minus_one_norm)

lemma bin_nth_minus_Bit0[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n, simp_all)

lemma bin_nth_minus_Bit1[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n, simp_all)

end