(* Author: Rafal Kolanski, 2008
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

section \<open>More properties of maps plus map disjuction.\<close>

theory Map_Extra
  imports Main
begin

text \<open>
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses \<open>m\<close> for map variable names.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses \<open>h\<close>
\<close>

section \<open>Things that could go into Option Type\<close>

text \<open>Misc option lemmas\<close>

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

section \<open>Things that go into Map.thy\<close>

text \<open>Map intersection: set of all keys for which the maps agree.\<close>

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text \<open>Map restriction via domain subtraction\<close>

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection \<open>Properties of maps not related to restriction\<close>

lemma empty_forall_equiv: "(m = Map.empty) = (\<forall>x. m x = None)"
  by (fastforce intro!: ext)

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m Map.empty) = (m = Map.empty)"
  by (auto simp: map_le_def intro: ext)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = Map.empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> Map.empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = Map.empty" by blast
next
  assume a: "m = Map.empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (auto intro!: ext simp: map_le_def elim!: ballE)

subsection \<open>Properties of map restriction\<close>

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce intro: ext dest: fun_cong
               simp: restrict_map_def None_not_eq
               split: if_split_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto intro: ext simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (auto intro!: ext simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com intro: ext)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def intro: ext)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com intro: ext)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = Map.empty"
  by (fastforce simp: restrict_map_def intro: ext)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits intro: ext)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (auto simp: map_add_def restrict_map_def split: option.splits intro!: ext)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce intro: ext simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (auto simp: None_com map_add_def restrict_map_def map_le_def
           split: option.splits
           intro!: ext)
     (force simp: Some_com)+

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (auto simp: restrict_map_def map_add_def intro!: ext split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto intro!: ext simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def intro!: ext split: option.splits)

section \<open>Things that should not go into Map.thy (separation logic)\<close>

subsection \<open>Definitions\<close>

text \<open>Map disjuction\<close>

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

subsection \<open>Properties of @{term "sub_restrict_map"}\<close>

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits if_split
               intro: ext)

subsection \<open>Properties of map disjunction\<close>

lemma map_disj_empty_right [simp]:
  "h \<bottom> Map.empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "Map.empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection \<open>Map associativity-commutativity based on map disjuction\<close>

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com map_add_assoc)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text \<open>
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, \<open>map_add_assoc\<close> will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via \<open>map_add_ac\<close>)
\<close>

declare map_add_assoc [simp del]

text \<open>
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
\<close>

lemmas map_add_ac =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection \<open>Basic properties\<close>

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

lemma map_disj_eq_dom_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; dom h\<^sub>0' = dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (auto simp: map_disj_def)

subsection \<open>Map disjunction and addition\<close>

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (auto elim!: map_disjD simp: map_add_comm map_add_eval_left map_disj_com)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (clarsimp simp: map_disj_def map_add_def split: option.splits)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_add_ac)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_add_ac)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by (auto intro!: ext)
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_add_ac)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_add_ac)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by (auto intro!: ext)
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by - (cases "x \<in> dom h\<^sub>0",
          simp_all add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by (auto intro!: ext)
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection \<open>Map disjunction and map updates\<close>

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp add: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto intro: ext simp: map_add_def cong: option.case_cong)

subsection \<open>Map disjunction and @{term "map_le"}\<close>

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_add_ac)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  by (rule iffI,
      clarsimp intro!: exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"])
     (fastforce intro: ext intro: split: option.splits if_split_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=Map.empty])

subsection \<open>Map disjunction and restriction\<close>

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = Map.empty"
  by (fastforce simp: map_disj_def restrict_map_def intro: ext)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma map_add_restrict_dom_left':
  "h \<bottom> h' \<Longrightarrow> S = dom h \<Longrightarrow> (h ++ h') |` S = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def map_add_def)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_add_ac)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce intro!: ext split: option.splits
               simp: map_le_restrict restrict_map_def map_le_def map_add_def
                     dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_add_ac intro!: restrict_map_disj_both restrict_map_disj)

end


(*  Title:      Prime.thy
    Author:     Klaus Weidinger, TU Muenchen
    Copyright   2020

A simproc for the predicate "prime (n::int)" from "Factorial_Ring.thy".
*)

theory Prime
  imports
    Main
    Complex_Main
    "HOL-Computational_Algebra.Primes"
    HOL.Num
    "Pratt_Certificate.Pratt_Certificate"
begin

text\<open>
Case distinction:
  case "n < 2": lemma 'prime_false_lt2'
  case "n >= 2 & prime n": solved with 'Pratt_Certificate.thy'
                           and 'pratt.ML' from the AFP
  case "n >= 2 & ~prime n": lemma 'prime_false'
\<close>

lemma prime_false:
  fixes p::nat
  assumes "p * k = a * b" "\<not> p dvd a" "\<not> p dvd b"
  shows "\<not> prime p"
proof -
  have "p dvd a * b" using assms and dvd_def by metis
  hence "\<not> prime_elem p \<or> \<not> normalize p = p" using assms and prime_elem_def by blast
  thus "\<not> prime p" using prime_def by blast
qed

lemma prime_false_lt2:
  fixes p::nat
  assumes "p = 0 \<or> p = 1"
  shows "\<not> prime p"
  using assms by auto

ML_file\<open>algorithms.ML\<close>
ML_file\<open>tools.ML\<close>

ML\<open>
signature PRIME =
sig

(* defines the upper (and lower) bound for the simproc *)
val limit: int Config.T

val parse: Thm.cterm -> int

(*                        p                     p  =  a  *  b                    p    *)
datatype cert = PRIME of int | DIVISOR_PAIR of int * int * int | LESS_THAN_2 of int
val mk_cert: int -> cert
val generate_proof: Proof.context -> cert -> thm option

val prove: Proof.context -> int -> thm option
val simproc: Proof.context -> Thm.cterm -> thm option

(* helper tools *)
val get_cert_number : cert -> int

end

structure Prime : PRIME =
struct

val limit = Attrib.setup_config_int \<^binding>\<open>limit\<close> (K 1000000);
exception LIMIT

(*                        p                     p  =  a  *  b                    p    *)
datatype cert = PRIME of int | DIVISOR_PAIR of int * int * int | LESS_THAN_2 of int

