(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Specification of Maps} *}
theory MapSpec
imports ICF_Spec_Base
begin
text_raw{*\label{thy:MapSpec}*}

(*@intf Map
  @abstype 'k\<rightharpoonup>'v
  This interface specifies maps from keys to values.
*)

text {*
  This theory specifies map operations by means of mapping to
  HOL's map type, i.e. @{typ "'k \<rightharpoonup> 'v"}.
*}

type_synonym ('k,'v,'s) map_\<alpha> = "'s \<Rightarrow> 'k \<rightharpoonup> 'v"
type_synonym ('k,'v,'s) map_invar = "'s \<Rightarrow> bool"
locale map =
  fixes \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"                 -- "Abstraction to map datatype"
  fixes invar :: "'s \<Rightarrow> bool"                 -- "Invariant"

locale map_no_invar = map +
  assumes invar[simp, intro!]: "\<And>s. invar s"

subsection "Basic Map Functions"

subsubsection "Empty Map"
type_synonym ('k,'v,'s) map_empty = "unit \<Rightarrow> 's"
locale map_empty = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "\<alpha> (empty ()) = Map.empty"
    "invar (empty ())"

subsubsection "Lookup"
type_synonym ('k,'v,'s) map_lookup = "'k \<Rightarrow> 's \<Rightarrow> 'v option"
locale map_lookup = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes lookup :: "'u \<Rightarrow> 's \<Rightarrow> 'v option"
  assumes lookup_correct:
    "invar m \<Longrightarrow> lookup k m = \<alpha> m k"

subsubsection "Update"
type_synonym ('k,'v,'s) map_update = "'k \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
locale map_update = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes update :: "'u \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
  assumes update_correct:
    "invar m \<Longrightarrow> \<alpha> (update k v m) = (\<alpha> m)(k \<mapsto> v)"
    "invar m \<Longrightarrow> invar (update k v m)"

subsubsection "Disjoint Update"
type_synonym ('k,'v,'s) map_update_dj = "'k \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
locale map_update_dj = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes update_dj :: "'u \<Rightarrow> 'v \<Rightarrow> 's \<Rightarrow> 's"
  assumes update_dj_correct:
    "\<lbrakk>invar m; k\<notin>dom (\<alpha> m)\<rbrakk> \<Longrightarrow> \<alpha> (update_dj k v m) = (\<alpha> m)(k \<mapsto> v)"
    "\<lbrakk>invar m; k\<notin>dom (\<alpha> m)\<rbrakk> \<Longrightarrow> invar (update_dj k v m)"

subsubsection "Delete"
type_synonym ('k,'v,'s) map_delete = "'k \<Rightarrow> 's \<Rightarrow> 's"
locale map_delete = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes delete :: "'u \<Rightarrow> 's \<Rightarrow> 's"
  assumes delete_correct:
    "invar m \<Longrightarrow> \<alpha> (delete k m) = (\<alpha> m) |` (-{k})"
    "invar m \<Longrightarrow> invar (delete k m)"

subsubsection "Add"
type_synonym ('k,'v,'s) map_add = "'s \<Rightarrow> 's \<Rightarrow> 's"
locale map_add = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes add :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes add_correct:
    "invar m1 \<Longrightarrow> invar m2 \<Longrightarrow> \<alpha> (add m1 m2) = \<alpha> m1 ++ \<alpha> m2"
    "invar m1 \<Longrightarrow> invar m2 \<Longrightarrow> invar (add m1 m2)"

type_synonym ('k,'v,'s) map_add_dj = "'s \<Rightarrow> 's \<Rightarrow> 's"
locale map_add_dj = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes add_dj :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes add_dj_correct:
    "\<lbrakk>invar m1; invar m2; dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {}\<rbrakk> \<Longrightarrow> \<alpha> (add_dj m1 m2) = \<alpha> m1 ++ \<alpha> m2"
    "\<lbrakk>invar m1; invar m2; dom (\<alpha> m1) \<inter> dom (\<alpha> m2) = {} \<rbrakk> \<Longrightarrow> invar (add_dj m1 m2)"

subsubsection "Emptiness Check"
type_synonym ('k,'v,'s) map_isEmpty = "'s \<Rightarrow> bool"
locale map_isEmpty = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct : "invar m \<Longrightarrow> isEmpty m \<longleftrightarrow> \<alpha> m = Map.empty"

subsubsection "Singleton Maps"
type_synonym ('k,'v,'s) map_sng = "'k \<Rightarrow> 'v \<Rightarrow> 's"
locale map_sng = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sng :: "'u \<Rightarrow> 'v \<Rightarrow> 's"
  assumes sng_correct :
    "\<alpha> (sng k v) = [k \<mapsto> v]"
    "invar (sng k v)"

type_synonym ('k,'v,'s) map_isSng = "'s \<Rightarrow> bool"
locale map_isSng = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'k \<rightharpoonup> 'v"
  fixes isSng :: "'s \<Rightarrow> bool"
  assumes isSng_correct:
    "invar s \<Longrightarrow> isSng s \<longleftrightarrow> (\<exists>k v. \<alpha> s = [k \<mapsto> v])"
begin
  lemma isSng_correct_exists1 :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (\<exists>!k. \<exists>v. (\<alpha> s k = Some v)))"
    apply (auto simp add: isSng_correct split: split_if_asm)
    apply (rule_tac x=k in exI)
    apply (rule_tac x=v in exI)
    apply (rule ext)
    apply (case_tac "\<alpha> s x")
    apply auto
    apply force
    done

  lemma isSng_correct_card :
    "invar s \<Longrightarrow> (isSng s \<longleftrightarrow> (card (dom (\<alpha> s)) = 1))"
    by (auto simp add: isSng_correct card_Suc_eq dom_eq_singleton_conv)

end

subsubsection "Finite Maps"
locale finite_map = map +
  assumes finite[simp, intro!]: "invar m \<Longrightarrow> finite (dom (\<alpha> m))"

subsubsection "Size"
type_synonym ('k,'v,'s) map_size = "'s \<Rightarrow> nat"
locale map_size = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes size :: "'s \<Rightarrow> nat"
  assumes size_correct: "invar s \<Longrightarrow> size s = card (dom (\<alpha> s))"

type_synonym ('k,'v,'s) map_size_abort = "nat \<Rightarrow> 's \<Rightarrow> nat"
locale map_size_abort = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes size_abort :: "nat \<Rightarrow> 's \<Rightarrow> nat"
  assumes size_abort_correct: "invar s \<Longrightarrow> size_abort m s = min m (card (dom (\<alpha> s)))"

subsubsection "Iterators"
text {*
  An iteration combinator over a map applies a function to a state for each
  map entry, in arbitrary order.
  Proving of properties is done by invariant reasoning.
  An iterator can also contain a continuation condition. Iteration is
  interrupted if the condition becomes false.
*}

(* Deprecated *)
(*locale map_iteratei = finite_map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes iteratei :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"

  assumes iteratei_rule: "invar m \<Longrightarrow> map_iterator (iteratei m) (\<alpha> m)"
begin
  lemma iteratei_rule_P:
    assumes "invar m"
        and I0: "I (dom (\<alpha> m)) \<sigma>0"
        and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                    \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
        and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
        and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iteratei_rule_insert_P:
    assumes
      "invar m"
      "I {} \<sigma>0"
      "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
          \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
      "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
      "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
               \<not> (c \<sigma>);
               I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using map_iterator_rule_insert_P [OF iteratei_rule, of m I \<sigma>0 c f P]
    by (simp_all add: assms)

  lemma iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast

  lemma iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by fast
end

lemma map_iteratei_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator (iti m) (\<alpha> m)"
  shows "map_iteratei \<alpha> invar iti"
proof
  fix m
  assume invar_m: "invar m"
  from assms(1)[OF invar_m] show it_OK: "map_iterator (iti m) (\<alpha> m)" .

  from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_def]]
  show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
qed
*)

type_synonym ('k,'v,'s) map_list_it
  = "'s \<Rightarrow> ('k\<times>'v,('k\<times>'v) list) set_iterator"
locale poly_map_iteratei_defs =
  fixes list_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition iteratei :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "iteratei S \<equiv> it_to_it (list_it S)"

  abbreviation "iterate m \<equiv> iteratei m (\<lambda>_. True)"
end

locale poly_map_iteratei =
  finite_map + poly_map_iteratei_defs list_it
  for list_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  assumes list_it_correct: "invar m \<Longrightarrow> map_iterator (list_it m) (\<alpha> m)"
begin
  lemma iteratei_correct: "invar S \<Longrightarrow> map_iterator (iteratei S) (\<alpha> S)"
    unfolding iteratei_def
    apply (rule it_to_it_correct)
    by (rule list_it_correct)

  lemma pi_iteratei[icf_proper_iteratorI]:
    "proper_it (iteratei S) (iteratei S)"
    unfolding iteratei_def
    by (intro icf_proper_iteratorI)

  lemma iteratei_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; (k,v) \<in> it; it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {(k,v)}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> map_to_set (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    apply (rule set_iterator_rule_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: IP)
    apply fact
    apply fact
    done

  lemma iteratei_rule_insert_P:
    assumes "invar m"
    and "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> c \<sigma>; (k,v) \<in> (map_to_set (\<alpha> m) - it);
                       it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert (k,v) it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (map_to_set (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    and "!!\<sigma> it. \<lbrakk> it \<subseteq> map_to_set (\<alpha> m); it \<noteq> map_to_set (\<alpha> m);
                  \<not> (c \<sigma>);
                  I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    apply (rule set_iterator_rule_insert_P[OF iteratei_correct])
    apply fact
    apply fact
    apply (case_tac x, simp add: assms)
    apply fact
    apply fact
    done

  lemma iterate_rule_P:
    assumes "invar m"
    and I0: "I (map_to_set (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> (k,v) \<in> it; it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {(k,v)}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterate m f \<sigma>0)"
    apply (rule iteratei_rule_P)
    apply fact
    apply (rule I0)
    apply (rule IP, assumption+) []
    apply (rule IF, assumption)
    apply simp
    done

  lemma iterate_rule_insert_P:
    assumes "invar m"
    and I0: "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> (k,v) \<in> (map_to_set (\<alpha> m) - it);
                       it \<subseteq> map_to_set (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert (k,v) it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (map_to_set (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterate m f \<sigma>0)"
    apply (rule iteratei_rule_insert_P)
    apply fact
    apply (rule I0)
    apply (rule assms, assumption+) []
    apply (rule assms, assumption)
    apply simp
    done

  lemma old_iteratei_rule_P:
    assumes "invar m"
    and I0: "I (dom (\<alpha> m)) \<sigma>0"
    and IP: "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    and IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    and II: "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> {}; \<not> c \<sigma>; I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using assms
    by (rule map_iterator_rule_P[OF iteratei_correct])

  lemma old_iteratei_rule_insert_P:
    assumes "invar m"
    and "I {} \<sigma>0"
    and "!!k v it \<sigma>. \<lbrakk> c \<sigma>; k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v;
                       it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
      \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>)"
    and "!!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>"
    and "!!\<sigma> it. \<lbrakk> it \<subseteq> dom (\<alpha> m); it \<noteq> dom (\<alpha> m);
                  \<not> (c \<sigma>);
                  I it \<sigma> \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iteratei m c f \<sigma>0)"
    using assms by (rule map_iterator_rule_insert_P[OF iteratei_correct])

  lemma old_iterate_rule_P:
    "\<lbrakk>
      invar m;
      I (dom (\<alpha> m)) \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> it; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>);
      !!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iterate m f \<sigma>0)"
    using old_iteratei_rule_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

  lemma old_iterate_rule_insert_P:
    "\<lbrakk>
      invar m;
      I {} \<sigma>0;
      !!k v it \<sigma>. \<lbrakk> k \<in> (dom (\<alpha> m) - it); \<alpha> m k = Some v;
                    it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (insert k it) (f (k, v) \<sigma>);
      !!\<sigma>. I (dom (\<alpha> m)) \<sigma> \<Longrightarrow> P \<sigma>
    \<rbrakk> \<Longrightarrow> P (iteratei m (\<lambda>_. True) f \<sigma>0)"
    using old_iteratei_rule_insert_P [of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

  end

subsubsection "Bounded Quantification"
type_synonym ('k,'v,'s) map_ball = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
locale map_ball = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes ball :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
  assumes ball_correct: "invar m \<Longrightarrow> ball m P \<longleftrightarrow> (\<forall>u v. \<alpha> m u = Some v \<longrightarrow> P (u, v))"

type_synonym ('k,'v,'s) map_bex = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
locale map_bex = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes bex :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> bool"
  assumes bex_correct:
    "invar m \<Longrightarrow> bex m P \<longleftrightarrow> (\<exists>u v. \<alpha> m u = Some v \<and> P (u, v))"

subsubsection "Selection of Entry"
type_synonym ('k,'v,'s,'r) map_sel = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> 'r option) \<Rightarrow> 'r option"
locale map_sel = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sel :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> 'r option) \<Rightarrow> 'r option"
  assumes selE:
  "\<lbrakk> invar m; \<alpha> m u = Some v; f (u, v) = Some r;
     !!u v r. \<lbrakk> sel m f = Some r; \<alpha> m u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  assumes selI:
    "\<lbrakk> invar m; \<forall>u v. \<alpha> m u = Some v \<longrightarrow> f (u, v) = None \<rbrakk> \<Longrightarrow> sel m f = None"

begin
  lemma sel_someE:
    "\<lbrakk> invar m; sel m f = Some r;
       !!u v. \<lbrakk> \<alpha> m u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
    apply (cases "\<exists>u v r. \<alpha> m u = Some v \<and> f (u, v) = Some r")
    apply safe
    apply (erule_tac u=u and v=v and r=ra in selE)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) selI)
    apply simp
    done

  lemma sel_noneD: "\<lbrakk>invar m; sel m f = None; \<alpha> m u = Some v\<rbrakk> \<Longrightarrow> f (u, v) = None"
    apply (rule ccontr)
    apply simp
    apply (erule exE)
    apply (erule_tac f=f and u=u and v=v and r=y in selE)
    apply auto
    done

end

  -- "Equivalent description of sel-map properties"
lemma map_sel_altI:
  assumes S1:
    "!!s f r P. \<lbrakk> invar s; sel s f = Some r;
                  !!u v. \<lbrakk>\<alpha> s u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P
                \<rbrakk> \<Longrightarrow> P"
  assumes S2:
    "!!s f u v. \<lbrakk>invar s; sel s f = None; \<alpha> s u = Some v\<rbrakk> \<Longrightarrow> f (u, v) = None"
  shows "map_sel \<alpha> invar sel"
proof -
  show ?thesis
    apply (unfold_locales)
    apply (case_tac "sel m f")
    apply (force dest: S2)
    apply (force elim: S1)
    apply (case_tac "sel m f")
    apply assumption
    apply (force elim: S1)
    done
qed

subsubsection "Selection of Entry (without mapping)"
type_synonym ('k,'v,'s) map_sel' = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) option"
locale map_sel' = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes sel' :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u\<times>'v) option"
  assumes sel'E:
  "\<lbrakk> invar m; \<alpha> m u = Some v; P (u, v);
     !!u v. \<lbrakk> sel' m P = Some (u,v); \<alpha> m u = Some v; P (u, v)\<rbrakk> \<Longrightarrow> Q
   \<rbrakk> \<Longrightarrow> Q"
  assumes sel'I:
    "\<lbrakk> invar m; \<forall>u v. \<alpha> m u = Some v \<longrightarrow> \<not> P (u, v) \<rbrakk> \<Longrightarrow> sel' m P = None"

begin
  lemma sel'_someE:
    "\<lbrakk> invar m; sel' m P = Some (u,v);
       !!u v. \<lbrakk> \<alpha> m u = Some v; P (u, v) \<rbrakk> \<Longrightarrow> thesis
     \<rbrakk> \<Longrightarrow> thesis"
    apply (cases "\<exists>u v. \<alpha> m u = Some v \<and> P (u, v)")
    apply safe
    apply (erule_tac u=ua and v=va in sel'E)
    apply assumption
    apply assumption
    apply simp
    apply (auto)
    apply (drule (1) sel'I)
    apply simp
    done

  lemma sel'_noneD: "\<lbrakk>invar m; sel' m P = None; \<alpha> m u = Some v\<rbrakk> \<Longrightarrow> \<not> P (u, v)"
    apply (rule ccontr)
    apply simp
    apply (erule (2) sel'E[where P=P])
    apply auto
    done

  lemma sel'_SomeD:
    "\<lbrakk> sel' m P = Some (u, v); invar m \<rbrakk> \<Longrightarrow> \<alpha> m u = Some v \<and> P (u, v)"
    apply(cases "\<exists>u' v'. \<alpha> m u' = Some v' \<and> P (u', v')")
     apply clarsimp
     apply(erule (2) sel'E[where P=P])
     apply simp
    apply(clarsimp)
    apply(drule (1) sel'I)
    apply simp
    done
end

subsubsection "Map to List Conversion"
type_synonym ('k,'v,'s) map_to_list = "'s \<Rightarrow> ('k\<times>'v) list"
locale map_to_list = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes to_list :: "'s \<Rightarrow> ('u\<times>'v) list"
  assumes to_list_correct:
    "invar m \<Longrightarrow> map_of (to_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_list m))"

subsubsection "List to Map Conversion"
type_synonym ('k,'v,'s) list_to_map = "('k\<times>'v) list \<Rightarrow> 's"
locale list_to_map = map +
  constrains \<alpha> :: "'s \<Rightarrow> 'u \<rightharpoonup> 'v"
  fixes to_map :: "('u\<times>'v) list \<Rightarrow> 's"
  assumes to_map_correct:
    "\<alpha> (to_map l) = map_of l"
    "invar (to_map l)"

subsubsection "Image of a Map"

text {* This locale allows to apply a function to both the keys and
 the values of a map while at the same time filtering entries. *}

definition transforms_to_unique_keys ::
  "('u1 \<rightharpoonup> 'v1) \<Rightarrow> ('u1 \<times> 'v1 \<rightharpoonup> ('u2 \<times> 'v2)) \<Rightarrow> bool"
  where
  "transforms_to_unique_keys m f \<equiv> (\<forall>k1 k2 v1 v2 k' v1' v2'. (
         m k1 = Some v1 \<and>
         m k2 = Some v2 \<and>
         f (k1, v1) = Some (k', v1') \<and>
         f (k2, v2) = Some (k', v2')) -->
       (k1 = k2))"

type_synonym ('k1,'v1,'m1,'k2,'v2,'m2) map_image_filter
  = "('k1 \<times> 'v1 \<Rightarrow> ('k2 \<times> 'v2) option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"

locale map_image_filter = m1!: map \<alpha>1 invar1 + m2!: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u1 \<rightharpoonup> 'v1" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u2 \<rightharpoonup> 'v2" and invar2
  +
  fixes map_image_filter :: "('u1 \<times> 'v1 \<Rightarrow> ('u2 \<times> 'v2) option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes map_image_filter_correct_aux1:
    "\<And>k' v'.
     \<lbrakk>invar1 m; transforms_to_unique_keys (\<alpha>1 m) f\<rbrakk> \<Longrightarrow>
     (invar2 (map_image_filter f m) \<and>
      ((\<alpha>2 (map_image_filter f m) k' = Some v') \<longleftrightarrow>
       (\<exists>k v. (\<alpha>1 m k = Some v) \<and> f (k, v) = Some (k', v'))))"
begin

  (*Let's use a definition for the precondition *)

  lemma map_image_filter_correct_aux2 :
    assumes "invar1 m"
      and "transforms_to_unique_keys (\<alpha>1 m) f"
    shows "(\<alpha>2 (map_image_filter f m) k' = None) \<longleftrightarrow>
      (\<forall>k v v'. \<alpha>1 m k = Some v \<longrightarrow> f (k, v) \<noteq> Some (k', v'))"
  proof -
    note map_image_filter_correct_aux1 [OF assms]
    have Some_eq: "\<And>v'. (\<alpha>2 (map_image_filter f m) k' = Some v') =
          (\<exists>k v. \<alpha>1 m k = Some v \<and> f (k, v) = Some (k', v'))"
      by (simp add: map_image_filter_correct_aux1 [OF assms])

    have intro_some: "(\<alpha>2 (map_image_filter f m) k' = None) \<longleftrightarrow>
                      (\<forall>v'. \<alpha>2 (map_image_filter f m) k' \<noteq> Some v')" by auto

    from intro_some Some_eq show ?thesis by auto
  qed

  lemmas map_image_filter_correct =
     conjunct1 [OF map_image_filter_correct_aux1]
     conjunct2 [OF map_image_filter_correct_aux1]
     map_image_filter_correct_aux2
end

text {* Most of the time the mapping function is only applied to values. Then,
  the precondition disapears.*}
type_synonym ('k,'v1,'m1,'k2,'v2,'m2) map_value_image_filter
  = "('k \<Rightarrow> 'v1 \<Rightarrow> 'v2 option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"

locale map_value_image_filter = m1!: map \<alpha>1 invar1 + m2!: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u \<rightharpoonup> 'v1" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u \<rightharpoonup> 'v2" and invar2
  +
  fixes map_value_image_filter :: "('u \<Rightarrow> 'v1 \<Rightarrow> 'v2 option) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes map_value_image_filter_correct_aux:
    "invar1 m \<Longrightarrow>
     invar2 (map_value_image_filter f m) \<and>
     (\<alpha>2 (map_value_image_filter f m) =
      (\<lambda>k. Option.bind (\<alpha>1 m k) (f k)))"
begin

  lemmas map_value_image_filter_correct =
    conjunct1[OF map_value_image_filter_correct_aux]
    conjunct2[OF map_value_image_filter_correct_aux]

  lemma map_value_image_filter_correct_alt :
    "invar1 m \<Longrightarrow>
     invar2 (map_value_image_filter f m)"
    "invar1 m \<Longrightarrow>
     (\<alpha>2 (map_value_image_filter f m) k = Some v') \<longleftrightarrow>
     (\<exists>v. (\<alpha>1 m k = Some v) \<and> f k v = Some v')"
    "invar1 m \<Longrightarrow>
     (\<alpha>2 (map_value_image_filter f m) k = None) \<longleftrightarrow>
     (\<forall>v. (\<alpha>1 m k = Some v) --> f k v = None)"
  proof -
    assume invar_m : "invar1 m"
    note aux = map_value_image_filter_correct_aux [OF invar_m]

    from aux show "invar2 (map_value_image_filter f m)" by simp
    from aux show "(\<alpha>2 (map_value_image_filter f m) k = Some v') \<longleftrightarrow>
     (\<exists>v. (\<alpha>1 m k = Some v) \<and> f k v = Some v')"
      by (cases "\<alpha>1 m k", simp_all)
    from aux show "(\<alpha>2 (map_value_image_filter f m) k = None) \<longleftrightarrow>
     (\<forall>v. (\<alpha>1 m k = Some v) --> f k v = None)"
      by (cases "\<alpha>1 m k", simp_all)
  qed
end

type_synonym ('k,'v,'m1,'m2) map_restrict = "('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
locale map_restrict = m1!: map \<alpha>1 invar1 + m2!: map \<alpha>2 invar2
  for \<alpha>1 :: "'m1 \<Rightarrow> 'u \<rightharpoonup> 'v" and invar1
  and \<alpha>2 :: "'m2 \<Rightarrow> 'u \<rightharpoonup> 'v" and invar2
  +
  fixes restrict :: "('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> 'm1 \<Rightarrow> 'm2"
  assumes restrict_correct_aux1 :
    "invar1 m \<Longrightarrow> \<alpha>2 (restrict P m) = \<alpha>1 m |` {k. \<exists>v. \<alpha>1 m k = Some v \<and> P (k, v)}"
    "invar1 m \<Longrightarrow> invar2 (restrict P m)"
begin
  lemma restrict_correct_aux2 :
    "invar1 m \<Longrightarrow> \<alpha>2 (restrict (\<lambda>(k,_). P k) m) = \<alpha>1 m |` {k. P k}"
  proof -
    assume invar_m : "invar1 m"
    have "\<alpha>1 m |` {k. (\<exists>v. \<alpha>1 m k = Some v) \<and> P k} = \<alpha>1 m |` {k. P k}"
      (is "\<alpha>1 m |` ?A1 = \<alpha>1 m |` ?A2")
    proof
      fix k
      show "(\<alpha>1 m |` ?A1) k = (\<alpha>1 m |` ?A2) k"
      proof (cases "k \<in> ?A2")
        case False thus ?thesis by simp
      next
        case True
        hence P_k : "P k" by simp

        show ?thesis
          by (cases "\<alpha>1 m k", simp_all add: P_k)
      qed
    qed
    with invar_m show "\<alpha>2 (restrict (\<lambda>(k, _). P k) m) = \<alpha>1 m |` {k. P k}"
      by (simp add: restrict_correct_aux1)
  qed

  lemmas restrict_correct =
     restrict_correct_aux1
     restrict_correct_aux2
end

subsection "Ordered Maps"
  locale ordered_map = map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar

  locale ordered_finite_map = finite_map \<alpha> invar + ordered_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar

subsubsection {* Ordered Iteration *}
  (* Deprecated *)
(*
  locale map_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_linord (iterateoi m) (\<alpha> m)"
  begin
    lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<le>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m c f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk> k \<in> it; \<forall>j\<in>it. k\<le>j; \<forall>j\<in>dom (\<alpha> m) - it. j\<le>k; \<alpha> m k = Some v; it \<subseteq> dom (\<alpha> m); I it \<sigma> \<rbrakk>
                  \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_linord_rule_P [OF iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_linord (itoi m) (\<alpha> m)"
  shows "map_iterateoi \<alpha> invar itoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_linord (itoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed

  locale map_reverse_iterateoi = ordered_finite_map \<alpha> invar
    for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v" and invar
    +
    fixes reverse_iterateoi :: "'s \<Rightarrow> ('u \<times> 'v,'\<sigma>) set_iterator"
    assumes reverse_iterateoi_rule: "
      invar m \<Longrightarrow> map_iterator_rev_linord (reverse_iterateoi m) (\<alpha> m)"
  begin
    lemma reverse_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        c \<sigma>;
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      assumes II: "!!\<sigma> it. \<lbrakk>
        it \<subseteq> dom (\<alpha> m);
        it \<noteq> {};
        \<not> c \<sigma>;
        I it \<sigma>;
        \<forall>k\<in>it. \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k
      \<rbrakk> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m c f \<sigma>0)"
    using map_iterator_rev_linord_rule_P [OF reverse_iterateoi_rule, of m I \<sigma>0 c f P] assms
    by simp

    lemma reverse_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
      assumes MINV: "invar m"
      assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
      assumes IP: "!!k v it \<sigma>. \<lbrakk>
        k \<in> it;
        \<forall>j\<in>it. k\<ge>j;
        \<forall>j\<in>dom (\<alpha> m) - it. j\<ge>k;
        \<alpha> m k = Some v;
        it \<subseteq> dom (\<alpha> m);
        I it \<sigma>
      \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
      assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
      shows "P (reverse_iterateoi m (\<lambda>_. True) f \<sigma>0)"
    using map_iterator_rev_linord_rule_P[OF reverse_iterateoi_rule, of m I \<sigma>0 "\<lambda>_. True" f P] assms
    by simp
  end

  lemma map_reverse_iterateoi_I :
  assumes "\<And>m. invar m \<Longrightarrow> map_iterator_rev_linord (ritoi m) (\<alpha> m)"
  shows "map_reverse_iterateoi \<alpha> invar ritoi"
  proof
    fix m
    assume invar_m: "invar m"
    from assms(1)[OF invar_m] show it_OK: "map_iterator_rev_linord (ritoi m) (\<alpha> m)" .

    from set_iterator_genord.finite_S0 [OF it_OK[unfolded set_iterator_map_rev_linord_def]]
    show "finite (dom (\<alpha> m))" by (simp add: finite_map_to_set)
  qed
*)

locale poly_map_iterateoi_defs =
  fixes olist_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition iterateoi :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "iterateoi S \<equiv> it_to_it (olist_it S)"

  abbreviation "iterateo m \<equiv> iterateoi m (\<lambda>_. True)"
end

locale poly_map_iterateoi =
  finite_map \<alpha> invar + poly_map_iterateoi_defs list_ordered_it
  for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v"
  and invar
  and list_ordered_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  assumes list_ordered_it_correct: "invar m
    \<Longrightarrow> map_iterator_linord (list_ordered_it m) (\<alpha> m)"
begin
  lemma iterateoi_correct: "invar S \<Longrightarrow> map_iterator_linord (iterateoi S) (\<alpha> S)"
    unfolding iterateoi_def
    apply (rule it_to_it_map_linord_correct)
    by (rule list_ordered_it_correct)

  lemma pi_iterateoi[icf_proper_iteratorI]:
    "proper_it (iterateoi S) (iterateoi S)"
    unfolding iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<le>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> dom (\<alpha> m);
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<And>k j. \<lbrakk>k\<in>it; j\<in>dom (\<alpha> m) - it\<rbrakk> \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (iterateoi m c f \<sigma>0)"
    using assms by (rule map_iterator_linord_rule_P[OF iterateoi_correct])

  lemma iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<le>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<le>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (iterateo m f \<sigma>0)"
    using assms
      map_iterator_linord_rule_P[OF iterateoi_correct, of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

end

type_synonym ('k,'v,'s) map_list_rev_it
  = "'s \<Rightarrow> ('k\<times>'v,('k\<times>'v) list) set_iterator"

locale poly_map_rev_iterateoi_defs =
  fixes list_rev_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator"
begin
  definition rev_iterateoi :: "'s \<Rightarrow> ('u\<times>'v,'\<sigma>) set_iterator"
    where "rev_iterateoi S \<equiv> it_to_it (list_rev_it S)"

  abbreviation "rev_iterateo m \<equiv> rev_iterateoi m (\<lambda>_. True)"
  abbreviation "reverse_iterateoi \<equiv> rev_iterateoi"
  abbreviation "reverse_iterateo \<equiv> rev_iterateo"
end

locale poly_map_rev_iterateoi =
  finite_map \<alpha> invar + poly_map_rev_iterateoi_defs list_rev_it
  for \<alpha> :: "'s \<Rightarrow> ('u::linorder) \<rightharpoonup> 'v"
  and invar
  and list_rev_it :: "'s \<Rightarrow> ('u\<times>'v,('u\<times>'v) list) set_iterator" +
  assumes list_rev_it_correct:
    "invar m \<Longrightarrow> map_iterator_rev_linord (list_rev_it m) (\<alpha> m)"
begin
  lemma rev_iterateoi_correct:
    "invar S \<Longrightarrow> map_iterator_rev_linord (rev_iterateoi S) (\<alpha> S)"
    unfolding rev_iterateoi_def
    apply (rule it_to_it_map_rev_linord_correct)
    by (rule list_rev_it_correct)

  lemma pi_rev_iterateoi[icf_proper_iteratorI]:
    "proper_it (rev_iterateoi S) (rev_iterateoi S)"
    unfolding rev_iterateoi_def
    by (intro icf_proper_iteratorI)

  lemma rev_iterateoi_rule_P[case_names minv inv0 inv_pres i_complete i_inter]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      c \<sigma>;
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<ge>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    assumes II: "!!\<sigma> it. \<lbrakk>
      it \<subseteq> dom (\<alpha> m);
      it \<noteq> {};
      \<not> c \<sigma>;
      I it \<sigma>;
      \<And>k j. \<lbrakk>k\<in>it; j\<in>dom (\<alpha> m) - it\<rbrakk> \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> P \<sigma>"
    shows "P (rev_iterateoi m c f \<sigma>0)"
    using assms by (rule map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct])

  lemma rev_iterateo_rule_P[case_names minv inv0 inv_pres i_complete]:
    assumes MINV: "invar m"
    assumes I0: "I (dom (\<alpha> m)) \<sigma>0"
    assumes IP: "!!k v it \<sigma>. \<lbrakk>
      k \<in> it;
      \<alpha> m k = Some v;
      it \<subseteq> dom (\<alpha> m);
      I it \<sigma>;
      \<And>j. j\<in>it \<Longrightarrow> k\<ge>j;
      \<And>j. j\<in>dom (\<alpha> m) - it \<Longrightarrow> j\<ge>k
    \<rbrakk> \<Longrightarrow> I (it - {k}) (f (k, v) \<sigma>)"
    assumes IF: "!!\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
    shows "P (rev_iterateo m f \<sigma>0)"
    using assms
      map_iterator_rev_linord_rule_P[OF rev_iterateoi_correct,
        of m I \<sigma>0 "\<lambda>_. True" f P]
    by blast

end

subsubsection {* Minimal and Maximal Elements *}

  type_synonym ('k,'v,'s) map_min
    = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
  locale map_min = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes min :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u \<times> 'v) option"
    assumes min_correct:
      "\<lbrakk> invar s; rel_of (\<alpha> s) P \<noteq> {} \<rbrakk> \<Longrightarrow> min s P \<in> Some ` rel_of (\<alpha> s) P"
      "\<lbrakk> invar s; (k,v) \<in> rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> fst (the (min s P)) \<le> k"
      "\<lbrakk> invar s; rel_of (\<alpha> s) P = {} \<rbrakk> \<Longrightarrow> min s P = None"
  begin
   lemma minE:
     assumes A: "invar s" "rel_of (\<alpha> s) P \<noteq> {}"
     obtains k v where
     "min s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P" "\<forall>(k',v')\<in>rel_of (\<alpha> s) P. k \<le> k'"
   proof -
     from min_correct(1)[OF A] have MIS: "min s P \<in> Some ` rel_of (\<alpha> s) P" .
     then obtain k v where KV: "min s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule min_correct(2)[OF `invar s`])
       apply (simp add: KV(1))
       done
   qed

   lemmas minI = min_correct(3)

   lemma min_Some:
     "\<lbrakk> invar s; min s P = Some (k,v) \<rbrakk> \<Longrightarrow> (k,v)\<in>rel_of (\<alpha> s) P"
     "\<lbrakk> invar s; min s P = Some (k,v); (k',v')\<in>rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> k\<le>k'"
     apply -
     apply (cases "rel_of (\<alpha> s) P = {}")
     apply (drule (1) min_correct(3))
     apply simp
     apply (erule (1) minE)
     apply auto [1]
     apply (drule (1) min_correct(2))
     apply auto
     done

   lemma min_None:
     "\<lbrakk> invar s; min s P = None \<rbrakk> \<Longrightarrow> rel_of (\<alpha> s) P = {}"
     apply (cases "rel_of (\<alpha> s) P = {}")
     apply simp
     apply (drule (1) min_correct(1))
     apply auto
     done

  end

  type_synonym ('k,'v,'s) map_max
    = "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
  locale map_max = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes max :: "'s \<Rightarrow> ('u \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('u \<times> 'v) option"
    assumes max_correct:
      "\<lbrakk> invar s; rel_of (\<alpha> s) P \<noteq> {} \<rbrakk> \<Longrightarrow> max s P \<in> Some ` rel_of (\<alpha> s) P"
      "\<lbrakk> invar s; (k,v) \<in> rel_of (\<alpha> s) P \<rbrakk> \<Longrightarrow> fst (the (max s P)) \<ge> k"
      "\<lbrakk> invar s; rel_of (\<alpha> s) P = {} \<rbrakk> \<Longrightarrow> max s P = None"
  begin
   lemma maxE:
     assumes A: "invar s" "rel_of (\<alpha> s) P \<noteq> {}"
     obtains k v where
     "max s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P" "\<forall>(k',v')\<in>rel_of (\<alpha> s) P. k \<ge> k'"
   proof -
     from max_correct(1)[OF A] have MIS: "max s P \<in> Some ` rel_of (\<alpha> s) P" .
     then obtain k v where KV: "max s P = Some (k,v)" "(k,v)\<in>rel_of (\<alpha> s) P"
       by auto
     show thesis
       apply (rule that[OF KV])
       apply (clarify)
       apply (drule max_correct(2)[OF `invar s`])
       apply (simp add: KV(1))
       done
   qed

   lemmas maxI = max_correct(3)

  end

subsubsection "Conversion to List"
  type_synonym ('k,'v,'s) map_to_sorted_list
    = "'s \<Rightarrow> ('k \<times> 'v) list"
  locale map_to_sorted_list = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes to_sorted_list :: "'s \<Rightarrow> ('u\<times>'v) list"
    assumes to_sorted_list_correct:
    "invar m \<Longrightarrow> map_of (to_sorted_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_sorted_list m))"
    "invar m \<Longrightarrow> sorted (map fst (to_sorted_list m))"

  type_synonym ('k,'v,'s) map_to_rev_list
    = "'s \<Rightarrow> ('k \<times> 'v) list"
  locale map_to_rev_list = ordered_map +
    constrains \<alpha> :: "'s \<Rightarrow> 'u::linorder \<rightharpoonup> 'v"
    fixes to_rev_list :: "'s \<Rightarrow> ('u\<times>'v) list"
    assumes to_rev_list_correct:
    "invar m \<Longrightarrow> map_of (to_rev_list m) = \<alpha> m"
    "invar m \<Longrightarrow> distinct (map fst (to_rev_list m))"
    "invar m \<Longrightarrow> sorted (rev (map fst (to_rev_list m)))"

subsection "Record Based Interface"

  record ('k,'v,'s) map_ops =
    map_op_\<alpha> :: "('k,'v,'s) map_\<alpha>"
    map_op_invar :: "('k,'v,'s) map_invar"
    map_op_empty :: "('k,'v,'s) map_empty"
    map_op_lookup :: "('k,'v,'s) map_lookup"
    map_op_update :: "('k,'v,'s) map_update"
    map_op_update_dj :: "('k,'v,'s) map_update_dj"
    map_op_delete :: "('k,'v,'s) map_delete"
    map_op_list_it :: "('k,'v,'s) map_list_it"
    map_op_sng :: "('k,'v,'s) map_sng"
    map_op_restrict :: "('k,'v,'s,'s) map_restrict"
    map_op_add :: "('k,'v,'s) map_add"
    map_op_add_dj :: "('k,'v,'s) map_add_dj"
    map_op_isEmpty :: "('k,'v,'s) map_isEmpty"
    map_op_isSng :: "('k,'v,'s) map_isSng"
    map_op_ball :: "('k,'v,'s) map_ball"
    map_op_bex :: "('k,'v,'s) map_bex"
    map_op_size :: "('k,'v,'s) map_size"
    map_op_size_abort :: "('k,'v,'s) map_size_abort"
    map_op_sel :: "('k,'v,'s) map_sel'"
    map_op_to_list :: "('k,'v,'s) map_to_list"
    map_op_to_map :: "('k,'v,'s) list_to_map"

  locale StdMapDefs = poly_map_iteratei_defs "map_op_list_it ops"
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> == map_op_\<alpha> ops"
    abbreviation invar where "invar == map_op_invar ops"
    abbreviation empty where "empty == map_op_empty ops"
    abbreviation lookup where "lookup == map_op_lookup ops"
    abbreviation update where "update == map_op_update ops"
    abbreviation update_dj where "update_dj == map_op_update_dj ops"
    abbreviation delete where "delete == map_op_delete ops"
    abbreviation list_it where "list_it == map_op_list_it ops"
    abbreviation sng where "sng == map_op_sng ops"
    abbreviation restrict where "restrict == map_op_restrict ops"
    abbreviation add where "add == map_op_add ops"
    abbreviation add_dj where "add_dj == map_op_add_dj ops"
    abbreviation isEmpty where "isEmpty == map_op_isEmpty ops"
    abbreviation isSng where "isSng == map_op_isSng ops"
    abbreviation ball where "ball == map_op_ball ops"
    abbreviation bex where "bex == map_op_bex ops"
    abbreviation size where "size == map_op_size ops"
    abbreviation size_abort where "size_abort == map_op_size_abort ops"
    abbreviation sel where "sel == map_op_sel ops"
    abbreviation to_list where "to_list == map_op_to_list ops"
    abbreviation to_map where "to_map == map_op_to_map ops"
  end

  locale StdMap = StdMapDefs 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 +
    map_sng \<alpha> invar sng  +
    map_restrict \<alpha> invar \<alpha> invar restrict +
    map_add \<alpha> invar add  +
    map_add_dj \<alpha> invar add_dj +
    map_isEmpty \<alpha> invar isEmpty  +
    map_isSng \<alpha> invar isSng  +
    map_ball \<alpha> invar ball  +
    map_bex \<alpha> invar bex  +
    map_size \<alpha> invar size +
    map_size_abort \<alpha> invar size_abort +
    map_sel' \<alpha> invar sel  +
    map_to_list \<alpha> invar to_list  +
    list_to_map \<alpha> invar to_map
    for ops :: "('k,'v,'s,'more) map_ops_scheme"
  begin
    lemmas correct =
      empty_correct
      sng_correct
      lookup_correct
      update_correct
      update_dj_correct
      delete_correct
      restrict_correct
      add_correct
      add_dj_correct
      isEmpty_correct
      isSng_correct
      ball_correct
      bex_correct
      size_correct
      size_abort_correct
      to_list_correct
      to_map_correct
  end

  lemmas StdMap_intro = StdMap.intro[rem_dup_prems]

  locale StdMap_no_invar = StdMap + map_no_invar \<alpha> invar

  record ('k,'v,'s) omap_ops = "('k,'v,'s) map_ops" +
    map_op_ordered_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
    map_op_rev_list_it :: "'s \<Rightarrow> ('k,'v,('k\<times>'v) list) map_iterator"
    map_op_min :: "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
    map_op_max :: "'s \<Rightarrow> ('k \<times> 'v \<Rightarrow> bool) \<Rightarrow> ('k \<times> 'v) option"
    map_op_to_sorted_list :: "'s \<Rightarrow> ('k \<times> 'v) list"
    map_op_to_rev_list :: "'s \<Rightarrow> ('k \<times> 'v) list"

  locale StdOMapDefs = StdMapDefs ops
    + poly_map_iterateoi_defs "map_op_ordered_list_it ops"
    + poly_map_rev_iterateoi_defs "map_op_rev_list_it ops"
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
    abbreviation ordered_list_it where "ordered_list_it
      \<equiv> map_op_ordered_list_it ops"
    abbreviation rev_list_it where "rev_list_it
      \<equiv> map_op_rev_list_it ops"
    abbreviation min where "min == map_op_min ops"
    abbreviation max where "max == map_op_max ops"
    abbreviation to_sorted_list where
      "to_sorted_list \<equiv> map_op_to_sorted_list ops"
    abbreviation to_rev_list where "to_rev_list \<equiv> map_op_to_rev_list ops"
  end

  locale StdOMap =
    StdOMapDefs ops +
    StdMap ops +
    poly_map_iterateoi \<alpha> invar ordered_list_it +
    poly_map_rev_iterateoi \<alpha> invar rev_list_it +
    map_min \<alpha> invar min +
    map_max \<alpha> invar max +
    map_to_sorted_list \<alpha> invar to_sorted_list +
    map_to_rev_list \<alpha> invar to_rev_list
    for ops :: "('k::linorder,'v,'s,'more) omap_ops_scheme"
  begin
  end

  lemmas StdOMap_intro =
    StdOMap.intro[OF StdMap_intro, rem_dup_prems]

end


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

section "Solving Word Equalities"

theory Word_EqI
  imports
    More_Word
    "HOL-Eisbach.Eisbach_Tools"
begin

text \<open>
  Some word equalities can be solved by considering the problem bitwise for all
  @{prop "n < LENGTH('a::len)"}, which is different to running @{text word_bitwise}
  and expanding into an explicit list of bits.
\<close>

named_theorems word_eqI_simps

lemmas [word_eqI_simps] =
  word_ops_nth_size
  bit_mask_iff
  word_size
  word_or_zero
  neg_mask_test_bit
  nth_ucast
  nth_w2p bit_push_bit_iff
  bit_drop_bit_eq
  less_2p_is_upper_bits_unset
  le_mask_high_bits
  bang_eq
  neg_test_bit
  is_up
  is_down

lemmas word_eqI_rule = word_eqI [rule_format]

lemma test_bit_lenD:
  "bit x n \<Longrightarrow> n < LENGTH('a) \<and> bit x n" for x :: "'a :: len word"
  by (fastforce dest: test_bit_size simp: word_size)

method word_eqI uses simp simp_del split split_del cong flip =
  ((* reduce conclusion to test_bit: *)
   rule word_eqI_rule,
   (* make sure we're in clarsimp normal form: *)
   (clarsimp simp: simp simp del: simp_del simp flip: flip split: split split del: split_del cong: cong)?,
   (* turn x < 2^n assumptions into mask equations: *)
   ((drule less_mask_eq)+)?,
   (* expand and distribute test_bit everywhere: *)
   (clarsimp simp: word_eqI_simps simp simp del: simp_del simp flip: flip
             split: split split del: split_del cong: cong)?,
   (* add any additional word size constraints to new indices: *)
   ((drule test_bit_lenD)+)?,
   (* try to make progress (can't use +, would loop): *)
   (clarsimp simp: word_eqI_simps simp simp del: simp_del simp flip: flip
             split: split split del: split_del cong: cong)?,
   (* helps sometimes, rarely: *)
   (simp add: simp test_bit_conj_lt del: simp_del flip: flip split: split split del: split_del cong: cong)?)

method word_eqI_solve uses simp simp_del split split_del cong flip =
  solves \<open>word_eqI simp: simp simp_del: simp_del split: split split_del: split_del
                   cong: cong simp flip: flip;
          (fastforce dest: test_bit_size simp: word_eqI_simps simp flip: flip
                     simp: simp simp del: simp_del split: split split del: split_del cong: cong)?\<close>

end


section \<open>Shallow Embedding of LLVM Semantics\<close>
theory LLVM_Shallow
imports Main
  "LLVM_Memory"
  "../../cost/Abstract_Cost"
begin

  text \<open>We define a type synonym for the LLVM monad\<close>
  type_synonym 'a llM = "('a,unit,cost,llvm_memory,err) M"
  translations
    (type) "'a llM" \<leftharpoondown> (type) "('a, unit, (char list, nat) acost, llvm_memory, err) M"

  subsection \<open>Shallow Embedding of Values\<close>

  text \<open>We use a type class to characterize types that can be injected into the value type.
    We will instantiate this type class to obtain injections from types of shape
    \<open>T = T\<times>T | _ word | _ ptr\<close>

    Although, this type class can be instantiated by other types, those will not be accepted
    by the code generator.

    We also define a class \<open>llvm_repv\<close>, which additionally contains \<open>unit\<close>.
    This is required for void functions, and if-the-else statements that produce no result.

    Again, while this class might be instantiated for other types, those will be rejected
    by the code generator.
  \<close>

  class llvm_repv

  class llvm_rep = llvm_repv +
    fixes to_val :: "'a \<Rightarrow> llvm_val"
      and from_val :: "llvm_val \<Rightarrow> 'a"
      and struct_of :: "'a itself \<Rightarrow> llvm_vstruct"
      and init :: 'a
    assumes from_to_id[simp]: "from_val o to_val = id"
    assumes to_from_id[simp]: "llvm_vstruct v = struct_of TYPE('a) \<Longrightarrow> to_val (from_val v) = v"
    assumes struct_of_matches[simp]: "llvm_vstruct (to_val x) = (struct_of TYPE('a))"
    assumes init_zero: "to_val init = llvm_zero_initializer (struct_of TYPE('a))"

  begin

    lemma from_to_id'[simp]: "from_val (to_val x) = x"
      using pointfree_idE[OF from_to_id] .

    lemma "to_val x = to_val y \<longleftrightarrow> x=y"
      by (metis from_to_id')

  end

  text \<open>We use a phantom type to attach the type of the pointed to value to a pointer.\<close>
  datatype 'a::llvm_rep ptr = PTR (the_raw_ptr: llvm_ptr)
  definition null :: "'a::llvm_rep ptr" where "null = PTR llvm_null"

  text \<open>We instantiate the type classes for the supported types,
    i.e., unit, word, ptr, and prod.\<close>

  instance unit :: llvm_repv by standard

  instantiation word :: (len) llvm_rep begin
    definition "to_val w \<equiv> llvm_int (lconst (len_of TYPE('a)) (uint w))"
    definition "from_val v \<equiv> word_of_int (lint_to_uint (llvm_the_int v))"
    definition [simp]: "struct_of_word (_::'a word itself) \<equiv> llvm_s_int (len_of TYPE('a))"
    definition [simp]: "init_word \<equiv> 0::'a word"

    lemma int_inv_aux: "width i = LENGTH('a) \<Longrightarrow> lconst LENGTH('a) (uint (word_of_int (lint_to_uint i) :: 'a word)) = i"
      by (metis uint_const uint_eq uint_lower_bound uint_upper_bound width_lconst word_of_int_inverse word_ubin.norm_Rep)

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_word_def to_val_word_def)
      apply (auto simp: llvm_s_int_def llvm_zero_initializer_def llvm_int_def)
      subgoal for v apply (cases v)
        apply (auto simp: llvm_int_def llvm_the_int_def llvm_s_ptr_def llvm_s_pair_def)
        apply (simp add: llvm_vstruct_def int_inv_aux)
      done
      done

  end

  instantiation ptr :: (llvm_rep) llvm_rep begin
    definition "to_val \<equiv> llvm_ptr o ptr.the_raw_ptr"
    definition "from_val v \<equiv> PTR (llvm_the_ptr v)"
    definition [simp]: "struct_of_ptr (_::'a ptr itself) \<equiv> llvm_s_ptr"
    definition [simp]: "init_ptr::'a ptr \<equiv> null"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_ptr_def to_val_ptr_def)
      apply (auto simp: llvm_zero_initializer_def llvm_ptr_def llvm_s_ptr_def null_def llvm_null_def)
      subgoal for v apply (cases v)
        by (auto simp: llvm_s_int_def llvm_s_pair_def llvm_ptr_def llvm_the_ptr_def)
      done

  end

  instantiation prod :: (llvm_rep, llvm_rep) llvm_rep begin
    definition "to_val_prod \<equiv> \<lambda>(a,b). llvm_pair (to_val a) (to_val b)"
    definition "from_val_prod p \<equiv> case llvm_the_pair p of (a,b) \<Rightarrow> (from_val a, from_val b)"
    definition [simp]: "struct_of_prod (_::('a\<times>'b) itself) \<equiv> llvm_s_pair (struct_of TYPE('a)) (struct_of TYPE('b))"
    definition [simp]: "init_prod ::'a\<times>'b \<equiv> (init,init)"

    instance
      apply standard
      apply (rule ext)
      apply (auto simp: from_val_prod_def to_val_prod_def)
      apply (auto simp: llvm_pair_def llvm_s_pair_def init_zero llvm_zero_initializer_def)
      subgoal for v
        apply (cases v)
        apply (auto simp: llvm_s_int_def llvm_s_ptr_def llvm_pair_def llvm_the_pair_def
          llvm_val.the_val_def llvm_vstruct_def split: prod.splits llvm_val.splits val.split)
        done
      done

  end

  lemma to_val_prod_conv[simp]: "to_val (a,b) = llvm_pair (to_val a) (to_val b)"
    unfolding to_val_prod_def by auto

  text \<open>Checked conversion from value\<close>
  definition checked_from_val :: "llvm_val \<Rightarrow> 'a::llvm_rep llM" where
    "checked_from_val v \<equiv> doM {
      fcheck (STATIC_ERROR ''Type mismatch'') (llvm_vstruct v = struct_of TYPE('a));
      return (from_val v)
    }"

  subsection \<open>Instructions\<close>

  text \<open>The instructions are arranged in the order as they are described in the
    LLVM Language Reference Manual \<^url>\<open>https://llvm.org/docs/LangRef.html\<close>.\<close>

  subsubsection \<open>Binary Operations\<close>
  text \<open>We define a generic lifter for binary arithmetic operations.
    It is parameterized by an error condition.
  \<close> (* TODO: Use precondition instead of negated precondition! *)

  definition op_lift_arith2 :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word llM"
    where "op_lift_arith2 n ovf f a b \<equiv> doM {
    consume (cost n 1);
    let a = word_to_lint a;
    let b = word_to_lint b;
    fcheck (OVERFLOW_ERROR) (\<not>ovf a b);
    return (lint_to_word (f a b))
  }"

  definition "op_lift_arith2' n \<equiv> op_lift_arith2 n (\<lambda>_ _. False)"

  definition udivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "udivrem_is_undef a b \<equiv> lint_to_uint b=0"
  definition sdivrem_is_undef :: "lint \<Rightarrow> lint \<Rightarrow> bool"
    where "sdivrem_is_undef a b \<equiv> lint_to_sint b=0 \<or> sdivrem_ovf a b"

  definition "ll_add \<equiv> op_lift_arith2' ''add'' (+)"
  definition "ll_sub \<equiv> op_lift_arith2' ''sub'' (-)"
  definition "ll_mul \<equiv> op_lift_arith2' ''mul'' (*)"
  definition "ll_udiv \<equiv> op_lift_arith2 ''udiv'' udivrem_is_undef (div)"
  definition "ll_urem \<equiv> op_lift_arith2 ''urem'' udivrem_is_undef (mod)"
  definition "ll_sdiv \<equiv> op_lift_arith2 ''sdiv'' sdivrem_is_undef (sdiv)"
  definition "ll_srem \<equiv> op_lift_arith2 ''srem'' sdivrem_is_undef (smod)"

  subsubsection \<open>Compare Operations\<close>
  definition op_lift_cmp :: "_ \<Rightarrow> _ \<Rightarrow> 'a::len word \<Rightarrow> 'a word \<Rightarrow> 1 word llM"
    where "op_lift_cmp n f a b \<equiv> doM {
    consume (cost n 1);
    let a = word_to_lint a;
    let b = word_to_lint b;
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition op_lift_ptr_cmp :: "_ \<Rightarrow> _ \<Rightarrow> 'a::llvm_rep ptr \<Rightarrow> 'a ptr \<Rightarrow> 1 word llM"
    where "op_lift_ptr_cmp n f a b \<equiv> doM {
    consume (cost n 1);
    return (lint_to_word (bool_to_lint (f a b)))
  }"

  definition "ll_icmp_eq \<equiv>  op_lift_cmp ''icmp_eq'' (=)"
  definition "ll_icmp_ne \<equiv>  op_lift_cmp ''icmp_ne'' (\<noteq>)"
  definition "ll_icmp_sle \<equiv> op_lift_cmp ''icmp_sle'' (\<le>\<^sub>s)"
  definition "ll_icmp_slt \<equiv> op_lift_cmp ''icmp_slt'' (<\<^sub>s)"
  definition "ll_icmp_ule \<equiv> op_lift_cmp ''icmp_ule'' (\<le>)"
  definition "ll_icmp_ult \<equiv> op_lift_cmp ''icmp_ult'' (<)"

  (* For presentation in paper *)
  lemma "ll_add a b = doM {
      consume (cost ''add'' 1);
      return (a+b)
    }"
    unfolding ll_add_def op_lift_arith2'_def op_lift_arith2_def
    apply simp
    by (metis lint_word_inv word_to_lint_plus)

  text \<open>Note: There are no pointer compare instructions in LLVM.
    To compare pointers in LLVM, they have to be casted to integers first.
    However, our abstract memory model cannot assign a bit-width to pointers.

    Thus, we model pointer comparison instructions in our semantics, and let the
    code generator translate them to integer comparisons.

    Up to now, we only model pointer equality.
    For less-than, suitable preconditions are required, which are consistent with the
    actual memory layout of LLVM. We could, e.g., adopt the rules from the C standard here.
  \<close>
  definition "ll_ptrcmp_eq \<equiv> op_lift_ptr_cmp ''ptrcmp_eq'' (=)"
  definition "ll_ptrcmp_ne \<equiv> op_lift_ptr_cmp ''ptrcmp_ne'' (\<noteq>)"

  subsubsection \<open>Bitwise Binary Operations\<close>
  definition "shift_ovf a n \<equiv> nat (lint_to_uint n) \<ge> width a"
  definition "bitSHL' a n \<equiv> bitSHL a (nat (lint_to_uint n))"
  definition "bitASHR' a n \<equiv> bitASHR a (nat (lint_to_uint n))"
  definition "bitLSHR' a n \<equiv> bitLSHR a (nat (lint_to_uint n))"

  definition "ll_shl \<equiv> op_lift_arith2 ''shl'' shift_ovf bitSHL'"
  definition "ll_lshr \<equiv> op_lift_arith2 ''lshr'' shift_ovf bitLSHR'"
  definition "ll_ashr \<equiv> op_lift_arith2 ''ashr'' shift_ovf bitASHR'"

  definition "ll_and \<equiv> op_lift_arith2' ''and'' (AND)"
  definition "ll_or \<equiv> op_lift_arith2' ''or'' (OR)"
  definition "ll_xor \<equiv> op_lift_arith2' ''xor'' (XOR)"

  subsubsection \<open>Aggregate Operations\<close>
  text \<open>In LLVM, there is an \<open>extractvalue\<close> and \<open>insertvalue\<close> operation.
    In our shallow embedding, these get instantiated for \<open>fst\<close> and \<open>snd\<close>.\<close>

  definition "checked_split_pair v \<equiv> doM {
    fcheck (STATIC_ERROR ''Expected pair'') (llvm_is_pair v);
    return (llvm_the_pair v)
  }"

  (* TODO: reinsert costs for products and push it to the abstract level. *)
  definition ll_extract_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep llM" where "ll_extract_fst p = doM { \<^cancel>\<open>consume (cost ''extract_fst'' 1);\<close> (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val a }"
  definition ll_extract_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep llM" where "ll_extract_snd p = doM { \<^cancel>\<open>consume (cost ''extract_snd'' 1);\<close> (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val b }"
  definition ll_insert_fst :: "'t::llvm_rep \<Rightarrow> 't\<^sub>1::llvm_rep \<Rightarrow> 't llM" where "ll_insert_fst p x = doM { \<^cancel>\<open>consume (cost ''insert_fst'' 1);\<close> (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair (to_val x) b) }"
  definition ll_insert_snd :: "'t::llvm_rep \<Rightarrow> 't\<^sub>2::llvm_rep \<Rightarrow> 't llM" where "ll_insert_snd p x = doM { \<^cancel>\<open>consume (cost ''insert_snd'' 1);\<close> (a,b) \<leftarrow> checked_split_pair (to_val p); checked_from_val (llvm_pair a (to_val x)) }"

  (*
  definition ll_extract_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a llM" where "ll_extract_fst ab \<equiv> return (fst ab)"
  definition ll_extract_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b llM" where "ll_extract_snd ab \<equiv> return (snd ab)"
  definition ll_insert_fst :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'a \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_fst ab a \<equiv> return (a,snd ab)"
  definition ll_insert_snd :: "('a::llvm_rep \<times> 'b::llvm_rep) \<Rightarrow> 'b \<Rightarrow> ('a\<times>'b) llM" where "ll_insert_snd ab b \<equiv> return (fst ab,b)"
  *)

  subsubsection \<open>Memory Access and Addressing Operations\<close>

  definition ll_load :: "'a::llvm_rep ptr \<Rightarrow> 'a llM" where
    "ll_load p \<equiv> doM {
      consume (cost ''load'' 1);
      r \<leftarrow> llvm_load (the_raw_ptr p);
      checked_from_val r
    }"

  definition ll_store :: "'a::llvm_rep \<Rightarrow> 'a ptr \<Rightarrow> unit llM" where
    "ll_store v p \<equiv> doM {
      consume (cost ''store'' 1);
      llvm_store (to_val v) (the_raw_ptr p)
    }"

  text \<open>Note that LLVM itself does not have malloc and free instructions.
    However, these are primitive instructions in our abstract memory model,
    such that we have to model them in our semantics.

    The code generator will map them to the C standard library
    functions \<open>calloc\<close> and \<open>free\<close>.
  \<close>

  definition ll_malloc :: "'a::llvm_rep itself \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where
    "ll_malloc TYPE('a) n = doM {
      consume (cost ''malloc'' (unat n)); \<comment> \<open>DESIGN CHOICE: malloc consumes n\<close>
      fcheck MEM_ERROR (unat n > 0); \<comment> \<open>Disallow empty malloc\<close>
      r \<leftarrow> llvm_allocn (to_val (init::'a)) (unat n);
      return (PTR r)
    }"

  definition ll_free :: "'a::llvm_rep ptr \<Rightarrow> unit llM"
    where "ll_free p \<equiv> doM {
            consume (cost ''free'' 1); \<comment> \<open>DESIGN CHOICE: consume 1 \<close>
            llvm_free (the_raw_ptr p)
          }"

  text \<open>As for the aggregate operations, the \<open>getelementptr\<close> instruction is instantiated
    for pointer indexing, fst, and snd. \<close>

  \<comment> \<open>pointer arithmetic, cost 1 each\<close>

  definition ll_ofs_ptr :: "'a::llvm_rep ptr \<Rightarrow> _::len word \<Rightarrow> 'a ptr llM" where "ll_ofs_ptr p ofs = doM {
    consume (cost ''ofs_ptr'' 1);
    r \<leftarrow> llvm_checked_idx_ptr (the_raw_ptr p) (sint ofs);
    return (PTR r)
  }"

  definition ll_gep_fst :: "'p::llvm_rep ptr \<Rightarrow> 'a::llvm_rep ptr llM" where "ll_gep_fst p = doM {
    consume (cost ''gep_fst'' 1);
    fcheck (STATIC_ERROR ''gep_fst: Expected pair type'') (llvm_is_s_pair (struct_of TYPE('p)));
    r \<leftarrow> llvm_checked_gep (the_raw_ptr p) PFST;
    return (PTR r)
  }"

  definition ll_gep_snd :: "'p::llvm_rep ptr \<Rightarrow> 'b::llvm_rep ptr llM" where "ll_gep_snd p = doM {
    consume (cost ''gep_snd'' 1);
    fcheck (STATIC_ERROR ''gep_snd: Expected pair type'') (llvm_is_s_pair (struct_of TYPE('p)));
    r \<leftarrow> llvm_checked_gep (the_raw_ptr p) PSND;
    return (PTR r)
  }"

  subsubsection \<open>Conversion Operations\<close>
  definition "llb_trunc i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Trunc must go to smaller type'') (width i > w);
    return (trunc w i)
  }"

  definition "llb_sext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Sext must go to greater type'') (width i < w);
    return (sext w i)
  }"

  definition "llb_zext i w \<equiv> doM {
    fcheck (STATIC_ERROR ''Zext must go to greater type'') (width i < w);
    return (zext w i)
  }"

  definition op_lift_iconv :: "_ \<Rightarrow> _ \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word itself  \<Rightarrow> 'b word llM"
    where "op_lift_iconv n f a _ \<equiv> doM {
    consume (cost n 1);
    let a = word_to_lint a;
    let w = LENGTH('b);
    r \<leftarrow> f a w;
    return (lint_to_word r)
  }"

  definition "ll_trunc \<equiv> op_lift_iconv ''trunc'' llb_trunc"
  definition "ll_sext \<equiv> op_lift_iconv ''sext'' llb_sext"
  definition "ll_zext \<equiv> op_lift_iconv ''zext'' llb_zext"

  subsection \<open>Control Flow\<close>

  text \<open>Our shallow embedding uses a structured control flow, which allows
    only sequential composition, if-then-else, and function calls.

    The code generator then maps sequential composition to basic blocks,
    and if-then-else to a control flow graph with conditional branching.
    Function calls are mapped to LLVM function calls.
   \<close>

  text \<open>We use the to Boolean conversion from word-lib. We re-state its semantics here.\<close>

  lemma to_bool_as_lint_to_bool:
    "to_bool (w::1 word) = lint_to_bool (word_to_lint w)"
    unfolding to_bool_def word_to_lint_def
    apply (clarsimp simp: ltrue_def lfalse_def lint_to_bool_def)
    apply transfer
    apply auto
    by (metis bin_rest_BIT bin_rest_x2)

  lemma to_bool_eq[simp]: "to_bool (w::1 word) \<longleftrightarrow> w\<noteq>0"
    by (rule to_bool_neq_0)

  definition llc_if :: "1 word \<Rightarrow> 'a::llvm_repv llM \<Rightarrow> 'a llM \<Rightarrow> 'a llM" where
    "llc_if b t e \<equiv> doM {
      consume (cost ''if'' 1);
      if to_bool b then t else e
    }"

  lemma llc_if_mono[partial_function_mono]:
    "\<lbrakk>M_mono F; M_mono G\<rbrakk> \<Longrightarrow> M_mono (\<lambda>f. llc_if b (F f) (G f))"
    unfolding llc_if_def
    by pf_mono_prover

  subsubsection \<open>Function Call\<close>

  definition ll_call :: "'a llM \<Rightarrow> 'a llM" where
    "ll_call f \<equiv> doM { consume (cost ''call'' 1) ; f  }"

  lemma ll_call_mono[partial_function_mono]: "M_mono f \<Longrightarrow> M_mono (\<lambda>x. ll_call (f x))"
    unfolding ll_call_def
    by pf_mono_prover

  subsubsection \<open>Recursion with Time for Call\<close>

  definition "REC' F x = REC (\<lambda>D x. F (\<lambda>x. ll_call (D x)) x) x"

  lemma REC'_unfold:
    assumes DEF: "f \<equiv> REC' F"
    assumes MONO: "\<And>x. M.mono_body (\<lambda>fa. F (\<lambda>x. ll_call (fa x)) x)"
    shows "f = F (\<lambda>x. ll_call (f x))"
    unfolding DEF REC'_def
    apply (rewrite REC_unfold[OF reflexive MONO])
    by rule

  lemma REC'_mono[partial_function_mono]:
    assumes MONO: "\<And>D x. M.mono_body (\<lambda>E. B D (\<lambda>x. ll_call (E x)) x)"
    assumes 1: "\<And>E x. M_mono (\<lambda>D. B D (\<lambda>x. ll_call (E x)) x)"
    shows "M_mono (\<lambda>D. REC' (B D) x)"
    unfolding REC'_def
    using assms
    by pf_mono_prover

  notepad  (* TODO: cleanup *)
  begin
    \<^cancel>\<open>

    assume MONO: "\<And>x. M.mono_body (\<lambda>fa. F (\<lambda>x. ll_call (fa x)) x)"

      and DEF: "f \<equiv> REC' F"
      and F: " F  \<equiv> \<lambda>D x. (if x>0 then D (x-1) else return 0 )"
    have "P (ll_call (f x))"
      apply(rewrite REC'_unfold[OF DEF MONO])
      apply(rewrite REC'_unfold[OF DEF MONO])
      apply(rewrite REC'_unfold[OF DEF MONO])
      apply(rewrite REC'_unfold[OF DEF MONO])
      unfolding F ll_call_def sorry
  \<close>
  end

  subsubsection \<open>While-Combinator\<close>
  text \<open>
    Note that we also include the while combinator at this point, as we direct translation
    of while to a control flow graph is the default translation mode of the code generator.

    As an optional feature, while can be translated to
    a tail recursive function call, which the preprocessor can do automatically.
  \<close>

  definition llc_while :: "('a::llvm_repv \<Rightarrow> 1 word llM) \<Rightarrow> ('a \<Rightarrow> 'a llM) \<Rightarrow> 'a \<Rightarrow> 'a llM" where
    "llc_while b f s\<^sub>0 \<equiv> ll_call (REC' (\<lambda>mwhile \<sigma>. doM {
              ctd \<leftarrow> b \<sigma>;
              llc_if ctd (f \<sigma> \<bind> mwhile) (return \<sigma>)
            }) s\<^sub>0)"

  (*
  lemma gen_code_thm_llc_while:
    assumes "f \<equiv> llc_while b body"
    shows "f s = ll_call (doM { ctd \<leftarrow> b s; llc_if ctd (doM { s\<leftarrow>body s; f s}) (return s)})"
    unfolding assms
    unfolding llc_while_def llc_if_def
    apply (rewrite REC'_unfold[OF reflexive])
    apply pf_mono_prover
    by simp
  *)

  (* 'Definition' of llc_while for presentation in paper: *)
  lemma "\<And>c. llc_while b c s \<equiv> ll_call (doM {
     x \<leftarrow> b s;
     llc_if x (doM {s\<leftarrow>c s; llc_while b c s}) (return s)
   })"
    unfolding llc_while_def llc_if_def
    apply (rewrite REC'_unfold[OF reflexive])
    apply pf_mono_prover
    by simp

  lemma llc_while_mono[partial_function_mono]:
    assumes "\<And>x. M_mono (\<lambda>f. b f x)"
    assumes "\<And>x. M_mono (\<lambda>f. c f x)"
    shows "M_mono (\<lambda>D. llc_while (b D) (c D) \<sigma>)"
    using assms unfolding llc_while_def by pf_mono_prover

end


theory Normalized_Zone_Semantics_Certification2
  imports TA_Impl.Normalized_Zone_Semantics_Impl_Semantic_Refinement Labeled_Graphs
begin

text \<open>Notes:
\<^item> We already have two variants of this theory
  \<^theory>\<open>TA_Impl.Normalized_Zone_Semantics_Impl_Semantic_Refinement\<close>,
  and \<open>Certification.Normalized_Zone_Semantics_Impl_Semantic_Refinement\<close>
\<^item> They gradually refine the same techniques and theorems because we need to implement finer steps
\<^item> The latter could definitely be derived from this theory by proving theorems for coupled steps
\<^item> The first adds normalization in the last step. Could this be another coupling step?
\<^item> \<open>E_combined_op\<close> is what is \<open>E_precise_op\<close> in
  \<open>Certification.Normalized_Zone_Semantics_Impl_Semantic_Refinement\<close>
\<close>

no_notation TA_Start_Defs.step_impl' ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)

context TA_Start_Defs
begin

definition
  "E_del_op l M \<equiv>
    FW' (abstr_upd (inv_of A l) (up_canonical_upd M n)) n"

definition
  "E_del_op' l M \<equiv>
    abstr_repair (inv_of A l) (up_canonical_upd M n)"

definition
  "E_act_op l r g l' M \<equiv>
    FW' (abstr_upd (inv_of A l') (reset'_upd (FW' (abstr_upd g M) n) n r 0)) n"

definition
  "E_act_op' l r g l' M \<equiv>
    let
      M1 = filter_diag (\<lambda> M. abstr_repair g M) M;
      M2 = filter_diag (\<lambda> M. abstr_repair (inv_of A l') (reset'_upd M n r 0)) M1
    in M2"

definition
  "E_combined_op l r g l' M \<equiv>
    let
      M' = FW' (abstr_upd (inv_of A l) (up_canonical_upd M n)) n;
      M'' = FW' (abstr_upd (inv_of A l') (reset'_upd (FW' (abstr_upd g M') n) n r 0)) n
    in M''"

lemma E_combined_op_decomp:
  "E_combined_op l r g l' M \<equiv>
    let
      M' = E_del_op l M;
      M'' = E_act_op l r g l' M'
    in M''"
  unfolding E_combined_op_def E_del_op_def E_act_op_def .

definition
  "E_combined_op' l r g l' M \<equiv>
    let
      M1 = abstr_repair (inv_of A l) (up_canonical_upd M n);
      M2 = filter_diag (\<lambda> M. abstr_repair g M) M1;
      M3 = filter_diag (\<lambda> M. abstr_repair (inv_of A l') (reset'_upd M n r 0)) M2
    in M3"

lemma E_combined_op'_alt_def:
  "E_combined_op' l r g l' M \<equiv>
    let
      M' = abstr_repair (inv_of A l) (up_canonical_upd M n);
      f1 = \<lambda> M. abstr_repair g M;
      f2 = \<lambda> M. abstr_repair (inv_of A l') (reset'_upd M n r 0)
    in filter_diag (filter_diag f2 o f1) M'"
  unfolding E_combined_op'_def filter_diag_def
  by (rule HOL.eq_reflection) (auto simp: Let_def check_diag_marker)

lemma E_combined_op'_decomp:
  "E_combined_op' l r g l' M \<equiv>
    let
      M' = E_del_op' l M;
      M'' = E_act_op' l r g l' M'
    in M''"
  unfolding E_combined_op'_def E_del_op'_def E_act_op'_def unfolding Let_def .

no_notation step_impl' ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)

abbreviation step_impl_precise' ("\<langle>_, _\<rangle> \<leadsto>\<^bsub>_\<^esub> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  "\<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l'', Z''\<rangle> \<equiv> \<exists> l' Z'.
    A \<turnstile>\<^sub>I \<langle>l, Z\<rangle> \<leadsto>\<^bsub>n,\<tau>\<^esub> \<langle>l', Z'\<rangle> \<and> A \<turnstile>\<^sub>I \<langle>l', Z'\<rangle> \<leadsto>\<^bsub>n,\<upharpoonleft>a\<^esub> \<langle>l'', Z''\<rangle>"

(* sublocale Graph_Defs "\<lambda> (l, u) (l', u'). conv_A A \<turnstile>' \<langle>l, u\<rangle> \<rightarrow> \<langle>l', u'\<rangle>" . *)

definition "E_combined \<equiv> (\<lambda>(l, Z) (l'', Z''). \<exists>a. \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l'', Z''\<rangle>)"

definition "E_precise \<equiv> (\<lambda>(l, Z) a (l', Z'). A \<turnstile>\<^sub>I \<langle>l, Z\<rangle> \<leadsto>\<^bsub>n,a\<^esub> \<langle>l', Z'\<rangle>)"

end

lemma (in TA_Start) E_precise_equiv:
  "\<exists> b'. E_precise b action b' \<and> a' \<sim> b'"
  if "E_precise a action a'" "a \<sim> b" "wf_state a" "wf_state b"
  using that
  unfolding wf_state_def E_precise_def
  apply safe
  apply (frule step_impl_equiv, assumption, assumption, rule state_equiv_D, assumption)
  by (safe, drule step_impl_equiv, auto intro: step_impl_wf_dbm simp: state_equiv_def)

locale E_From_Op_Defs = TA_Start_Defs _ l\<^sub>0 for l\<^sub>0 :: "'s" +
  fixes del :: "'s \<Rightarrow> (nat \<times> nat \<Rightarrow> int DBMEntry) \<Rightarrow> nat \<times> nat \<Rightarrow> int DBMEntry"
  fixes act :: "'s
   \<Rightarrow> nat list
      \<Rightarrow> (nat, int) acconstraint list
         \<Rightarrow> 's
            \<Rightarrow> (nat \<times> nat \<Rightarrow> int DBMEntry)
               \<Rightarrow> nat \<times> nat \<Rightarrow> int DBMEntry"
begin

definition "E_from_op = (\<lambda> (l, M) a (l', M'). case a of
  \<tau> \<Rightarrow> l' = l \<and> M' = del l M
  | \<upharpoonleft>a \<Rightarrow> \<exists> g r. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> M' = act l r g l' M)"

end

locale E_From_Op = TA_Start + E_From_Op_Defs

locale E_Precise_Bisim = E_From_Op +
  assumes del_bisim:
    "wf_dbm M \<Longrightarrow> del l M \<simeq> E_del_op l M"
    and act_bisim:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> wf_dbm M \<Longrightarrow> act l r g l' M \<simeq> E_act_op l r g l' M"
    and del_wf:
    "wf_dbm M \<Longrightarrow> wf_dbm (del l M)"
    and act_wf:
    "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<Longrightarrow> wf_dbm M \<Longrightarrow> wf_dbm (act l r g l' M)"
begin

lemma step_impl_E_del_op:
  "A \<turnstile>\<^sub>I \<langle>l, Z\<rangle> \<leadsto>\<^bsub>n,\<tau>\<^esub> \<langle>l', Z'\<rangle> \<longleftrightarrow> l' = l \<and> Z' = E_del_op l Z"
  unfolding E_del_op_def by (auto elim!: step_impl.cases)

lemma step_impl_E_act_op:
  "A \<turnstile>\<^sub>I \<langle>l, Z\<rangle> \<leadsto>\<^bsub>n,\<upharpoonleft>a\<^esub> \<langle>l', Z'\<rangle> \<longleftrightarrow> (\<exists>g r. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> Z' = E_act_op l r g l' Z)"
  unfolding E_act_op_def by (auto elim!: step_impl.cases)

term "valid_dbm (curry (conv_M D))" term "dbm_int M n"
term E_From_Op_Defs.E_from_op
thm E_From_Op_Defs.E_from_op_def
\<^cancel>\<open>definition
  "E_precise_op = E_From_Op_Defs.E_from_op A E_del_op E_act_op"\<close>

lemma E_precise_alt_def:
  "E_precise = E_From_Op_Defs.E_from_op A E_del_op E_act_op"
  unfolding E_precise_def E_From_Op_Defs.E_from_op_def
  by (intro ext)
     (auto split: prod.splits action.split simp: simp: step_impl_E_del_op step_impl_E_act_op)

\<^cancel>\<open>lemma E_precise_E_op:
  "E_precise = (\<lambda>(l, M) a (l', M'''). \<exists>g a r. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> M''' = E_from_op l r g l' M)"
  unfolding E_precise_op_def E_precise_def by (intro ext) (auto elim!: step_impl.cases)
\<close>
\<^cancel>\<open>lemma E_precise_E_op:
  "E_precise = (\<lambda>(l, M) (l', M'''). \<exists>g a r. A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l' \<and> M''' = E_precise_op l r g l' M)"
  unfolding E_precise_op_def E_precise_def by (intro ext) (auto elim!: step_impl.cases)\<close>

lemma E_E_from_op_step:
  "\<exists>c. E_from_op a action c \<and> b \<sim> c" if "E_precise a action b" "wf_state a"
  using that unfolding E_precise_alt_def E_From_Op_Defs.E_from_op_def wf_state_def state_equiv_def
  by (cases action) (auto 4 4 intro!: del_bisim[THEN dbm_equiv_sym] act_bisim[THEN dbm_equiv_sym])

lemma E_from_op_E_step:
  "\<exists>c. E_precise a action c \<and> b \<sim> c" if "E_from_op a action b" "wf_state a"
  using that unfolding E_precise_alt_def E_From_Op_Defs.E_from_op_def wf_state_def state_equiv_def
  by (cases action) (auto 4 4 intro!: del_bisim act_bisim)

lemma E_from_op_wf_state:
  "wf_state b" if "wf_state a" "E_from_op a action b"
  using that unfolding E_E_op E_from_op_def wf_state_def state_equiv_def
  by (cases action) (auto 4 4 intro: del_wf act_wf)

lemma E_precise_wf_dbm[intro]:
  "wf_dbm D'" if "E_precise (l, D) action (l', D')" "wf_dbm D"
  using that unfolding wf_state_def E_def E_precise_def by (auto intro: step_impl_wf_dbm)

lemma E_precise_wf_state:
  "wf_state a \<Longrightarrow> E_precise a action b \<Longrightarrow> wf_state b"
  unfolding wf_state_def by auto

lemma E_from_op_bisim:
  "Bisimulation_Invariant E_precise E_from_op (\<sim>) wf_state wf_state"
  apply standard
  subgoal for action a b a'
    by (drule E_precise_equiv, assumption+) (auto dest!: E_E_from_op_step)
  subgoal
    by (drule (1) E_from_op_E_step, safe, drule E_precise_equiv) (auto 4 4 intro: state_equiv_sym)
   apply (rule E_precise_wf_state; assumption)
  apply (rule E_from_op_wf_state; assumption)
  done

(* lemma E_E_from_op_steps_empty:
  "(\<exists>l' M'. E_precise\<^sup>*\<^sup>* a\<^sub>0 (l', M') \<and> [curry (conv_M M')]\<^bsub>v,n\<^esub> = {}) \<longleftrightarrow>
   (\<exists>l' M'. E_from_op\<^sup>*\<^sup>* a\<^sub>0 (l', M') \<and> [curry (conv_M M')]\<^bsub>v,n\<^esub> = {})"
  by (rule E_E\<^sub>1_steps_empty[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]) *)

\<^cancel>\<open>theorem E_from_op_reachability_check:
  "(\<exists> l' D'. E_precise\<^sup>*\<^sup>* a\<^sub>0 (l', D') \<and> F_rel (l', D'))
  \<longleftrightarrow> (\<exists> l' D'. E_from_op\<^sup>*\<^sup>* a\<^sub>0 (l', D') \<and> F_rel (l', D'))"
  oops\<close>
(*   apply (rule E_E\<^sub>1_steps_equiv[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state])
  by
    (auto
      simp: F_rel_def state_equiv_def wf_state_def dbm_equiv_def
      dest!:
        check_diag_empty_spec[OF check_diag_conv_M]
        canonical_check_diag_empty_iff[OF wf_dbm_altD(1)]
    ) *)

\<^cancel>\<open>lemma E_from_op_mono:
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "[curry (conv_M D)]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M)]\<^bsub>v,n\<^esub>"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M')]\<^bsub>v,n\<^esub>"
  (* using assms by - (rule E\<^sub>1_mono[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]; blast) *)
  oops

lemma E_from_op_mono':
  assumes "E_from_op (l,D) (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op (l,M) (l',M') \<and> dbm_subset n D' M'"
  (* using assms by - (rule E\<^sub>1_mono'[OF E_E_from_op_step E_from_op_E_step E_from_op_wf_state]; blast) *)
  oops

  thm E_E_from_op_step E_from_op_E_step E_from_op_wf_state

lemma E_equiv:
  "\<exists> b'. E_precise b b' \<and> a' \<sim> b'" if "E_precise a a'" "a \<sim> b" "wf_state a" "wf_state b"
  using that
  unfolding wf_state_def E_precise_def
  apply safe
  apply (frule step_impl_equiv, assumption, assumption, rule state_equiv_D, assumption)
  by (safe, drule step_impl_equiv, auto intro: step_impl_wf_dbm simp: state_equiv_def)

lemma E_from_op_bisim:
  "Bisimulation_Invariant E_precise E_from_op (\<sim>) wf_state wf_state"
  apply standard
  subgoal
    by (drule E_equiv, assumption+) (auto dest!: E_E_from_op_step)
  subgoal
    by (drule (1) E_from_op_E_step, safe, drule E_equiv) (auto 4 4 intro: state_equiv_sym)
   apply (rule E_precise_wf_state; assumption)
  apply (rule E_from_op_wf_state; assumption)
  done\<close>

lemma E_from_op_bisim_empty:
  "Bisimulation_Invariant
    (\<lambda>(l, M) action (l', M'). E_precise (l, M) action (l', M') \<and> \<not> check_diag n M')
    (\<lambda>(l, M) action (l', M'). E_from_op (l, M) action (l', M') \<and> \<not> check_diag n M')
    (\<sim>) wf_state wf_state"
  using E_from_op_bisim
  apply (rule Bisimulation_Invariant_filter[
        where FA = "\<lambda>(l, M). \<not> check_diag n M" and FB = "\<lambda>(l, M). \<not> check_diag n M"
        ])
  subgoal
    unfolding wf_state_def state_equiv_def
    apply clarsimp
    apply (subst canonical_check_diag_empty_iff[symmetric], erule wf_dbm_altD(1))
    apply (subst canonical_check_diag_empty_iff[symmetric], erule wf_dbm_altD(1))
    apply (simp add: dbm_equiv_def)
    done
   apply (auto; fail)+
  done

end (* End of context for bisimilarity *)

context TA_Start
begin

lemma
  assumes "A \<turnstile> l \<longrightarrow>\<^bsup>g,a,r\<^esup> l'" "wf_dbm M"
  shows E_act_op'_bisim: "E_act_op' l r g l' M \<simeq> E_act_op l r g l' M" (is ?bisim)
  and E_act_op'_wf: "wf_dbm (E_act_op' l r g l' M)" (is ?wf)
proof -
  note intros =
    dbm_equiv_refl dbm_equiv_trans[OF filter_diag_equiv, rotated]
    wf_dbm_abstr_repair_equiv_FW[rotated] reset'_upd_equiv
  have
    "\<forall>c\<in>constraint_clk ` set (inv_of A l'). 0 < c \<and> c \<le> n"
    "\<forall>c\<in>constraint_clk ` set (inv_of A l'). 0 < c"
    using clock_range collect_clks_inv_clk_set[of A l'] unfolding collect_clks_def by blast+
  moreover have "\<forall>c\<in>constraint_clk ` set g. 0 < c \<and> c \<le> n" "\<forall>c\<in>constraint_clk ` set g. 0 < c"
    using clock_range collect_clocks_clk_set[OF assms(1)] unfolding collect_clks_def by blast+
  moreover have "\<forall>i\<in>set r. 0 < i \<and> i \<le> n" "\<forall>i\<in>set r. 0 < i"
    using clock_range reset_clk_set[OF assms(1)] unfolding collect_clks_def by blast+
  moreover note side_conds = calculation assms(2)
  note wf_intros =
    wf_dbm_abstr_repair wf_dbm_reset'_upd filter_diag_wf_dbm wf_dbm_FW'_abstr_upd
  note check_diag_intros =
    reset'_upd_check_diag_preservation abstr_repair_check_diag_preservation
  show ?bisim unfolding E_act_op'_def E_act_op_def
    by simp (intro intros check_diag_intros side_conds wf_intros order.refl)
  show ?wf
    unfolding E_act_op'_def by simp (intro wf_intros side_conds order.refl)
qed

lemma
  assumes "wf_dbm M"
  shows E_del_op'_bisim: "E_del_op' l M \<simeq> E_del_op l M" (is ?bisim)
    and E_del_op'_wf: "wf_dbm (E_del_op' l M)" (is ?wf)
proof -
  note intros =
    dbm_equiv_refl wf_dbm_abstr_repair_equiv_FW[rotated]
  note wf_intros =
    wf_dbm_abstr_repair wf_dbm_up_canonical_upd filter_diag_wf_dbm
  note check_diag_intros =
    abstr_repair_check_diag_preservation
  have side_conds: "\<forall>c\<in>constraint_clk ` set (inv_of A l). 0 < c \<and> c \<le> n"
    using clock_range collect_clks_inv_clk_set[of A l] unfolding collect_clks_def by blast
  show ?bisim and ?wf unfolding E_del_op'_def E_del_op_def
    by (intro intros check_diag_intros side_conds wf_intros order.refl assms)+
qed

lemma step_z_step_z_dbm_equiv:
  "Bisimulation_Invariant
     (\<lambda> (l, D) a (l', D'). step_z (conv_A A) l D a l' D')
     (\<lambda> (l, D) a (l', D'). step_z_dbm (conv_A A) l D v n a l' D')
     (\<lambda>(l, Z) (l', M). l = l' \<and> [M]\<^bsub>v,n\<^esub> = Z)
     (\<lambda>(l, Z). True)
     (\<lambda>(l, y). True)"
  by (standard; fastforce elim: step_z_dbm_DBM intro: step_z_dbm_sound)

lemma step_z_dbm_step_impl_precise_equiv:
  "Bisimulation_Invariant
     (\<lambda> (l, D) a (l', D'). step_z_dbm (conv_A A) l D v n a l' D')
     E_precise
     (\<lambda>(l, M) (l', D). l = l' \<and> [curry (conv_M D)]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>)
     (\<lambda>(l, y). valid_dbm y)
     wf_state"
  unfolding E_precise_def
proof (standard, goal_cases)
  case prems: (1 a b a')
  then show ?case
    using step_impl_complete''_improved by (auto dest: step_z_dbm_equiv' simp: wf_state_def)
next
  case prems: (2 a a' b')
  then show ?case
    by clarsimp
       (drule step_impl_sound', auto 4 3 dest: step_z_dbm_equiv' simp add: wf_state_def wf_dbm_def)
next
  case (3 a b)
  then show ?case
    using step_z_norm_valid_dbm'_spec step_z_valid_dbm' by auto
next
  case (4 a b)
  then show ?case
    by (clarsimp simp: norm_step_wf_dbm step_impl_wf_dbm wf_state_def)
qed

sublocale E_precise_op': E_Precise_Bisim _ _ _ _ E_del_op' E_act_op'
  by standard
     (rule E_del_op'_bisim E_act_op'_bisim E_del_op'_wf E_act_op'_wf; assumption)+

lemma step_z_dbm_final_bisim:
  "Bisimulation_Invariant
     (\<lambda> (l, D) a (l', D'). step_z_dbm (conv_A A) l D v n a l' D')
     E_precise_op'.E_from_op
     (\<lambda> (l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>)
     (\<lambda>(l, y). valid_dbm y) wf_state"
  by (rule Bisimulation_Invariant_sim_replace,
      rule Bisimulation_Invariant_composition[
        OF step_z_dbm_step_impl_precise_equiv[folded E_precise_def] E_precise_op'.E_from_op_bisim
      ]) (auto simp add: state_equiv_def dbm_equiv_def)

end (* TA Start *)

context E_Precise_Bisim
begin

interpretation
  Bisimulation_Invariant
  "(\<lambda> (l, D) a (l', D'). conv_A A \<turnstile> \<langle>l, D\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D'\<rangle>)"
  E_from_op
  "\<lambda> (l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  "\<lambda>(l, y). valid_dbm y"
  wf_state
  by (rule Bisimulation_Invariant_sim_replace,
      rule Bisimulation_Invariant_composition[
        OF step_z_dbm_step_impl_precise_equiv[folded E_precise_def] E_from_op_bisim
      ]) (auto simp add: state_equiv_def dbm_equiv_def)

lemmas step_z_dbm'_E_from_op_bisim = Bisimulation_Invariant_axioms

definition
  "E_from_op_empty \<equiv> \<lambda>(l, D) a (l', D'). E_from_op (l, D) a (l', D') \<and> \<not> check_diag n D'"

interpretation bisim_empty:
  Bisimulation_Invariant
  "\<lambda>(l, M) a (l', M'). conv_A A \<turnstile> \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M'\<rangle> \<and> [M']\<^bsub>v,n\<^esub> \<noteq> {}"
  "\<lambda>(l, D) a (l', D'). E_from_op (l, D) a (l', D') \<and> \<not> check_diag n D'"
  "\<lambda>(l, M) (l', D'). l' = l \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> = [M]\<^bsub>v,n\<^esub>"
  "\<lambda>(l, y). valid_dbm y"
  wf_state
  using step_z_dbm'_E_from_op_bisim apply (rule Bisimulation_Invariant_filter[
        where FA = "\<lambda>(l', M'). [M']\<^bsub>v,n\<^esub> \<noteq> {}" and FB = "\<lambda>(l', D'). \<not> check_diag n D'"
        ])
  using canonical_check_diag_empty_iff canonical_empty_check_diag' by (auto simp: wf_state_def)

lemmas step_z_dbm_E_from_op_bisim_empty =
  bisim_empty.Bisimulation_Invariant_axioms[folded E_from_op_empty_def]

lemma E_from_op_mono:
  assumes "E_from_op (l,D) a (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "[curry (conv_M D)]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M)]\<^bsub>v,n\<^esub>"
  shows "\<exists> M'. E_from_op (l,M) a (l',M') \<and> [curry (conv_M D')]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M')]\<^bsub>v,n\<^esub>"
proof -
  from B_A_step[OF assms(1), of "(l, curry (conv_M D))"] assms(2) obtain D1 where D1:
    "conv_A A \<turnstile> \<langle>l, curry (conv_M D)\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', D1\<rangle>" "[D1]\<^bsub>v,n\<^esub> = [curry (conv_M D')]\<^bsub>v,n\<^esub>"
    unfolding wf_state_def by (auto dest!: wf_dbm_D)
  from step_z_dbm_mono[OF this(1) assms(4)] obtain M1 where M1:
    "conv_A A \<turnstile> \<langle>l, curry (conv_M M)\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M1\<rangle>"
    "[D1]\<^bsub>v,n\<^esub> \<subseteq> [M1]\<^bsub>v,n\<^esub>"
    by atomize_elim
  with A_B_step[of "(l, curry (conv_M M))" a "(l', M1)" "(l, M)"] assms(3) obtain M2 where
    "E_from_op (l, M) a (l', M2)" "[curry (conv_M M2)]\<^bsub>v,n\<^esub> = [M1]\<^bsub>v,n\<^esub>"
    unfolding wf_state_def by (force dest: wf_dbm_D)
  with assms(3) M1(2) D1(2) show ?thesis
    by auto
qed

(* XXX Duplication (E_mono') *)
lemma E_from_op_mono':
  assumes "E_from_op (l,D) a (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op (l,M) a (l',M') \<and> dbm_subset n D' M'"
  using assms
  apply -
  apply (frule E_from_op_mono[where M = M], assumption+)
   apply (subst dbm_subset_correct'', assumption+)
   apply (rule dbm_subset_conv, assumption)
  apply safe
  apply (subst (asm) dbm_subset_correct'')
  subgoal
    using B_invariant[unfolded wf_state_def] by auto
  subgoal
    using B_invariant[unfolded wf_state_def] by auto
  apply (blast intro: dbm_subset_conv_rev)
  done

lemma E_from_op_empty_mono':
  assumes "E_from_op_empty (l,D) a (l',D')"
    and   "wf_dbm D" "wf_dbm M"
    and "dbm_subset n D M"
  shows "\<exists> M'. E_from_op_empty (l,M) a (l',M') \<and> dbm_subset n D' M'"
  using assms unfolding E_from_op_empty_def using check_diag_subset E_from_op_mono' by fast

interpretation B:
    Bisimulation
    "\<lambda> (l, Z) a (l', Z'). conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
    "\<lambda> (l, M) a (l', M'). conv_A A \<turnstile> \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M'\<rangle> \<and> [M']\<^bsub>v,n\<^esub> \<noteq> {}"
    "\<lambda> (l, Z) (l', M). l' = l \<and> Z = [M]\<^bsub>v,n\<^esub>"
    by (standard; force elim!: step_z_dbm_DBM step_z_dbm_sound)

interpretation B1:
    Bisimulation_Invariant
    "\<lambda> (l, Z) a (l', Z'). conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
    "\<lambda> (l, M) a (l', M'). conv_A A \<turnstile> \<langle>l, M\<rangle> \<leadsto>\<^bsub>v,n,a\<^esub> \<langle>l', M'\<rangle> \<and> [M']\<^bsub>v,n\<^esub> \<noteq> {}"
    "\<lambda> (l, Z) (l', M). l' = l \<and> Z = [M]\<^bsub>v,n\<^esub>"
    "\<lambda>_. True"
    "\<lambda>(l, M). valid_dbm M"
  by standard (auto 4 3 elim: step_z_dbm_DBM step_z_dbm_sound dest: step_z_valid_dbm')

interpretation bisim_empty_zone:
  Bisimulation_Invariant
  "\<lambda>(l, Z) a (l', Z'). conv_A A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^bsub>a\<^esub> \<langle>l', Z'\<rangle> \<and> Z' \<noteq> {}"
  E_from_op_empty
  "\<lambda>(l, Z) (l', D). l' = l \<and> [curry (conv_M D)]\<^bsub>v,n\<^esub> = Z"
  "\<lambda>_. True"
  wf_state
  apply (rule Bisimulation_Invariant_sim_replace)
   apply (rule Bisimulation_Invariant_composition[rotated])
    apply (rule step_z_dbm_E_from_op_bisim_empty)
   apply (rule B1.Bisimulation_Invariant_axioms)
  apply (auto simp: wf_state_def dest!: wf_dbm_D(3))
  done

lemmas step_z_E_from_op_bisim_empty =
  bisim_empty_zone.Bisimulation_Invariant_axioms[folded E_from_op_empty_def]

end (* E Precise Bisim *)

end