fun parse ct = Tools.parse1 ct @{const_name "prime"}

fun mk_cert n =
    if n < 2 then LESS_THAN_2 n else
    let
        val sf = Algorithms.smallest_factor n
    in
        if sf = n then PRIME n
                  else DIVISOR_PAIR (n, sf, n div sf)
    end

fun generate_proof ctxt (PRIME n) =
        fst (Pratt.prove_prime [] n ctxt)
  | generate_proof ctxt (DIVISOR_PAIR (p, d1, d2)) =
        @{thm prime_false}
            |> Drule.infer_instantiate' ctxt
                      (map (Tools.nat2ct' ctxt) [p, d1*d2 div p, d1, d2])
            |> Tools.simp ctxt 3
            |> SOME
  | generate_proof ctxt (LESS_THAN_2 n) =
        @{thm prime_false_lt2}
            |> Drule.infer_instantiate' ctxt
                      (map (Tools.nat2ct' ctxt) [n])
            |> Tools.simp ctxt 1
            |> SOME

fun prove ctxt n =
    n     |> mk_cert                (* cert            *)
          |> generate_proof ctxt    (* thm option      *)

fun simproc ctxt input =            (* term            *)
    input |> parse                  (* n               *)
          |> (fn n => if abs n < Config.get ctxt limit then n else raise LIMIT)
          |> prove ctxt             (* thm option      *)
          |> Tools.wrap             (* thm option      *)
    handle LIMIT => NONE
         | TERM _ => NONE

(* helper tools *)
fun get_cert_number (PRIME p) = p
  | get_cert_number (DIVISOR_PAIR (p, _, _)) = p
  | get_cert_number (LESS_THAN_2 p) = p

end
\<close>

simproc_setup prime_simproc ("prime (numeral n::nat)") = \<open>K Prime.simproc\<close>

end


theory MainHCPairs
imports Main
begin

types 'a partial = "bool * 'a"

constdefs

defOp :: "'a partial => bool"
"defOp p == fst p"

makeTotal :: "'a partial => 'a"
"makeTotal == snd"

makePartial :: "'a => 'a partial"
"makePartial a == (True, a)"

(* undefined is predefined *)
undefinedOp :: "'a partial"
"undefinedOp == (False, arbitrary)"

(* backward compatibility only *)
noneOp :: "'a partial"
"noneOp == undefinedOp"

restrictOp :: "'a partial => bool => 'a partial"
"restrictOp a b == if b then a else undefinedOp"

(* utilities *)
flip :: "('a => 'b => 'c) => 'b => 'a => 'c"
"flip f a b == f b a"

uncurryOp :: "('a => 'b => 'c) => 'a * 'b => 'c"
"uncurryOp f p == f (fst p) (snd p)"

curryOp :: "('a * 'b => 'c) => 'a => 'b => 'c"
"curryOp f a b == f (a, b)"

(* map on pairs *)
mapFst :: "('a => 'b) => 'a * 'c => 'b * 'c"
"mapFst f p == (f (fst p), snd p)"

mapSnd :: "('b => 'c) => 'a * 'b => 'a * 'c"
"mapSnd f p == (fst p, f (snd p))"

(* predefined HasCASL functions *)
ifImplOp :: "bool * bool => bool"
"ifImplOp p == snd p --> fst p"

existEqualOp :: "'a partial => 'a partial => bool" ("(_ =e=/ _)" [50, 51] 50)
"existEqualOp a b == defOp a & defOp b & makeTotal a = makeTotal b"

exEqualOp :: "'a partial * 'a partial => bool"
"exEqualOp == uncurryOp existEqualOp"

strongEqualOp :: "'a partial => 'a partial => bool" ("(_ =s=/ _)" [50, 51] 50)
"strongEqualOp a b == a = b"

whenElseOp :: "('a partial * bool) * 'a partial => 'a partial"
"whenElseOp t == case t of
    (p, e) => if snd p then fst p else e"

resOp :: "'a partial * 'b partial => 'a"
"resOp p == makeTotal (restrictOp (fst p) (defOp (snd p)))"

(* conversions *)
lift2partial :: "('a => 'b partial) => 'a partial => 'b partial"
"lift2partial f s == restrictOp (f (makeTotal s)) (defOp s)"

mapPartial :: "('a => 'b) => 'a partial => 'b partial"
"mapPartial f s == restrictOp (makePartial (f (makeTotal s))) (defOp s)"

unpackPartial :: "(('a => 'b partial) => 'c => 'd partial)
            => ('a => 'b partial) partial => 'c => 'd partial"
"unpackPartial c s a == lift2partial (flip c a) s"

unpackBool :: "(('a => bool) => 'c => bool)
            => ('a => bool) partial => 'c => bool"
"unpackBool c s a == defOp s & c (makeTotal s) a"

unpack2partial :: "(('a => 'b) => 'c => 'd)
            => ('a => 'b) partial => 'c => 'd partial"
"unpack2partial c s a == mapPartial (flip c a) s"

unpack2bool :: "(('a => unit) => 'c => unit)
            => ('a => unit) partial => 'c => bool"
"unpack2bool c s a == defOp s"

bool2partial :: "bool => unit partial"
"bool2partial b == restrictOp (makePartial ()) b"

liftUnit2unit :: "('a => 'b) => bool => bool"
"liftUnit2unit f b == b"

liftUnit2bool :: "(unit => bool) => bool => bool"
"liftUnit2bool f b == b & f ()"

liftUnit2partial :: "(unit => 'a partial) => bool => 'a partial"
"liftUnit2partial f b == restrictOp (f ()) b"

liftUnit :: "(unit => 'a) => bool => 'a partial"
"liftUnit f b == restrictOp (makePartial (f ())) b"

lift2unit :: "('b => 'c) => ('a partial => bool)"
"lift2unit f == defOp"

lift2bool :: "('a => bool) => 'a partial => bool"
"lift2bool f s == defOp s & f (makeTotal s)"

-- "SUBTYPE ENCODING"

consts

subt :: "'a => 'b => bool"
gn_inj :: "'a => 'b"
gn_proj :: "'a => 'b partial"

axioms

-- "general injection projection property"
gn_inj_proj_def [rule_format] :
"subt (x\<Colon>'a) (y\<Colon>'b)  ==>
  makeTotal(gn_proj(gn_inj(x)\<Colon>'b)) = x"

-- "SUBTYPE RULES"

-- "necessary when omitting the quantifiers in the axioms below"
subtype_constant [rule_format] :
"subt (x:: 'a) (y:: 'b) ==> (!!(u:: 'a) v:: 'b. subt u v)"

subtype_reflexive [rule_format] :
"subt (x:: 'a) (y:: 'a)"

subtype_transitive [rule_format] :
"[| subt (x:: 'a) (y:: 'b); subt (z:: 'b) (t:: 'c) |]  ==> subt (u:: 'a) (v:: 'c)"

-- "is used for derivation of subtypes:"
subtype_subsumption [rule_format] :
"[| subt (x:: 'a) (y:: 'c); subt (z:: 'b) (t:: 'c);
  (!!(z':: 'c). defOp(gn_proj(z'):: 'a partial) ==> defOp(gn_proj(z'):: 'b partial)) |]
  ==> (subt (u:: 'a) (v:: 'b))"

-- "INJECTION PROJECTION RULES"

-- "is used to derive defining predicate P for a subtype A, P(gn_inj(x::A))"
gn_proj_def [rule_format] :
"subt (x:: 'a) (y:: 'b) ==> defOp(gn_proj(gn_inj(x):: 'b):: 'a partial)"

gn_proj_inj [rule_format] :
"subt (x:: 'a) (y:: 'b) ==> (!!(z:: 'a). makeTotal(gn_proj(gn_inj(z):: 'b)) = z)"

gn_inj_proj [rule_format] :
"subt (x:: 'a) (y:: 'b) ==> (!!(z:: 'b). defOp(gn_proj(z):: 'a partial) ==>
  gn_inj(makeTotal(gn_proj(z):: 'a partial)) = z)"

<<<<<<< .mine
subt_inj_diagram [rule_format] :
"!!(x::'a) (y::'b) (z::'c). (subt y z) & (subt x y)
  ==> (!!(x'::'a). (gn_inj(x')\<Colon>'c) = gn_inj(gn_inj(x')\<Colon>'b))"
=======
gn_inj_diagram [rule_format] :
"[| subt (x:: 'a) (y:: 'b); subt (t:: 'b) (z:: 'c) |]
  ==> (!!(x':: 'a). (gn_inj(x'):: 'c) = gn_inj(gn_inj(x'):: 'b))"
>>>>>>> .r1306

<<<<<<< .mine
lemma gn_inj_proj_def_alt [rule_format] :
"defOp(gn_proj(gn_inj(x\<Colon>'a)\<Colon>'b)\<Colon>'a partial) ==>
  makeTotal(gn_proj(gn_inj(x)\<Colon>'b)) = x"

lemma gn_proj_fact:
"!!(x::'a) (y::'b). (subt x y) ==> (defOp(gn_proj(y)\<Colon>'a partial)
  ==> gn_inj(makeTotal(gn_proj(y)\<Colon>'a partial)) = y)"
  proof-
    fix x::'a
    fix y::'b
    assume hyp1: "subt x y" and hyp2: "defOp(gn_proj y\<Colon>'a partial)"
    have "\<exists>z::'a. y = gn_inj(z)" (is "\<exists>z. ?P z")
      by (rule gn_proj_def [of x y], (simp only: hyp1 hyp2)+)
    then obtain z where y_def: "?P z" ..
    from hyp2 have fact: "defOp(gn_proj(gn_inj(z)\<Colon>'b)\<Colon>'a partial)" by (simp only: y_def)
    show "gn_inj(makeTotal(gn_proj(y)\<Colon>'a partial)) = y"
      by ((subst y_def)+, subst gn_inj_proj_def, simp_all only: fact)
=======
--   "subt (u:: 'a) (v:: 'b) ==> inj (gn_inj:: 'a => 'b)"

lemma gn_inj_injective :
  "subt (u :: 'a) (v:: 'b) ==> inj (gn_inj:: 'a => 'b)"
  proof (rule injI)
    fix x:: 'a
    fix y:: 'a
    assume hyp1: "subt (u:: 'a) (v:: 'b)"
      and hyp2: "(gn_inj x:: 'b) = gn_inj y"

    from hyp1 subtype_constant
    have fact: "!!(z:: 'a). makeTotal(gn_proj(gn_inj(z):: 'b)) = z"
      by (rule_tac gn_proj_inj, blast)

    hence "x = makeTotal(gn_proj(gn_inj(x):: 'b))" ..
    also from hyp2 have "... = makeTotal(gn_proj(gn_inj(y):: 'b))" by simp
    also from fact have "... = y" by simp
    finally show "x = y" by simp
>>>>>>> .r1306
  qed

lemma gn_inj_identity :
"!!x:: 'a. (gn_inj(x):: 'a) = x"
proof-
  fix x:: 'a
  have fact: "(gn_inj(x):: 'a) = gn_inj(gn_inj(x):: 'a)"
    by (simp_all add: gn_inj_diagram subtype_reflexive)
  thus "(gn_inj(x):: 'a) = x"
    by (subst injD [of "(gn_inj:: 'a=>'a)" "(gn_inj(x):: 'a)" x],
      simp_all only: gn_inj_injective subtype_reflexive fact [symmetric])
qed

end


theory DivergenceReflection
  imports SourceTargetRelation
begin

section \<open>Divergence Reflection\<close>

text \<open>Divergence reflection forbids for encodings that introduce loops of internal actions. Thus
        they determine the practicability of encodings in particular with respect to
        implementations. An encoding reflects divergence if each loop in a target term result from
        the translation of a divergent source term.\<close>

abbreviation (in encoding) enc_preserves_divergence :: "bool" where
  "enc_preserves_divergence \<equiv> enc_preserves_pred (\<lambda>P. P \<longmapsto>ST\<omega>)"

lemma (in encoding) divergence_preservation_cond:
  shows "enc_preserves_divergence = (\<forall>S. S \<longmapsto>(Source)\<omega> \<longrightarrow> \<lbrakk>S\<rbrakk> \<longmapsto>(Target)\<omega>)"
    by simp

abbreviation (in encoding) enc_reflects_divergence :: "bool" where
  "enc_reflects_divergence \<equiv> enc_reflects_pred (\<lambda>P. P \<longmapsto>ST\<omega>)"

lemma (in encoding) divergence_reflection_cond:
  shows "enc_reflects_divergence = (\<forall>S. \<lbrakk>S\<rbrakk> \<longmapsto>(Target)\<omega> \<longrightarrow> S \<longmapsto>(Source)\<omega>)"
    by simp

abbreviation rel_preserves_divergence
    :: "('proc \<times> 'proc) set \<Rightarrow> 'proc processCalculus \<Rightarrow> bool"
  where
  "rel_preserves_divergence Rel Cal \<equiv> rel_preserves_pred Rel (\<lambda>P. P \<longmapsto>(Cal)\<omega>)"

abbreviation rel_reflects_divergence
    :: "('proc \<times> 'proc) set \<Rightarrow> 'proc processCalculus \<Rightarrow> bool"
  where
  "rel_reflects_divergence Rel Cal \<equiv> rel_reflects_pred Rel (\<lambda>P. P \<longmapsto>(Cal)\<omega>)"

text \<open>Apart from divergence reflection we consider divergence respection. An encoding respects
        divergence if each divergent source term is translated into a divergent target term and
        each divergent target term result from the translation of a divergent source term.\<close>

abbreviation (in encoding) enc_respects_divergence :: "bool" where
  "enc_respects_divergence \<equiv> enc_respects_pred (\<lambda>P. P \<longmapsto>ST\<omega>)"

lemma (in encoding) divergence_respection_cond:
  shows "enc_respects_divergence = (\<forall>S. \<lbrakk>S\<rbrakk> \<longmapsto>(Target)\<omega> \<longleftrightarrow> S \<longmapsto>(Source)\<omega>)"
    by auto

abbreviation rel_respects_divergence
    :: "('proc \<times> 'proc) set \<Rightarrow> 'proc processCalculus \<Rightarrow> bool"
  where
  "rel_respects_divergence Rel Cal \<equiv> rel_respects_pred Rel (\<lambda>P. P \<longmapsto>(Cal)\<omega>)"

text \<open>An encoding preserves divergence iff
        (1) there exists a relation that relates source terms and their literal translations and
            preserves divergence, or
        (2) there exists a relation that relates literal translations and their source terms and
            reflects divergence.\<close>

lemma (in encoding) divergence_preservation_iff_source_target_rel_preserves_divergence:
  shows "enc_preserves_divergence
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_preserves_divergence Rel (STCal Source Target))"
      using enc_preserves_pred_iff_source_target_rel_preserves_pred(1)[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp

lemma (in encoding) divergence_preservation_iff_source_target_rel_reflects_divergence:
  shows "enc_preserves_divergence
         = (\<exists>Rel. (\<forall>S. (TargetTerm (\<lbrakk>S\<rbrakk>), SourceTerm S) \<in> Rel)
            \<and> rel_reflects_divergence Rel (STCal Source Target))"
      using enc_preserves_pred_iff_source_target_rel_reflects_pred(1)[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp

text \<open>An encoding reflects divergence iff
        (1) there exists a relation that relates source terms and their literal translations and
            reflects divergence, or
        (2) there exists a relation that relates literal translations and their source terms and
            preserves divergence.\<close>

lemma (in encoding) divergence_reflection_iff_source_target_rel_reflects_divergence:
  shows "enc_reflects_divergence
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_reflects_divergence Rel (STCal Source Target))"
      using enc_reflects_pred_iff_source_target_rel_reflects_pred[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp

lemma (in encoding) divergence_reflection_iff_source_target_rel_preserves_divergence:
  shows "enc_reflects_divergence
         = (\<exists>Rel. (\<forall>S. (TargetTerm (\<lbrakk>S\<rbrakk>), SourceTerm S) \<in> Rel)
            \<and> rel_preserves_divergence Rel (STCal Source Target))"
      using enc_reflects_pred_iff_source_target_rel_preserves_pred[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp

text \<open>An encoding respects divergence iff there exists a relation that relates source terms and
        their literal translations in both directions and respects divergence.\<close>

lemma (in encoding) divergence_respection_iff_source_target_rel_respects_divergence:
  shows "enc_respects_divergence = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
         \<and> rel_respects_divergence Rel (STCal Source Target))"
  and   "enc_respects_divergence = (\<exists>Rel.
         (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel \<and> (TargetTerm (\<lbrakk>S\<rbrakk>), SourceTerm S) \<in> Rel)
         \<and> rel_respects_divergence Rel (STCal Source Target))"
proof -
  show "enc_respects_divergence = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
        \<and> rel_respects_divergence Rel (STCal Source Target))"
      using enc_respects_pred_iff_source_target_rel_respects_pred_encR[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp
next
  show "enc_respects_divergence = (\<exists>Rel.
        (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel \<and> (TargetTerm (\<lbrakk>S\<rbrakk>), SourceTerm S) \<in> Rel)
        \<and> rel_respects_divergence Rel (STCal Source Target))"
      using enc_respects_pred_iff_source_target_rel_respects_pred_encRL[where Pred="\<lambda>P. P \<longmapsto>ST\<omega>"]
            divergentST_STCal_divergent
    by simp
qed

end


(*  Title:      HOL/Nitpick_Examples/Record_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to records.
*)

section {* Examples Featuring Nitpick Applied to Records *}

theory Record_Nits
imports Main
begin

nitpick_params [verbose, card = 1-6, max_potential = 0,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

record point2d =
  xc :: int
  yc :: int

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x, yc := y\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> = p"
nitpick [expect = genuine]
oops

record point3d = point2d +
  zc :: int

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x, yc := y, zc := z\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>zc := z\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> = p"
nitpick [expect = genuine]
oops

record point4d = point3d +
  wc :: int

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>zc := z\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>wc := w\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> = p"
nitpick [expect = genuine]
oops

end


(*  Title:      Presburger-Automata/DFS.thy
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Author:     Stefan Berghofer and Alex Krauss, TU Muenchen, 2008-2009
*)

section \<open>Depth First Search\<close>

theory DFS
imports Main
begin

definition "succsr succs = {(x, y). y \<in> set (succs x)}"

partial_function (tailrec) gen_dfs
where
  "gen_dfs succs ins memb S wl =
    (case wl of
      [] \<Rightarrow> S
    | x # xs \<Rightarrow>
        if memb x S then gen_dfs succs ins memb S xs
        else gen_dfs succs ins memb (ins x S) (succs x @ xs))"

lemma gen_dfs_simps[simp]:
  "gen_dfs succs ins memb S [] = S"
  "gen_dfs succs ins memb S (x # xs) =
    (if memb x S then gen_dfs succs ins memb S xs
     else gen_dfs succs ins memb (ins x S) (succs x @ xs))"
  by (simp_all add: gen_dfs.simps)

locale DFS =
  fixes succs :: "'a \<Rightarrow> 'a list"
    and is_node :: "'a \<Rightarrow> bool"
    and invariant :: "'b \<Rightarrow> bool"
    and ins :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
    and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
    and empt :: 'b
  assumes ins_eq: "\<And>x y S. is_node x \<Longrightarrow> is_node y \<Longrightarrow> invariant S \<Longrightarrow> \<not> memb y S \<Longrightarrow>
      memb x (ins y S) = ((x = y) \<or> memb x S)"
    and empt: "\<And>x. is_node x \<Longrightarrow> \<not> memb x empt"
    and succs_is_node: "\<And>x. is_node x \<Longrightarrow> list_all is_node (succs x)"
    and empt_invariant: "invariant empt"
    and ins_invariant: "\<And>x S. is_node x \<Longrightarrow> invariant S \<Longrightarrow> \<not> memb x S \<Longrightarrow> invariant (ins x S)"
    and graph_finite: "finite {x. is_node x}"
begin

definition rel where
  "rel = inv_image finite_psubset (\<lambda>S. {n. is_node n \<and> \<not> memb n S})"

abbreviation "dfs \<equiv> gen_dfs succs ins memb"

lemma dfs_induct [consumes 2, case_names base step]:
  assumes S: "invariant S"
    and xs: "list_all is_node xs"
    and I1: "\<And>S. invariant S \<Longrightarrow> P S []"
    and I2: "\<And>S x xs. invariant S \<Longrightarrow> is_node x \<Longrightarrow> list_all is_node xs \<Longrightarrow>
      (memb x S \<Longrightarrow> P S xs) \<Longrightarrow> (\<not> memb x S \<Longrightarrow> P (ins x S) (succs x @ xs)) \<Longrightarrow> P S (x # xs)"
  shows "P S xs" using I1 I2 S xs
  apply induction_schema
  apply atomize_elim
  apply (case_tac xs, simp+)
  apply atomize_elim
  apply (rule conjI)
  apply (rule ins_invariant, assumption+)
  apply (rule succs_is_node, assumption)
  apply (relation "rel <*lex*> measure length")
  apply (simp add: wf_lex_prod rel_def)
  apply simp
  apply simp
  apply (rule disjI1)
  apply (simp add: rel_def finite_psubset_def)
  apply (rule conjI)
  apply (auto simp add: ins_eq graph_finite cong: conj_cong)
  done

definition "succss xs = (\<Union>x\<in>xs. set (succs x))"

definition "set_of S = {x. is_node x \<and> memb x S}"

definition "reachable xs = {(x, y). y \<in> set (succs x)}\<^sup>* `` xs"

lemma visit_subset_dfs: "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow>
    is_node y \<Longrightarrow> memb y S \<Longrightarrow> memb y (dfs S xs)"
  by (induct S xs rule: dfs_induct) (simp_all add: ins_eq)

lemma next_subset_dfs: "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow>
    x \<in> set xs \<Longrightarrow> memb x (dfs S xs)"
proof (induct S xs rule: dfs_induct)
  case base
  then show ?case by simp
next
  case (step S y xs)
  then show ?case
    by (auto simp add: visit_subset_dfs ins_eq ins_invariant succs_is_node)
qed

lemma succss_closed_dfs':
  "invariant ys \<Longrightarrow> list_all is_node xs \<Longrightarrow>
    succss (set_of ys) \<subseteq> set xs \<union> set_of ys \<Longrightarrow>
    succss (set_of (dfs ys xs)) \<subseteq> set_of (dfs ys xs)"
  by (induct ys xs rule: dfs_induct)
    (auto simp add: ins_eq succss_def set_of_def cong: conj_cong)

lemma succss_closed_dfs: "list_all is_node xs \<Longrightarrow>
    succss (set_of (dfs empt xs)) \<subseteq> set_of (dfs empt xs)"
  apply (rule succss_closed_dfs')
  apply (rule empt_invariant)
  apply assumption
  apply (simp add: succss_def)
  apply (rule subsetI)
  apply (erule UN_E)
  apply (simp add: set_of_def empt cong: conj_cong)
  done

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "X \<subseteq> r\<^sup>* `` X" by auto
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    { fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X" using assms y
        by induct (auto simp add: Image_def)
    } then show ?thesis by auto
  qed
qed

lemma reachable_closed_dfs:
  assumes "list_all is_node xs"
  shows "reachable (set xs) \<subseteq> set_of (dfs empt xs)"
proof -
  from assms have "reachable (set xs) \<subseteq> reachable (set_of (dfs empt xs))"
    apply (unfold reachable_def)
    apply (rule Image_mono)
    apply (auto simp add: set_of_def next_subset_dfs empt_invariant list_all_iff)
    done
  also from succss_closed_dfs assms have "\<dots> = set_of (dfs empt xs)"
    apply (unfold reachable_def)
    apply (rule Image_closed_trancl)
    apply (auto simp add: succss_def set_of_def)
    done
  finally show ?thesis .
qed

lemma reachable_succs: "reachable (set (succs x)) \<subseteq> reachable {x}"
  by (auto simp add: reachable_def intro: converse_rtrancl_into_rtrancl)

lemma dfs_subset_reachable_visit_nodes:
  "invariant ys \<Longrightarrow> list_all is_node xs \<Longrightarrow>
     set_of (dfs ys xs) \<subseteq> reachable (set xs) \<union> set_of ys"
proof (induct ys xs rule: dfs_induct)
  case base
  then show ?case by (simp add: reachable_def)
next
  case (step S x xs)
  show ?case
  proof (cases "memb x S")
    case True
    with step show ?thesis
      by (auto simp add: reachable_def)
  next
    case False
    have "reachable (set (succs x)) \<subseteq> reachable {x}"
      by (rule reachable_succs)
    then have "reachable (set (succs x @ xs)) \<subseteq> reachable (set (x # xs))"
      by (auto simp add: reachable_def)
    then show ?thesis using step
      by (auto simp add: reachable_def ins_eq set_of_def cong: conj_cong)
  qed
qed

theorem dfs_eq_reachable:
  assumes y: "is_node y"
    and xs: "list_all is_node xs"
  shows "memb y (dfs empt xs) = (y \<in> reachable (set xs))"
proof
  assume "memb y (dfs empt xs)"
  with dfs_subset_reachable_visit_nodes [OF empt_invariant xs] y
  show "y \<in> reachable (set xs)"
    by (auto simp add: empt set_of_def)
next
  assume "y \<in> reachable (set xs)"
  with reachable_closed_dfs [OF xs] show "memb y (dfs empt xs)"
    by (auto simp add: set_of_def)
qed

theorem dfs_eq_rtrancl:
  assumes y: "is_node y"
    and x: "is_node x"
  shows "memb y (dfs empt [x]) = ((x,y) \<in> (succsr succs)\<^sup>*)"
proof -
  from x have x': "list_all is_node [x]" by simp
  show ?thesis
    by (simp only: dfs_eq_reachable [OF y x'] reachable_def succsr_def) (auto simp add: empt)
qed

theorem dfs_invariant [consumes 2, case_names base step]:
  assumes S: "invariant S"
    and xs: "list_all is_node xs"
    and H: "I S"
    and I: "\<And>S x. \<not> memb x S \<Longrightarrow> is_node x \<Longrightarrow> invariant S \<Longrightarrow> I S \<Longrightarrow> I (ins x S)"
  shows "I (dfs S xs)"
proof -
  from S xs H
  have "I (dfs S xs) \<and> invariant (dfs S xs)"
  proof (induct S xs rule: dfs_induct)
    case base
    then show ?case by simp
  next
    case (step S x xs)
    show ?case
    proof (cases "memb x S")
      case True
      then show ?thesis by (simp add: step)
    next
      case False
      then show ?thesis
        apply simp
        apply (rule step)
        apply assumption
        apply (rule I)
        apply assumption
        apply (rule step)+
        done
    qed
  qed
  then show ?thesis ..
qed

theorem dfs_invariant': "invariant S \<Longrightarrow> list_all is_node xs \<Longrightarrow> invariant (dfs S xs)"
  by (induct S xs rule: dfs_induct) auto

theorem succsr_is_node:
  assumes "(x, y) \<in> (succsr succs)\<^sup>*"
  shows "is_node x \<Longrightarrow> is_node y" using assms
proof induct
  case base
  then show ?case .
next
  case (step y z)
  then have "is_node y" by simp
  then have "list_all is_node (succs y)"
    by (rule succs_is_node)
  with step show ?case
    by (simp add: succsr_def list_all_iff)
qed

end

declare gen_dfs_simps [simp del]

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Auxiliary Mapping Facts\<close>

theory Mapping2
  imports Main Map2 "HOL-Library.Mapping"
begin

lemma lookup_delete:
  "Mapping.lookup (Mapping.delete k m) k = None"
  by (transfer; simp)

lemma lookup_tabulate:
  "Mapping.lookup (Mapping.tabulate xs f) x = (if x \<in> set xs then Some (f x) else None)"
  by (transfer; insert map_of_tabulate_simp)

lemma lookup_tabulate_Some:
  "x \<in> set xs \<Longrightarrow> the (Mapping.lookup (Mapping.tabulate xs f) x) = f x"
  by (simp add: lookup_tabulate)

lemma finite_keys_tabulate:
  "finite (Mapping.keys (Mapping.tabulate xs f))"
  by simp

lemma keys_empty_iff_map_empty:
  "Mapping.keys m = {} \<longleftrightarrow> m = Mapping.empty"
  by (transfer; simp)

lemma mapping_equal:
  "Mapping.keys m = Mapping.keys m' \<Longrightarrow> (\<And>x. x \<in> Mapping.keys m \<Longrightarrow> Mapping.lookup m x = Mapping.lookup m' x) \<Longrightarrow> m = m'"
  by (transfer; blast intro: map_equal)

fun mapping_generator :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> ('a, 'b) mapping set"
where
  "mapping_generator V [] = {Mapping.empty}"
| "mapping_generator V (k#ks) = {Mapping.update k v m | v m.  v \<in> set (V k) \<and> m \<in> mapping_generator V ks}"

fun mapping_generator_list :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> ('a, 'b) mapping list"
where
  "mapping_generator_list V [] = [Mapping.empty]"
| "mapping_generator_list V (k#ks) = concat (map (\<lambda>m. map (\<lambda>v. Mapping.update k v m) (V k)) (mapping_generator_list V ks))"

lemma mapping_generator_code [code]:
  "mapping_generator V K = set (mapping_generator_list V K)"
  by (induction K) auto

lemma mapping_generator_set_eq:
  "mapping_generator V K = {m. Mapping.keys m = set K \<and> (\<forall>k \<in> (set K). the (Mapping.lookup m k) \<in> set (V k))}"
proof (induction K)
  case (Cons k ks)
    let ?l = "{m(k \<mapsto> v) |v m. v \<in> set (V k) \<and>  m \<in> {m. dom m = set ks \<and> (\<forall>k\<in>set ks. the (m k) \<in> set (V k))}}"
    let ?r = "{m. dom m = set (k # ks) \<and> (\<forall>k\<in>set (k # ks). the (m k) \<in> set (V k))}"

    have "?l \<subseteq> ?r"
      by fastforce
    moreover
    {
      fix m
      assume "m \<in> ?r"
      hence "dom m = set (k#ks)"
        and "\<forall>k \<in> set (k#ks). the (m k) \<in> set (V k)"
        and "\<forall>k' \<in> set (k#ks). m k \<noteq> None"
        by auto
      moreover
      then obtain m' where "dom m' = set ks"
        and "\<forall>x \<in> set ks. m x = m' x"
        using map_reduce[of m k "set ks"] by auto
      ultimately
      have "the (m k) \<in> set (V k)"
        and "dom m' = set ks"
        and "\<forall>k \<in> (set ks). the (m' k) \<in> set (V k)"
        and "m = m'(k \<mapsto> the (m k))"
        apply (simp, blast, auto)
        apply (insert map_equal[of m "m'(k \<mapsto> the (m k))"])
        apply (unfold dom_map_update \<open>dom m = set (k#ks)\<close> \<open>dom m' = set ks\<close>)
        by fastforce
      moreover
      hence "m \<in> set (map (\<lambda>v. m'(k \<mapsto> v)) (V k))"
        by simp
      ultimately
      have "m \<in> ?l"
        using \<open>dom m = set (k#ks)\<close> by blast
    }
    ultimately
    have "{Mapping.update k v m |v m. v \<in> set (V k) \<and> m \<in> {m. Mapping.keys m = set ks \<and> (\<forall>k\<in>set ks. the (Mapping.lookup m k) \<in> set (V k))}}
      = {m. Mapping.keys m = set (k # ks) \<and> (\<forall>k\<in>set (k # ks). the (Mapping.lookup m k) \<in> set (V k))}"
      by (transfer; blast)
    thus ?case
      by (simp add: Cons)
qed (force simp add: keys_empty_iff_map_empty)

end


(*  Title:      JinjaThreads/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
    Copyright   2000 TUM, 2010 KIT

Kildall's algorithm.
*)

header {* \isaheader{Kildall's Algorithm}\label{sec:Kildall} *}

theory Kildall
imports SemilatAlg "../Basic/Auxiliary"
begin

locale Kildall_base =
  fixes s_\<alpha> :: "'w \<Rightarrow> nat set"
  and s_empty :: "'w"
  and s_is_empty :: "'w \<Rightarrow> bool"
  and s_choose :: "'w \<Rightarrow> nat"
  and s_remove :: "nat \<Rightarrow> 'w \<Rightarrow> 'w"
  and s_insert :: "nat \<Rightarrow> 'w \<Rightarrow> 'w"
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 'w \<Rightarrow> 's list * 'w"
where
  "propa f []      \<tau>s w = (\<tau>s,w)"
| "propa f (q'#qs) \<tau>s w = (let (q,\<tau>) = q';
                             u = \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!q;
                             w' = (if u = \<tau>s!q then w else s_insert q w)
                         in propa f qs (\<tau>s[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 'w \<Rightarrow> 's list \<times> 'w"
where
  "iter f step \<tau>s w =
  while (\<lambda>(\<tau>s,w). \<not> s_is_empty w)
        (\<lambda>(\<tau>s,w). let p = s_choose w in propa f (step p (\<tau>s!p)) \<tau>s (s_remove p w))
        (\<tau>s,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 'w"
where
  "unstables r step \<tau>s = foldr s_insert (filter (\<lambda>p. \<not>stable r step \<tau>s p) [0..<size \<tau>s]) s_empty"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
where "kildall r f step \<tau>s \<equiv> fst(iter f step \<tau>s (unstables r step \<tau>s))"

primrec t_\<alpha> :: "'s list \<times> 'w \<Rightarrow> 's list \<times> nat set"
where "t_\<alpha> (\<tau>s, w) = (\<tau>s, s_\<alpha> w)"

end

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
where
  "merges f []      \<tau>s = \<tau>s"
| "merges f (p'#ps) \<tau>s = (let (p,\<tau>) = p' in merges f ps (\<tau>s[p := \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!p]))"

locale Kildall =
  Kildall_base +
  assumes empty_spec [simp]: "s_\<alpha> s_empty = {}"
  and is_empty_spec [simp]: "s_is_empty A \<longleftrightarrow> s_\<alpha> A = {}"
  and choose_spec: "s_\<alpha> A \<noteq> {} \<Longrightarrow> s_choose A \<in> s_\<alpha> A"
  and remove_spec [simp]: "s_\<alpha> (s_remove n A) = s_\<alpha> A - {n}"
  and insert_spec [simp]: "s_\<alpha> (s_insert n A) = insert n (s_\<alpha> A)"
begin

lemma s_\<alpha>_foldr_s_insert:
  "s_\<alpha> (foldr s_insert xs A) = foldr insert xs (s_\<alpha> A)"
by(induct xs arbitrary: A) simp_all

lemma unstables_spec [simp]: "s_\<alpha> (unstables r step \<tau>s) = {p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p}"
proof -
  have "{p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p} = foldr insert (filter (\<lambda>p. \<not>stable r step \<tau>s p) [0..<size \<tau>s]) {}"
    unfolding foldr_insert_conv_set by auto
  thus ?thesis by(simp add: unstables_def s_\<alpha>_foldr_s_insert)
qed

end

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] \<Squnion>\<^bsub>f\<^esub> ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
(*<*)
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  hence IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" using ps' by iprover

  from ss ab
  have "ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  with l have "p < length (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a])" by simp
  ultimately
  have "?P (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed
(*>*)

(** merges **)

lemma length_merges [simp]:
  "\<And>ss. size(merges f ps ss) = size ss"
(*<*) by (induct ps, auto) (*>*)

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
         \<longrightarrow> merges f ps xs \<in> list n A"
(*<*)
apply (insert closedI)
apply (unfold closed_def)
apply (induct ps)
 apply simp
apply clarsimp
done
(*>*)

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
(*<*)
apply (induct ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
(*>*)

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x \<sqsubseteq>\<^bsub>r\<^esub> xs!p))"
(*<*)
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] xs")
     apply (force dest!: le_listD simp add: nth_list_update)
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done
(*>*)

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<longrightarrow> p < size xs \<longrightarrow>
   x \<sqsubseteq>\<^bsub>r\<^esub> ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] ys"
(*<*)
  apply(insert semilat)
  apply (unfold Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  apply (auto simp add: Listn.le_def lesub_def plussub_def)
  done
(*>*)

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts \<subseteq> A"  "set ss \<subseteq> A"
    "\<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p < size ts"  "ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
  shows "merges f ps ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
(*<*)
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts \<subseteq> A; \<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs \<subseteq> set ps  \<longrightarrow>
    (\<forall>ss. set ss \<subseteq> A \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<longrightarrow> merges f qs ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]
  from assms show ?thesis by blast
qed
(*>*)

context Kildall begin

subsection {* @{term propa} *}

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   t_\<alpha> (propa f qs ss w) =
   (merges f qs ss, {q. \<exists>t.(q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> s_\<alpha> w)"
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done

end

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss!q = ss!q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
(*<*)
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule Semilat.intro)
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done
(*>*)

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss [\<sqsubseteq>\<^sub>r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss [\<sqsubseteq>\<^sub>r] ts"
(*<*)
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done
(*>*)

lemma termination_lemma: assumes "Semilat A r f"
shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
      ss [\<sqsubset>\<^sub>r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> (w-{p}) \<subset> w"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
      defer
      apply (rule sym, assumption)
     defer apply simp
     apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss ! q \<noteq> ss ! q)")
     apply (blast intro!: psubsetI elim: equalityE)
     apply clarsimp
     apply (drule bspec, assumption)
     apply (drule bspec, assumption)
     apply clarsimp
    done
qed
(*>*)

context Kildall_base begin

definition s_finite_psubset  :: "('w * 'w) set"
where "s_finite_psubset == {(A,B). s_\<alpha> A < s_\<alpha> B & finite (s_\<alpha> B)}"

lemma s_finite_psubset_inv_image:
  "s_finite_psubset = inv_image finite_psubset s_\<alpha>"
by(auto simp add: s_finite_psubset_def finite_psubset_def)

lemma wf_s_finite_psubset [simp]: "wf s_finite_psubset"
unfolding s_finite_psubset_inv_image by simp

end

context Kildall begin

subsection {* @{term iter} *}

lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>s_\<alpha> w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> s_\<alpha> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   t_\<alpha> (iter f step ss0 w0) = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 [\<sqsubseteq>\<^sub>r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss' [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
  apply (unfold iter_def stables_def)
  apply(unfold is_empty_spec)
  apply (rule_tac P = "\<lambda>(ss,w).
   ss \<in> list n A \<and> (\<forall>p<n. p \<notin> s_\<alpha> w \<longrightarrow> stable r step ss p) \<and> ss0 [\<sqsubseteq>\<^sub>r] ss \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss [\<sqsubseteq>\<^sub>r] ts) \<and>
   (\<forall>p\<in> s_\<alpha> w. p < n)" and
   r = "{(ss',ss) . ss \<in> list n A \<and> ss' \<in> list n A \<and> ss [\<sqsubset>\<^sub>r] ss'} <*lex*> s_finite_psubset"
         in while_rule)

  -- "Invariant holds initially:"
  apply (simp add:stables_def)

  -- "Invariant is preserved:"
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w \<in> s_\<alpha> w")
   prefer 2 apply(erule choose_spec)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (s_choose w) (ss ! (s_choose w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(\<lambda>(ss, w).
              ss \<in> list n A \<and>
              (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and>
              ss0 [\<sqsubseteq>\<^bsub>r\<^esub>] ss \<and>
              (\<forall>ts\<in>list n A.
                  ss0 [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<and> (\<forall>p<n. stable r step ts p) \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts) \<and>
              (\<forall>p\<in>w. p < n))
           (t_\<alpha> (propa f (step (s_choose w) (ss ! s_choose w)) ss
             (s_remove (s_choose w) w)))")
   apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss (s_remove (s_choose w) w)")
   apply(simp)
  apply (subst decomp_propa)
   apply blast
  apply simp
  apply (rule conjI)
   apply (rule merges_preserves_type)
   apply blast
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (rule conjI)
   apply clarify
   apply (blast intro!: stable_pres_lemma)
  apply (rule conjI)
   apply (blast intro!: merges_incr intro: le_list_trans)
  apply (rule conjI)
   apply clarsimp
   apply (blast intro!: merges_bounded_lemma)
  apply (blast dest!: boundedD)

  -- "Postcondition holds upon termination:"
  apply(clarsimp simp add: stables_def split_paired_all)

  -- "Well-foundedness of the termination relation:"
  apply (rule wf_lex_prod)
   apply (insert orderI [THEN acc_le_listI])
   apply (simp only: acc_def lesssub_def)
  apply (rule wf_s_finite_psubset)

  -- "Loop decreases along termination relation:"
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w \<in> s_\<alpha> w")
   prefer 2 apply (erule choose_spec)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (s_choose w) (ss ! (s_choose w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(t_\<alpha> (propa f (step (s_choose w) (ss ! s_choose w)) ss
            (s_remove (s_choose w) w)),
           ss, s_\<alpha> w)
          \<in> {(ss', ss). ss \<in> list n A \<and> ss' \<in> list n A \<and> ss [\<sqsubset>\<^bsub>r\<^esub>] ss'} <*lex*> finite_psubset")
   prefer 2
   apply (subst decomp_propa)
    apply blast
   apply clarify
   apply (simp del: listE_length
               add: lex_prod_def finite_psubset_def bounded_nat_set_is_finite)
   apply(subgoal_tac "merges f (step (s_choose w) (ss ! s_choose w)) ss \<in> list n A")
    apply simp
    apply (rule termination_lemma)
    apply (rule assms)
    apply assumption+
   apply clarsimp
  apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss
               (s_remove (s_choose w) w)")
  apply(simp add: s_finite_psubset_inv_image)
  done
qed
(*>*)

lemma kildall_properties: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 [\<sqsubseteq>\<^sub>r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply (unfold kildall_def)
  apply(case_tac "iter f step ss0 (unstables r step ss0)")
  apply(simp)
  apply (rule iter_properties[where ?w0.0="unstables r step ss0"])
  apply(rule assms)
  apply (simp_all add: unstables_def stable_def s_\<alpha>_foldr_s_insert foldr_insert_conv_set)
  done
qed

lemma is_bcv_kildall: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(unfold is_bcv_def wt_step_def)
  apply(insert `Semilat A r f` semilat kildall_properties[of A])
  apply(simp add:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0 \<in> list n A")
   prefer 2 apply (simp(no_asm_simp))
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step \<tau>s\<^sub>0" in bexI)
    apply (rule conjI)
     apply (blast)
    apply (simp  (no_asm_simp))
   apply(assumption)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0!p <=_r \<tau>s!p")
   apply simp
  apply (blast intro!: le_listD less_lengthI)
  done
qed
(*>*)

end

interpretation Kildall "set" "[]" "\<lambda>xs. xs = []" "hd" "removeAll" "Cons"
by(unfold_locales) auto

lemmas kildall_code [code] =
  kildall_def
  Kildall_base.propa.simps
  Kildall_base.iter_def
  Kildall_base.unstables_def
  Kildall_base.kildall_def

end