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

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

theory MapExtra
imports Main
begin

text \<open>
  BEWARE: we are not interested in using the @{term "dom x \<inter> dom y = {}"}
  rules from Map for our separation logic proofs. As such, we overwrite the
  Map rules where that form of disjointness is in the assumption conflicts
  with a name we want to use with @{text "\<bottom>"}.\<close>

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

text \<open>---------------------------------------\<close>
text \<open>Things that should go into Option Type\<close>
text \<open>---------------------------------------\<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

text \<open>---------------------------------------\<close>
text \<open>Things that should go into Map.thy\<close>
text \<open>---------------------------------------\<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 (rule fun_eq_iff)

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

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 (simp add: map_le_antisym map_le_def)

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: set_eqI 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 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 (fastforce 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)

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)

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)

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)

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)

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

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 (fastforce 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 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 (metis map_add_restrict_comp_right_dom map_le_iff_map_add_commute map_le_restrict)

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

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto 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 split: option.splits)

text \<open>---------------------------------------\<close>
text \<open>Things that should NOT go into Map.thy\<close>
text \<open>---------------------------------------\<close>

section \<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]

text \<open>Heap monotonicity and the frame property\<close>

definition
  heap_mono :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "heap_mono f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f h = Some v \<longrightarrow> f (h ++ h') = Some v"

lemma heap_monoE:
  "\<lbrakk> heap_mono f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = Some v"
  unfolding heap_mono_def by blast

lemma heap_mono_simp:
  "\<lbrakk> heap_mono f ; f h = Some v ; h \<bottom> h' \<rbrakk> \<Longrightarrow> f (h ++ h') = f h"
  by (frule (2) heap_monoE, simp)

definition
  heap_frame :: "(('a \<rightharpoonup> 'b) \<Rightarrow> 'c option) \<Rightarrow> bool" where
  "heap_frame f \<equiv> \<forall>h h' v. h \<bottom> h' \<and> f (h ++ h') = Some v
                           \<longrightarrow> (f h = Some v \<or> f h = None)"

lemma heap_frameE:
  "\<lbrakk> heap_frame f ; f (h ++ h') = Some v ; h \<bottom> h' \<rbrakk>
   \<Longrightarrow> f h = Some v \<or> f h = None"
  unfolding heap_frame_def by fastforce

section \<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)

section \<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)

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, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_ac_simps"})
\<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_ac_simps =
  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)

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_ac_simps)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_ac_simps)
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
  { 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_ac_simps)

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_ac_simps)
  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
  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
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 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 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 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_ac_simps)

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
  using exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"]
  by (rule iffI, clarsimp)
     (fastforce intro: set_eqI 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)

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 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_ac_simps)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce 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_ac_simps intro!: restrict_map_disj_both restrict_map_disj)

end


theory Smap
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Stream"

begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy
primcorec smap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "smap f xs = SCons (f (shd xs)) (smap f (stl xs))"
(* cohipster smap *)
(* Discovered in ca. 15 sec *)
lemma lemma_a [thy_expl]: "SCons (y z) (smap y x2) = smap y (SCons z x2)"
 by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    simp
(*cohipster smap Fun.id*)
(* Discovered in ca. 15 sec *)
lemma lemma_aa [thy_expl]: "smap id y = y"
  by (coinduction arbitrary: y rule: Stream.Stream.coinduct_strong)
    simp
(*cohipster smap Fun.comp*)
(* Discovered in ca. 30 seconds *)
lemma lemma_ab [thy_expl]: "smap (y \<circ> z) x2 = smap y (smap z x2)"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    auto

end


(* Author: Mathias Fleury
   Minor additions by Peter Lammich
*)
theory Bits_Natural
  imports "HOL-Library.Word" Word_Lib.Aligned "Word_Lib.Word_Lib_Sumo"
begin

(* TODO: Move *)
lemma bin_trunc_xor':
  "bintrunc n x XOR bintrunc n y = bintrunc n (x XOR y)"
  by (auto simp add: bin_eq_iff bin_nth_ops nth_bintr)

(*lemma uint_xor: "uint (x XOR y) = uint x XOR uint y"
  by (transfer, simp add: bin_trunc_xor')*)

instance nat :: semiring_bit_syntax ..

instantiation nat :: set_bit begin
  definition set_bit_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> nat" where
    "set_bit i n b = nat (bin_sc n b (int i))"

instance
  apply standard
  apply (simp_all add: set_bit_nat_def)
  by (metis bin_nth_sc_gen bin_sign_sc bit_nat_iff bit_of_nat_iff_bit of_nat_0_le_iff sign_Pls_ge_0)
end

instantiation nat :: msb
begin
  definition msb_nat :: "nat \<Rightarrow> bool" where
    "msb i = msb (int i)"

instance ..
end

(*
instantiation nat :: semiring_bit_shifts
begin

definition set_bits_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat" where
  "set_bits f =
  (if \<exists>n. \<forall>n'\<ge>n. \<not> f n' then
     let n = LEAST n. \<forall>n'\<ge>n. \<not> f n'
     in nat (bl_to_bin (rev (map f [0..<n])))
   else if \<exists>n. \<forall>n'\<ge>n. f n' then
     let n = LEAST n. \<forall>n'\<ge>n. f n'
     in nat (sbintrunc n (bl_to_bin (True # rev (map f [0..<n]))))
   else 0 :: nat)"

definition not_nat :: "nat \<Rightarrow> nat" where
  "NOT i = nat (NOT (int i))"

(*
definition shiftl_nat where
  "shiftl x n = nat ((int x) * 2 ^ n)"

definition shiftr_nat where
  "shiftr x n = nat (int x div 2 ^ n)"

definition bitNOT_nat :: "nat \<Rightarrow> nat" where
  "bitNOT i = nat (bitNOT (int i))"

definition bitAND_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitAND i j = nat (bitAND (int i) (int j))"

definition bitOR_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitOR i j = nat (bitOR (int i) (int j))"

definition bitXOR_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "bitXOR i j = nat (bitXOR (int i) (int j))"

definition msb_nat :: "nat \<Rightarrow> bool" where
  "msb i = msb (int i)"
*)
instance . .

end
*)

lemma nat_shiftr[simp]:
  "m >> 0 = m"
  \<open>((0::nat) >> m) = 0\<close>
  \<open>(m >> Suc n) = (m div 2 >> n)\<close> for m :: nat
  by (simp_all add: shiftr_eq_drop_bit drop_bit_Suc)

lemma nat_shifl_div: \<open>m >> n = m div (2^n)\<close> for m :: nat
  by (induction n arbitrary: m) (auto simp: div_mult2_eq)

lemma nat_shiftl[simp]:
  "m << 0 = m"
  \<open>((0) << m) = 0\<close>
  \<open>(m << Suc n) = ((m * 2) << n)\<close> for m :: nat
  by (simp_all add: shiftl_eq_push_bit)

lemma nat_shiftr_div2: \<open>m >> 1 = m div 2\<close> for m :: nat
  by auto

lemma nat_shiftr_div: \<open>m << n = m * (2^n)\<close> for m :: nat
  by (induction n arbitrary: m) (auto simp: div_mult2_eq)

definition shiftl1 :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>shiftl1 n = n << 1\<close>

definition shiftr1 :: \<open>nat \<Rightarrow> nat\<close> where
  \<open>shiftr1 n = n >> 1\<close>

(*
instantiation natural :: bit_comprehension
begin

context includes natural.lifting begin

lift_definition test_bit_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> bool\<close> is test_bit .

lift_definition lsb_natural :: \<open>natural \<Rightarrow> bool\<close> is lsb .

lift_definition set_bit_natural :: "natural \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> natural" is
  set_bit .

lift_definition set_bits_natural :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> natural\<close>
  is \<open>set_bits :: (nat \<Rightarrow> bool) \<Rightarrow> nat\<close> .

lift_definition shiftl_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> natural\<close>
  is \<open>shiftl :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition shiftr_natural :: \<open>natural \<Rightarrow> nat \<Rightarrow> natural\<close>
  is \<open>shiftr :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitNOT_natural :: \<open>natural \<Rightarrow> natural\<close>
  is \<open>bitNOT :: nat \<Rightarrow> nat\<close> .

lift_definition bitAND_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitAND :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitOR_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitOR :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition bitXOR_natural :: \<open>natural \<Rightarrow> natural \<Rightarrow> natural\<close>
  is \<open>bitXOR :: nat \<Rightarrow> nat \<Rightarrow> nat\<close> .

lift_definition msb_natural :: \<open>natural \<Rightarrow> bool\<close>
  is \<open>msb :: nat \<Rightarrow> bool\<close> .

end

instance ..
end
*)

lemma bitXOR_1_if_mod_2: \<open> L XOR 1 = (if L mod 2 = 0 then L + 1 else L - 1)\<close> for L :: nat
  apply transfer
  apply (subst int_int_eq[symmetric])
  apply (rule bin_rl_eqI)
   apply (auto simp: xor_nat_def)
  unfolding bin_last_def xor_nat_def
       apply presburger+
  done

lemma bitAND_1_mod_2: \<open>L AND 1 = L mod 2\<close> for L :: nat by auto

lemma nat_set_bit_0: \<open>set_bit x 0 b = nat ((bin_rest (int x)) BIT b)\<close> for x :: nat
  by (auto simp: set_bit_nat_def Bit_def)

lemma nat_test_bit0_iff: \<open>n !! 0 \<longleftrightarrow> n mod 2 = 1\<close> for n :: nat
proof -
  have 2: \<open>2 = int 2\<close>
    by auto
  have [simp]: \<open>int n mod 2 = 1 \<longleftrightarrow> n mod 2 = Suc 0\<close>
    unfolding 2 zmod_int[symmetric]
    by auto

  show ?thesis
    unfolding test_bit_eq_bit
    by (auto simp: bin_last_def zmod_int bit_nat_def odd_iff_mod_2_eq_one)

qed

lemma test_bit_2: \<open>m > 0 \<Longrightarrow> (2*n) !! m \<longleftrightarrow> n !! (m - 1)\<close> for n :: nat
  by (cases m)
    (auto simp: test_bit_eq_bit bit_nat_def)

lemma test_bit_Suc_2: \<open>m > 0 \<Longrightarrow> Suc (2 * n) !! m \<longleftrightarrow> (2 * n) !! m\<close> for n :: nat
  apply (cases m)
  by (auto simp: test_bit_eq_bit bit_nat_def div_mult2_eq)

lemma bin_rest_prev_eq:
  assumes [simp]: \<open>m > 0\<close>
  shows  \<open>nat ((bin_rest (int w))) !! (m - Suc (0::nat)) = w !! m\<close>
proof -
  define m' where \<open>m' = w div 2\<close>
  have w: \<open>w = 2 * m' \<or> w = Suc (2 * m')\<close>
    unfolding m'_def
    by auto
  moreover have \<open>bin_nth (int m') (m - Suc 0) = m' !! (m - Suc 0)\<close>
    by (simp add: bit_of_nat_iff_bit test_bit_eq_bit)
  ultimately show ?thesis
    by (auto simp: test_bit_2 test_bit_Suc_2)
qed

lemma bin_sc_ge0: \<open>w >= 0 ==> (0::int) \<le> bin_sc n b w\<close>
  by (induction n arbitrary: w) auto

lemma bin_to_bl_eq_nat:
  \<open>bin_to_bl (size a) (int a) = bin_to_bl (size b) (int b) ==> a=b\<close>
  by (metis Nat.size_nat_def size_bin_to_bl)

lemma nat_bin_nth_bl: "n < m \<Longrightarrow> w !! n = nth (rev (bin_to_bl m (int w))) n" for w :: nat
  by (metis bin_nth_bl bit_of_nat_iff_bit test_bit_eq_bit)

lemma bin_nth_ge_size: \<open>nat na \<le> n \<Longrightarrow> 0 \<le> na \<Longrightarrow> bin_nth na n = False\<close>
proof (induction \<open>n\<close> arbitrary: na)
  case 0
  then show ?case by auto
next
  case (Suc n na) note IH = this(1) and H = this(2-)
  have \<open>na = 1 \<or> 0 \<le> na div 2\<close>
    using H by auto
  moreover have
    \<open>na = 0 \<or> na = 1 \<or> nat (na div 2) \<le> n\<close>
    using H by auto
  ultimately show ?case
    using IH[rule_format,  of \<open>bin_rest na\<close>] H
    by (auto simp: bit_Suc)
qed

lemma test_bit_nat_outside: "n > size w \<Longrightarrow> \<not>w !! n" for w :: nat
  unfolding test_bit_eq_bit bit_nat_def
  by (metis Nat.size_nat_def div_less even_zero le_eq_less_or_eq le_less_trans n_less_equal_power_2)

lemma nat_bin_nth_bl':
  \<open>a !! n \<longleftrightarrow> (n < size a \<and> (rev (bin_to_bl (size a) (int a)) ! n))\<close>
  by (metis Nat.size_nat_def bit_nat_def div_less even_zero n_less_equal_power_2 nat_bin_nth_bl not_less_iff_gr_or_eq test_bit_eq_bit test_bit_nat_outside)

lemma nat_set_bit_test_bit: \<open>set_bit w n x !! m = (if m = n then x else w !! m)\<close> for w n :: nat
  unfolding nat_bin_nth_bl'
  apply auto
        apply (metis bin_nth_bl bin_nth_sc bin_nth_simps(3) bin_to_bl_def int_nat_eq set_bit_nat_def)
       apply (metis bin_nth_ge_size bin_nth_sc bin_sc_ge0 leI of_nat_less_0_iff set_bit_nat_def)
      apply (metis bin_nth_bl bin_nth_ge_size bin_nth_sc bin_sc_ge0 bin_to_bl_def int_nat_eq leI
      of_nat_less_0_iff set_bit_nat_def)
  apply (metis Nat.size_nat_def bin_to_bl_def nat_bin_nth_bl' set_bit_class.bit_set_bit_iff test_bit_eq_bit)
    apply (metis Nat.size_nat_def bin_nth_bl bin_nth_sc_gen bin_to_bl_def int_nat_eq nat_bin_nth_bl
      nat_bin_nth_bl' of_nat_less_0_iff of_nat_less_iff set_bit_nat_def)
   apply (metis (full_types) bin_nth_bl bin_nth_ge_size bin_nth_sc_gen bin_sc_ge0 bin_to_bl_def leI of_nat_less_0_iff set_bit_nat_def)
  by (metis bin_nth_bl bin_nth_ge_size bin_nth_sc_gen bin_sc_ge0 bin_to_bl_def int_nat_eq leI of_nat_less_0_iff set_bit_nat_def)

lemma unat_or: "unat (x OR y) = unat x OR unat y" by (rule unsigned_or_eq)

lemma unat_and: "unat (x AND y) = unat x AND unat y" by (rule unsigned_and_eq)

lemma unat_xor: "unat (x XOR y) = unat x XOR unat y" by (rule unsigned_xor_eq)

(* TODO: Add OR-numerals, XOR-numerals! *)

lemma nat_and_numerals [simp]:
  "(numeral (Num.Bit0 x) :: nat) AND (numeral (Num.Bit0 y) :: nat) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit0 x) AND numeral (Num.Bit1 y) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit0 y) = (2 :: nat) * (numeral x AND numeral y)"
  "numeral (Num.Bit1 x) AND numeral (Num.Bit1 y) = (2 :: nat) * (numeral x AND numeral y)+1"
  "0 AND n = 0"
  "n AND 0 = 0"
  "(1::nat) AND numeral (Num.Bit0 y) = 0"
  "(1::nat) AND numeral (Num.Bit1 y) = 1"
  "numeral (Num.Bit0 x) AND (1::nat) = 0"
  "numeral (Num.Bit1 x) AND (1::nat) = 1"
  "(Suc 0::nat) AND numeral (Num.Bit0 y) = 0"
  "(Suc 0::nat) AND numeral (Num.Bit1 y) = 1"
  "numeral (Num.Bit0 x) AND (Suc 0::nat) = 0"
  "numeral (Num.Bit1 x) AND (Suc 0::nat) = 1"
  "Suc 0 AND Suc 0 = 1"
  for n::nat
  by (auto simp: and_nat_def Bit_def nat_add_distrib)

lemma nat_and_comm: "a AND b = b AND a" for a b :: nat
  unfolding and_nat_def by (auto simp: int_and_comm)

lemma AND_upper_nat1: "a AND b \<le> a" for a b :: nat
proof -
  have "int a AND int b \<le> int a"
    by (rule AND_upper1) simp
  thus ?thesis unfolding and_nat_def by linarith
qed

lemma AND_upper_nat2: "a AND b \<le> b" for a b :: nat
  using AND_upper_nat1[of b a] by (simp add: nat_and_comm)

lemmas AND_upper_nat1' [simp] = order_trans [OF AND_upper_nat1]
lemmas AND_upper_nat1'' [simp] = order_le_less_trans [OF AND_upper_nat1]

lemmas AND_upper_nat2' [simp] = order_trans [OF AND_upper_nat2]
lemmas AND_upper_nat2'' [simp] = order_le_less_trans [OF AND_upper_nat2]

lemma msb_shiftr_nat [simp]: "msb ((x :: nat) >> r) \<longleftrightarrow> msb x"
  by (simp add: msb_int_def msb_nat_def)

lemma bintrunc_le: \<open>a \<ge> 0 \<Longrightarrow> a < b \<Longrightarrow> bintrunc n a < b\<close>
  by (smt bintr_lt2p bintrunc_mod2p mod_pos_pos_trivial)

lemma msb_shiftr_word [simp]: "r < LENGTH('a) \<Longrightarrow> msb ((x :: 'a :: {len} word) >> r) \<longleftrightarrow> ((r = 0 \<and> msb x))"
  apply (cases r)
  apply (auto simp: bl_shiftr word_size msb_word_def
    simp flip: sint_uint[unfolded One_nat_def] hd_bl_sign_sint)
  done

lemma msb_shiftl_word [simp]: "r < LENGTH('a)  \<Longrightarrow> x << r < 2 ^ (LENGTH('a) - Suc 0) \<Longrightarrow>
     msb ((x :: 'a :: {len} word) << r) = (r = 0 \<and> msb x)"
  using less_is_drop_replicate[of \<open>x << r\<close> \<open>(LENGTH('a) - Suc 0)\<close>]
  apply (cases r)
  apply (auto simp: bl_shiftl word_size msb_word_def
    simp flip: sint_uint[unfolded One_nat_def] hd_bl_sign_sint)
  done

end


theory TTock_FL

imports
  TTock
  "HOL-Library.Sublist"
  Finite_Linear_Model
begin

text \<open>Function mapping to non-subset closed refusals.\<close>

fun funFLTTockl :: "('a tockevent) fltrace \<Rightarrow> 'a ctockl" where
"funFLTTockl \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> = (if A = \<bullet> then [] else [Ref {z. z \<notin>\<^sub>\<F>\<^sub>\<L> A}])" |
"funFLTTockl (A #\<^sub>\<F>\<^sub>\<L> fl) = (if event(A) = tock \<and> acceptance(A) \<noteq> \<bullet> then
                             (Ref {z. z \<notin>\<^sub>\<F>\<^sub>\<L> acceptance(A)} # REvent tock # (funFLTTockl fl))
                          else ((REvent (event A)) # funFLTTockl fl))"

lemma funFLTTockl_is_ctockWD[simp]:
  "ctockWD (funFLTTockl fltrace)"
  apply (induct fltrace rule:funFLTTockl.induct, auto)
  using event_in_acceptance by fastforce

lift_definition funFLTTock :: "('a tockevent) fltrace \<Rightarrow> 'a ctock" is funFLTTockl by auto

definition fFL2Tock :: "('a tockevent) fltrace set \<Rightarrow> 'a ctock set" where
"fFL2Tock P = {funFLTTock fl|fl. fl \<in> P}"

lemma fFL2Tock_univ_disj:
  "fFL2Tock (\<Union> P) = \<Union>{fFL2Tock fl|fl. fl \<in> P}"
  unfolding fFL2Tock_def by auto

definition TTock2FLf :: "'a ctock set \<Rightarrow> ('a tockevent) fltrace set" where
"TTock2FLf P = \<Union>{fl. (fFL2Tock fl) \<subseteq> P}"

lemma "mkFL1(TTock2FLf(P)) = \<Union>{mkFL1(fl)| fl. (fFL2Tock fl) \<subseteq> P}"
  unfolding mkFL1_def TTock2FLf_def by auto

lemma fFL2Tock_mono:
  assumes "P \<subseteq> Q"
  shows "fFL2Tock(P) \<subseteq> fFL2Tock(Q)"
  using assms unfolding fFL2Tock_def by auto

lemma TTock2FLf_mono:
  assumes "P \<subseteq> Q"
  shows "TTock2FLf(P) \<subseteq> TTock2FLf(Q)"
  using assms unfolding TTock2FLf_def by auto

lemma prefix_exists_funFLTTockl:
  assumes "prefix s (funFLTTockl fl)" (*"FL1 P" "FL0 P"*)
  shows "\<exists>fl\<^sub>0. s = funFLTTockl fl\<^sub>0 \<and> fl\<^sub>0 \<le> fl"
  using assms proof(induct fl arbitrary:s rule:funFLTTockl.induct)
  case (1 A)
  then show ?case
  proof (cases A)
    case acnil
    then show ?thesis using 1
      apply auto
      by (rule exI[where x="\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
  next
    case (acset x2)
    then show ?thesis using 1
     proof (cases s)
      case Nil
      then show ?thesis by (intro exI[where x="\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
    next
      case (Cons a list)
      then show ?thesis using 1 acset by (intro exI[where x="\<langle>[x2]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
    qed
  qed
next
  case (2 A fl)
  then show ?case
  proof(induct s)
    case Nil
    then show ?case by (auto, intro exI[where x="\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
  next
    case C1:(Cons a x)
    then show ?case
    proof(cases "event A = tock \<and> acceptance A \<noteq> \<bullet>")
      case True
      then show ?thesis using C1
        proof (induct x)
          case Nil
          then show ?case
            using C1
            apply (auto, intro exI[where x="\<langle>acceptance(A)\<rangle>\<^sub>\<F>\<^sub>\<L>"])
            by auto
        next
          case C2:(Cons aa ss)
          then have AA:
            "[a,aa] = funFLTTockl(\<langle>A,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
            by (simp add: C2.prems(4))

          have "prefix ss (funFLTTockl fl)"
                       "\<exists>fl\<^sub>0. ss = funFLTTockl fl\<^sub>0 \<and> fl\<^sub>0 \<le> fl"
            using C2 by auto
          then have "\<exists>fl\<^sub>0. a # aa # ss = a # aa # funFLTTockl fl\<^sub>0 \<and> fl\<^sub>0 \<le> fl"
            by auto
          then have "\<exists>fl\<^sub>0. a # aa # ss = funFLTTockl (A #\<^sub>\<F>\<^sub>\<L> fl\<^sub>0) \<and> fl\<^sub>0 \<le> fl"
            using AA by auto
          then show ?case
            using less_eq_fltrace.simps(3) by blast
        qed
    next
      case False
      then show ?thesis
        by (metis C1.prems(2) C1.prems(3) Cons_prefix_Cons dual_order.refl funFLTTockl.simps(2) less_eq_fltrace.simps(3))
    qed
  qed
qed

lemma funFLTTockl_consC_mutual_extend:
  assumes "xs = funFLTTockl fl"
  shows "\<exists>z. xs @\<^sub>C [y] = funFLTTockl (fl @\<^sub>\<F>\<^sub>\<L> z)"
  using assms
proof (induct fl arbitrary: xs y rule:funFLTTockl.induct)
  case (1 A)
  then show ?case
  proof (cases A)
    case acnil
    {
      then have "\<exists>z. [y] = funFLTTockl z"
      proof (cases y)
      case (Ref x1)
      then show ?thesis
        apply auto
        apply (rule exI[where x="\<langle>[{x. x \<notin> x1}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>"])
        by auto
      next
      case (REvent x2)
      then show ?thesis
      proof (cases x2)
        case (Event ev)
        then show ?thesis
          using acnil apply (intro exI[where x="\<langle>([{Event ev}]\<^sub>\<F>\<^sub>\<L>,Event ev)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"])
          apply auto
          by (simp add: REvent)
      next
        case tock
        then show ?thesis
          using acnil apply (intro exI[where x="\<langle>(\<bullet>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"])
          apply auto
          by (simp add: REvent)
      qed
      qed
      then show ?thesis using "1" acnil by auto
    }
  next
    case (acset x2)
    then show ?thesis using "1"
    proof (cases y)
      case (Ref x1)
      then show ?thesis using 1 acset apply auto
        apply (rule exI[where x="\<langle>[{x. x \<notin> x1}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>"])
          by auto
    next
      case (REvent rev)
      then show ?thesis
        proof (cases rev)
          case (Event x1)
          then show ?thesis using 1 acset REvent apply auto
            by (rule exI[where x="\<langle>(\<bullet>,Event x1)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
        next
          case tock
          then show ?thesis using 1 acset REvent apply auto
             apply (rule exI[where x="\<langle>([x2]\<^sub>\<F>\<^sub>\<L>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
            by (rule exI[where x="\<langle>(\<bullet>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto)
        qed
    qed
  qed
next
  case (2 A fl)
  then show ?case by auto
qed

thm rev_induct

lemma ctockWD_concat_eq_some_concatC:
  assumes "ctockWD (xs @ [y])"
  shows "\<exists>z. xs @\<^sub>C [z] = xs @ [y]"
  using assms apply (induct xs arbitrary: y rule:ctockWD.induct, auto)
  apply (case_tac ya, auto)
  by (metis (full_types) ctockWD.simps(4) ctockWD.simps(6) ctockl_append.simps(4) tockevent.exhaust)

lemma funFLTTockl_consC_mutual_extend2:
  assumes "xs = funFLTTockl fl" "ctockWD (xs @ [y])"
  shows "\<exists>z. xs @ [y] = funFLTTockl (fl @\<^sub>\<F>\<^sub>\<L> z)"
  by (metis assms(1) assms(2) ctockWD_concat_eq_some_concatC funFLTTockl_consC_mutual_extend)

(* We could have instead established the following rev induction theorem,
   but with the above two theorems we can transfer the equality on @\<^sub>C to one
   over standard @. This is key to showing that we have a bijection under
   fFL2Tock(TTock2FLf(P)). *)

lemma tockl_is_in_funFLTTockl:
  assumes "ctockWD x" "TTockl2 P" (*"\<forall>s t. (t \<in> P \<and> list_le s t) \<longrightarrow> (s \<in> P)"*)
      and "\<forall>x\<in>P. ctockWD x"
      and "x \<in> P"
    shows "\<exists>fl. x = funFLTTockl fl \<and> (\<exists>x. {xa. (\<exists>fl. xa = funFLTTockl fl \<and> fl \<in> x) \<and> ctockWD xa} \<subseteq> P \<and> fl \<in> x)"
  using assms proof(induct x rule:rev_induct)
  case Nil
  then show ?case apply auto
     by (smt funFLTTockl.simps(1) mem_Collect_eq singletonD singletonI subsetI)
next
  case (snoc x xs)
  then have "xs \<in> P"
    apply auto
    using list_le_concat_prefix TTockl2_def by blast
  then show ?case using "snoc.hyps"
    apply auto
    using assms(2) funFLTTockl_consC_mutual_extend2
    by (smt assms(2) funFLTTockl_consC_mutual_extend2 mem_Collect_eq singletonD singletonI snoc.prems(3) snoc.prems(4) subsetI)
qed

lemma fFL2Tock_TTock2FLf_refines: "fFL2Tock(TTock2FLf(P)) \<subseteq> P"
  unfolding TTock2FLf_def fFL2Tock_def by auto

lemma xTTock2_refines_fFL2Tock_TTock2FLf:
  assumes "xTTock2 P"
  shows "P \<subseteq> fFL2Tock(TTock2FLf(P))"
  using assms unfolding TTock2FLf_def fFL2Tock_def apply auto
  apply transfer
  apply auto
  using tockl_is_in_funFLTTockl by blast

lemma xTTock2_bij:
  assumes "xTTock2 P"
  shows "fFL2Tock(TTock2FLf(P)) = P"
  using assms
  by (simp add: fFL2Tock_TTock2FLf_refines subset_antisym xTTock2_refines_fFL2Tock_TTock2FLf)

lemma fFL2Tock_TTock2FLf_is_xTTock1:
  assumes "xTTock1 P"
  shows "xTTock1(fFL2Tock(TTock2FLf(P)))"
  using assms
  by (simp add: xTTock1_imp_xTTock2 xTTock2_bij)

lemma
  assumes "prefix s t" "FL0 P" "FL1 P"
      and "t \<in> {funFLTTockl fl|fl. fl \<in> P \<and> ctockWD(funFLTTockl fl)}"
    shows "s \<in> {funFLTTockl fl|fl. fl \<in> P \<and> ctockWD(funFLTTockl fl)}"
  using assms
  by (smt FL1_def ctockWD_list_le mem_Collect_eq prefix_exists_funFLTTockl)

lemma TTockl2_prefix_help1:
  assumes "X # Y # Z \<in> P" "TTockl2 P"
  shows "[X, Y] \<in> P"
  using assms
  by (metis TTockl2_def append.left_neutral append_Cons list_le_concat_prefix_also_prefix prefix_Cons prefix_order.dual_order.refl)

lemma TTockl2_prefix_help2:
  assumes "X # Y \<in> P" "TTockl2 P"
  shows "[X] \<in> P"
  using assms
  by (meson TTockl2_def Cons_prefix_Cons prefix_code(1))

lemma funFLTTockl_prefix_help:
  assumes "funFLTTockl (x1a #\<^sub>\<F>\<^sub>\<L> t) \<in> P" "TTockl2 P"
  shows "funFLTTockl \<langle>x1a,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P"
  using assms TTockl2_prefix_help2 TTockl2_prefix_help1
  by fastforce

lemma fFL2Tock_is_xTTock2:
  assumes "FL1 P"
  shows "xTTock2(fFL2Tock(P))"
  using assms unfolding fFL2Tock_def apply transfer
  unfolding TTockl2_def apply auto
   apply (meson FL1_def prefix_exists_funFLTTockl)
  using ctockWD_list_le funFLTTockl_is_ctockWD by blast

(* Work in progress below *)

definition TTock2FL1 :: "'a ctock set \<Rightarrow> ('a tockevent) fltrace set" where
"TTock2FL1 P = \<Union>{fl. FL1 fl \<and> (fFL2Tock fl) \<subseteq> P}"

lemma TTock2FL1_mono:
  assumes "P \<subseteq> Q"
  shows   "TTock2FL1(P) \<subseteq> TTock2FL1(Q)"
  using assms unfolding TTock2FL1_def by auto

lemma fFL2Tock_TTock2FL1_refines: "fFL2Tock(TTock2FL1(P)) \<subseteq> P"
  unfolding TTock2FL1_def fFL2Tock_def by auto

lemma xTTock2_refines_fFL2Tock_TTock2FL1:
  assumes "xTTock2 P"
  shows "P \<subseteq> fFL2Tock(TTock2FL1(P))"
  using assms unfolding TTock2FL1_def fFL2Tock_def apply auto
  apply transfer
  apply auto
  oops

lemma
  assumes "xTTock2 P"
  shows "fFL2Tock(TTock2FL1(P)) = P"
  using assms unfolding TTock2FL1_def
  apply auto
  oops

lemma FL1_two_element_set:
  shows "FL1 {\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>, \<langle>(\<bullet>,x1)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}"
proof -
  have "FL1 {\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>, \<langle>(\<bullet>,x1)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}
        =
        (mkFL1 ({\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>, \<langle>(\<bullet>,x1)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}) = {\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>, \<langle>(\<bullet>,x1)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>})"
    using FL1_fixpoint by auto
  also have "... = True"
    unfolding mkFL1_def apply auto
     apply (metis dual_order.refl fltrace_antisym fltrace_trans prefixFL_induct2)
    apply (case_tac x, auto)
      apply (case_tac x1, auto)
     apply (case_tac x21, auto)
    apply (case_tac a, auto)
      apply (simp_all add: Abs_aevent_inverse less_eq_aevent_def)
    by (metis antisym_conv dual_order.refl order.trans prefixFL_induct2)
  finally show ?thesis by auto
qed

lemma FL1_prefix_set:
 "FL1 {z. z \<le> Y}"
  unfolding FL1_def by auto

lemma
  assumes "funFLTTockl ys \<in> P" "xs \<le> ys" "TTockl2 P"
  shows "funFLTTockl xs \<in> P"
  using assms
  oops

lemma Ref_tock_le_in_funFLTTockl:
  assumes "[Ref {z. z \<notin> x2}, REvent tock] \<in> P" "TTockl2 P" "tock \<in> x2"
          -- \<open>The following healthiness condition was introduced because of this lemma\<close>
          "TTockl3 P"
  shows "fl \<le> \<langle>([x2]\<^sub>\<F>\<^sub>\<L>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<longrightarrow> funFLTTockl fl \<in> P"
  using assms
proof (induct fl)
  have Nil_in:"[] \<in> P" using assms unfolding TTockl2_def apply auto
    using Nil_prefix by blast
   case (Acceptance x)
  then show ?case
    apply (case_tac x, auto simp add:Nil_in)
    using TTockl2_prefix_help2 by blast
next
  case (AEvent x1a fl)
  then show ?case apply auto
         apply (case_tac fl, auto, case_tac x1a, auto, case_tac x1, auto)
        apply (case_tac fl, auto, case_tac x1a, auto, case_tac x1, auto, case_tac x1, auto)
       apply (case_tac fl, auto, case_tac x1a, auto, case_tac x1, auto)
      apply (case_tac fl, auto, case_tac x1a, auto, case_tac a, auto)
       apply (metis Collect_cong acceptance_set amember.simps(2) less_eq_acceptance.simps(3) less_eq_aevent_def)
      apply (case_tac fl, auto, case_tac x1a, auto, case_tac x1, auto)
     apply (case_tac fl, auto, case_tac x1a, auto, case_tac a, auto)
    apply (simp_all add: less_eq_aevent_def)
    apply (case_tac fl, auto, case_tac x1a, auto)
    apply (metis (no_types, lifting) TTockl3_def append_eq_Cons_conv assms(1) assms(4))
    using less_eq_acceptance.elims(2) by blast
qed

(*
lemma xpp3:
  assumes "xs = funFLTTockl fl" "ctockWD (xs @ [y])"
  shows "\<exists>z. xs @ [y] = funFLTTockl (fl @\<^sub>\<F>\<^sub>\<L> z) \<and> (\<exists>x. FL1 x \<and> fl \<in> x \<and> (fl @\<^sub>\<F>\<^sub>\<L> z) \<in> x)"
  using assms sorry

lemma xpp21:
  assumes "xs = funFLTTockl fl"
  shows "\<exists>z. xs @\<^sub>C [y] = funFLTTockl (fl @\<^sub>\<F>\<^sub>\<L> z) \<and> (\<exists>x. FL1 x \<and> (fl @\<^sub>\<F>\<^sub>\<L> z) \<in> x)"
  using assms sorry
*)

lemma some_x_then_nil_TTockl2:
  assumes "x \<in> P" "TTockl2 P"
  shows "[] \<in> P"
  using assms
  using TTl0s_TTl2s_imp_nil TTockl0_def empty_iff by blast

lemma fl_le_TTockl2:
  assumes "fl \<le> \<langle>[{z. z \<notin> x1}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>" "[Ref x1] \<in> P" "TTockl2 P"
  shows "funFLTTockl fl \<in> P"
  using assms apply (cases fl, auto)
  using some_x_then_nil_TTockl2 apply auto
  apply (case_tac x1a, auto)
  by (smt Collect_cong Collect_mem_eq mem_Collect_eq)

lemma fl_le_TTockl2_Event:
  assumes "fl \<le> \<langle>(\<bullet>,(Event ev))\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>" "[REvent (Event ev)] \<in> P" "TTockl2 P"
  shows "funFLTTockl fl \<in> P"
  using assms apply (cases fl, auto)
  using some_x_then_nil_TTockl2 apply auto
  apply (case_tac x1, auto)
    apply (case_tac x21, auto)
  apply (simp_all add: less_eq_aevent_def)
   apply (case_tac x21, auto)
  by (case_tac x22, auto, case_tac x1, auto)+

lemma fl_le_TTockl2_tock:
  assumes "fl \<le> \<langle>(\<bullet>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>" "[REvent tock] \<in> P" "TTockl2 P"
  shows "funFLTTockl fl \<in> P"
  using assms apply (cases fl, auto)
  using some_x_then_nil_TTockl2 apply auto
  apply (case_tac x1, auto)
    apply (case_tac x21, auto)
    apply (simp_all add: less_eq_aevent_def)
   apply (case_tac a, auto)
  by (case_tac x22, auto, case_tac x1, auto)

lemma funFLTTockl_last_tock:
  assumes "tock \<in>\<^sub>\<F>\<^sub>\<L> last fl"
  shows "funFLTTockl (fl @\<^sub>\<F>\<^sub>\<L> \<langle>(last fl,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) = funFLTTockl fl @ funFLTTockl(\<langle>(\<bullet>,tock)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms by (induct fl, auto)

end


theory Finite_Linear_Pri

imports
  "Utils.Event_Priority"
  Finite_Linear_Model
  Finite_Linear_Ops
begin

fun priacc :: "'a partialorder \<Rightarrow> 'a acceptance \<Rightarrow> 'a acceptance" ("priacc\<^sub>[\<^sub>_\<^sub>] _" [65,65]) where
"priacc\<^sub>[\<^sub>p\<^sub>](\<bullet>) = \<bullet>" |
\<comment> \<open>Any acceptance Z, that is not \<bullet>, is related to A, where A is a set that
    contains events in Z, such that no event b in Z is of higher priority as
    given by the partial order p.\<close>
"priacc\<^sub>[\<^sub>p\<^sub>]([Z]\<^sub>\<F>\<^sub>\<L>) = [Z \<inter> {e. \<not>(\<exists>b. b\<in>Z \<and> e <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>"

fun pri :: "'a partialorder \<Rightarrow> 'a fltrace \<Rightarrow> 'a fltrace \<Rightarrow> bool" where
"pri p \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>Z\<rangle>\<^sub>\<F>\<^sub>\<L> = (A = priacc\<^sub>[\<^sub>p\<^sub>](Z))" |
"pri p \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>) = False" |
"pri p (A #\<^sub>\<F>\<^sub>\<L> \<rho>) \<langle>Z\<rangle>\<^sub>\<F>\<^sub>\<L> = False" |
"pri p (A #\<^sub>\<F>\<^sub>\<L> \<rho>) (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>) =
  (acceptance A \<le> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z) \<and> (pri p \<rho> \<sigma>) \<and> event(A) = event(Z) \<and>
    (\<not> maximal(p,event(A)) \<longrightarrow> event(Z) \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z)))"

syntax
  "_pri" :: "'a fltrace \<Rightarrow> 'a partialorder \<Rightarrow> 'a fltrace \<Rightarrow> bool" ("_ pri\<^sub>[\<^sub>_\<^sub>] _" [51,51,51])

translations
  "x pri\<^sub>[\<^sub>p\<^sub>] y" == "CONST pri p x y"

definition Pri :: "'a partialorder \<Rightarrow> 'a fltraces \<Rightarrow> 'a fltraces" ("Pri\<^sub>[\<^sub>_\<^sub>] _" [51,51]) where
"Pri\<^sub>[\<^sub>p\<^sub>] P = {\<rho>|\<sigma> \<rho>. \<rho> pri\<^sub>[\<^sub>p\<^sub>] \<sigma> \<and> \<sigma> \<in> P}"

lemma Pri_univ_dist:
  "Pri p (\<Union> X) = \<Union>{Pri p x|x. x \<in> X}"
  unfolding Pri_def by auto

lemma priacc_not_in [intro]:
  assumes "e \<notin>\<^sub>\<F>\<^sub>\<L> Z"
  shows "e \<notin>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>] Z"
  using assms by (cases Z, auto)

lemma priacc_not_in' [intro]:
  assumes "A \<le> priacc\<^sub>[\<^sub>p\<^sub>] Z" "e \<in>\<^sub>\<F>\<^sub>\<L> A"
  shows "e \<in>\<^sub>\<F>\<^sub>\<L> Z"
  using assms apply (cases A, auto)
  apply (cases Z, auto)
  by (metis (mono_tags, lifting) Int_iff)

lemma priacc_in' [intro]:
  assumes "A \<le> priacc\<^sub>[\<^sub>p\<^sub>] Z" "e \<in>\<^sub>\<F>\<^sub>\<L> A"
  shows "e \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>] Z"
  using assms apply (cases A, auto)
  apply (cases Z, auto)
   apply (metis (no_types, lifting) IntE)
  by (metis (no_types, lifting) Int_Collect)

lemma priacc_in'' [intro]:
  assumes "b \<in>\<^sub>\<F>\<^sub>\<L> A" "\<forall>x. \<not> b <\<^sup>*p x"
  shows "b \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>] A"
  using assms by (cases A, auto)

lemma priacc_simp_aset [intro]:
  assumes "A \<le> priacc\<^sub>[\<^sub>p\<^sub>] Z"  "A \<noteq> \<bullet>"
  shows "A = [{a. a \<in>\<^sub>\<F>\<^sub>\<L> Z \<and> (\<forall>b. b \<in>\<^sub>\<F>\<^sub>\<L> Z \<longrightarrow> \<not> a <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>"
proof (cases A)
  case acnil
  then show ?thesis using assms by auto
next
  case (acset x2)
  obtain Y where Y:"[Y]\<^sub>\<F>\<^sub>\<L> = Z"
    using assms by (cases Z, auto, cases A, auto)

  have "[x2]\<^sub>\<F>\<^sub>\<L> \<le> priacc\<^sub>[\<^sub>p\<^sub>] Z"
    using acset assms by auto
  then have "[x2]\<^sub>\<F>\<^sub>\<L> = priacc\<^sub>[\<^sub>p\<^sub>] Z"
    using less_eq_acceptance.elims(2) by fastforce
  then have "[x2]\<^sub>\<F>\<^sub>\<L> = [Y \<inter> {e. \<not>(\<exists>b. b\<in>Y \<and> e <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>"
    using Y by auto
  then have "[x2]\<^sub>\<F>\<^sub>\<L> = [{a. a \<in>\<^sub>\<F>\<^sub>\<L> Z \<and> (\<forall>b. b \<in>\<^sub>\<F>\<^sub>\<L> Z \<longrightarrow> \<not> a <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>"
    using Y by auto
  then have "x2 = {a. a \<in>\<^sub>\<F>\<^sub>\<L> Z \<and> (\<forall>b. b \<in>\<^sub>\<F>\<^sub>\<L> Z \<longrightarrow> \<not> a <\<^sup>*p b)}"
    by auto
  then show ?thesis using acset by auto
qed

lemma pri_base_bullet [intro]:
  assumes "\<rho> pri\<^sub>[\<^sub>p\<^sub>] \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  shows "\<rho> = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms by (cases \<rho>, auto)

lemma pri_mono:
  assumes "P \<subseteq> Q"
  shows "Pri p P \<subseteq> Pri p Q"
  using assms unfolding Pri_def by auto

lemma bullet_in_pri:
  assumes "FL0 P" "FL1 P"
  shows "\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> Pri p P"
  using assms unfolding FL0_def Pri_def apply auto
  using FL0_FL1_bullet_in assms(1) pri.simps(1) priacc.simps(1)
  by metis

lemma pri_FL0:
  assumes "FL0 P" "FL1 P"
  shows "FL0 (Pri p P)"
  using assms FL0_def
  using bullet_in_pri by fastforce

lemma prirel_prirel_for_FL1:
  assumes "s \<le> t"
          "pri p t Z"
    shows "\<exists>Y. pri p s Y \<and> Y \<le> Z"
  using assms
proof (induct p t Z arbitrary:s rule:pri.induct)
  case (1 p A Z)
  then show ?case
    apply (cases s, auto)
    apply (cases A, auto, cases Z, auto)
    using "1.prems"(2) less_eq_acceptance.elims(2)
    apply (metis bullet_left_zero2 x_le_x_concat2)
    using "1.prems"(2) less_eq_acceptance.simps(1)
    by (metis acceptance.distinct(1) eq_iff less_eq_acceptance.elims(2) less_eq_fltrace.simps(1) pri.simps(1) priacc.simps(1))
next
  case (2 p A Z zz)
  then show ?case by auto
next
  case (3 p A aa Z)
  then show ?case by auto
next
  case (4 p A aa Z zz)
  then show ?case
  proof (induct s)
    case (Acceptance x)
    then show ?case using 4 apply auto
      apply (cases x, auto)
      apply (metis fltrace_concat2.simps(3) pri.simps(1) priacc.simps(1) x_le_x_concat2)
      apply (cases x, auto)
      apply (metis acceptance.distinct(1) eq_iff less_eq_acceptance.elims(2) less_eq_fltrace.simps(2) pri.simps(1))
      apply (cases x, auto)
      apply (metis less_eq_acceptance.simps(1) less_eq_fltrace.simps(2) pri.simps(1) priacc.simps(1))
      by (metis acceptance.distinct(1) less_eq_acceptance.elims(2) less_eq_fltrace.simps(2) order_refl pri.simps(1))
 next
    case (AEvent x z)
    then obtain C where C:"pri p z C \<and> C \<le> zz"
      by auto
    then have x_less_eq_A:"x \<le> A"
      using AEvent by auto
    then have event_x_z:"event(x) = event(Z)"
      by (metis AEvent.prems(3) less_eq_aevent_def pri.simps(4))
    then show ?case using 4 AEvent
       proof (cases "acceptance(A) = \<bullet>")
         case A_bullet:True
         then show ?thesis
           using A_bullet 4 x_less_eq_A event_x_z
           apply (intro exI[where x="Z #\<^sub>\<F>\<^sub>\<L> C"], simp)
           apply (simp add: less_eq_aevent_def C)+
           apply (cases x, auto)
           by (case_tac a, auto)+
       next
         case A_not_bullet:False
         then show ?thesis using 4 AEvent
          proof (cases "acceptance(Z) = \<bullet>")
            case True
            then show ?thesis using 4 A_not_bullet
              apply (intro exI[where x="Z #\<^sub>\<F>\<^sub>\<L> C"], simp)
              apply (simp add: less_eq_aevent_def C)
              by (simp add: eq_iff)
          next
            case False
            then show ?thesis using 4 A_not_bullet event_x_z
              apply (intro exI[where x="Z #\<^sub>\<F>\<^sub>\<L> C"], simp)
              apply (simp add: less_eq_aevent_def C)
              apply (cases x, auto, cases Z, auto)
              by (metis acceptance_set less_eq_aevent_def order.trans x_less_eq_A)+
          qed
       qed
  qed
qed

lemma FL1_prirel:
  assumes "s \<le> t" "pri p t Z" "Z \<in> P" "FL1 P"
  shows "\<exists>Z. pri p s Z \<and> Z \<in> P"
  using assms
  by (meson FL1_def prirel_prirel_for_FL1)

lemma pri_FL1:
  assumes "FL1 P"
  shows "FL1 (Pri p P)"
  using assms unfolding FL1_def Pri_def apply safe
  using FL1_prirel assms by blast

lemma FL1_prirel_prirel:
  assumes "pri p x Z"
    shows "\<exists>Y. pri p x Y \<and> Y \<le> Z"
  using assms
proof (induct p x Z rule:pri.induct)
  case (1 p A Z)
  then show ?case by blast
next
  case (2 p A Z zz)
  then show ?case by auto
next
  case (3 p A aa Z)
  then show ?case by auto
next
  case (4 p A aa Z zz)
  then show ?case by blast
qed

lemma prirel_cons_imp1:
  assumes "pri p (x #\<^sub>\<F>\<^sub>\<L> y) (a #\<^sub>\<F>\<^sub>\<L> b)"
  shows "pri p \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>a,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms by auto

lemma prirel_cons_imp2:
  assumes "pri p (x #\<^sub>\<F>\<^sub>\<L> y) (a #\<^sub>\<F>\<^sub>\<L> b)"
  shows "pri p y b"
  using assms by auto

lemma acceptance_null [intro]:
  assumes "acceptance A \<le> \<bullet>"
  shows "acceptance A = \<bullet>"
  using assms by (cases A, auto, case_tac a, auto)

lemma not_bullet_less_eq_imp [simp]:
  assumes "a \<noteq> \<bullet>"
          "a \<le> x"
    shows "a = x"
  using assms
  apply (cases a, auto)
  apply (cases x, auto)
  by presburger+

lemma prirel_two_acceptances_bullet_not_bullet:
  assumes "acceptance(A) \<noteq> \<bullet>"
  shows "pri p \<langle>A,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>Z,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> = (acceptance(Z) \<noteq> \<bullet> \<and> event A = event Z \<and> acceptance(A) =  [{a. a \<in>\<^sub>\<F>\<^sub>\<L> acceptance(Z) \<and> \<not>(\<exists>b. b\<in>\<^sub>\<F>\<^sub>\<L> acceptance(Z) \<and> a <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>)"
  using assms apply auto
     apply (cases Z, auto, cases A, auto, case_tac a, auto)
  by (cases Z, auto, cases A, auto, case_tac a, auto)

lemma prirelacc_singleton:
  "priacc\<^sub>[\<^sub>p\<^sub>]([{b}]\<^sub>\<F>\<^sub>\<L>) = [{b}]\<^sub>\<F>\<^sub>\<L>"
  by auto

lemma preirelacc_pair_removed:
  assumes "a <\<^sup>*p b" "priacc\<^sub>[\<^sub>p\<^sub>]([X]\<^sub>\<F>\<^sub>\<L>) = [Y]\<^sub>\<F>\<^sub>\<L>" "a \<in> Y" "b \<in> Y"
  shows "a \<notin> X"
  using assms by (auto simp add:my_lt_def)

lemma prirel_same_from_singleton:
  shows "pri p \<langle>([{b}]\<^sub>\<F>\<^sub>\<L>,b)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>([{b}]\<^sub>\<F>\<^sub>\<L>,b)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  by auto

lemma prirel_same:
  assumes "a <\<^sup>*p b" "pri p \<langle>([X]\<^sub>\<F>\<^sub>\<L>,b)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>([Y]\<^sub>\<F>\<^sub>\<L>,b)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>" "b \<in> Y" "b \<in> X"
  shows "a \<notin> X"
  using assms apply auto
  by (metis (mono_tags, lifting) Int_Collect)+

lemma prirel_same_length:
  assumes "pri p fl Y"
  shows "length fl = length Y"
  using assms by (induct fl Y rule:pri.induct, auto)

lemma prirel_rhs_singleton_iff:
  "pri p x \<langle>[{a}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L> = (x = \<langle>[{a}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  by (cases x, auto)

lemma prirel_cons_imp_exists:
  assumes "pri p x (([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)"
  shows "(\<exists>z. (x = ([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z \<or> x = (\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z) \<and> pri p z s)"
  using assms
proof (induct p x s rule:pri.induct)
  case (1 p A Z)
  then show ?case by auto
next
  case (2 p A Z zz)
  then show ?case by auto
next
  case (3 p A aa Z)
  then show ?case
    apply (cases A, cases Z, cases aa, auto)
     apply (rule exI[where x="\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"], auto, case_tac ab, auto, metis)
    by (rule exI[where x="aa"], auto, case_tac ab, auto, metis)
next
  case (4 p A aa Z zz)
  then show ?case
    apply (cases A, cases Z, auto)
    by (metis less_eq_acceptance.elims(2))+
qed

lemma prirel_cons_iff_exists:
  "pri p x (([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)
   =
   (\<exists>z. (x = ([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z \<or> x = (\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z) \<and> pri p z s)"
  apply auto
  using prirel_cons_imp_exists
  by (simp add: prirel_cons_imp_exists)

lemma prirel_cons_bullet_iff_exists:
  "pri p x ((\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)
   =
   (\<exists>z. x = (\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z \<and> maximal(p,a) \<and> pri p z s)"
  apply auto
   apply (cases x, auto)
  by (case_tac x21, auto, case_tac aa, auto)

lemma prirel_less_eq_imp:
  assumes "pri p \<langle>B,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>Z,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>" "A \<le> B"
  shows "pri p \<langle>A,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>Z,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms apply auto
  apply (simp_all add:less_eq_aevent_def)
  by (metis less_eq_acceptance.elims(2))+

lemma prirel_singleton_set_iff:
  "pri p A \<langle>[X]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L> = (A = \<langle>[{a. a \<in> X \<and> \<not>(\<exists>b. b \<in> X \<and> a <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  apply auto
  by (cases A, auto)

lemma prirel_singleton_set_iff_diff:
  "pri p \<langle>[A]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>[X]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L> = (A = X - {a. a \<in> X \<and> (\<exists>b. b \<in> X \<and> a <\<^sup>*p b)})"
  by auto

lemma prirel_singleton_set_iff_diff2:
  "pri p A \<langle>[X]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L> = (A = \<langle>[X - {a. a \<in> X \<and> (\<exists>b. b \<in> X \<and> a <\<^sup>*p b)}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  by (cases A, auto)

lemma not_prirelAlt_less_eq_both_events [simp]:
  assumes "b <\<^sup>*p a" "a \<in> X" "b \<in> X"
  shows "\<not> pri p x (([X]\<^sub>\<F>\<^sub>\<L>,b)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> \<rho>)"
  using assms apply (cases x, auto)
   apply (case_tac x21, auto, case_tac aa, auto)
  by (meson some_higher_not_maximal)+

lemma prirel_cons:
  assumes "b <\<^sup>*p a" "pri p z \<rho>"
  shows "pri p (([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z) (([{b, a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> \<rho>) \<or> pri p ((\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z) (([{b, a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> \<rho>)"
  using assms by auto

lemma prirel_cons_also_prirel:
  assumes "pri p s z"
  shows "pri p ((\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s) (([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z)"
  using assms by auto

lemma prirel_rel_less_eq_twoset:
  assumes "b <\<^sup>*p a" "pri p x (([{b,a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)"
  shows "pri p x (([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)"
  using assms
  apply (cases x, simp)
  apply (case_tac x21, simp, case_tac y, simp, case_tac aa, simp)
  apply safe
   apply simp_all
  by (smt IntD2 Int_insert_left insert_absorb2 insert_is_Un mem_Collect_eq sup_inf_absorb)+

lemma prirel_cons_iff_exists_less_eq_twoset:
  assumes "b <\<^sup>*p a"
  shows "pri p x (([{b,a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> s)
   =
   (\<exists>z. (x = ([{a}]\<^sub>\<F>\<^sub>\<L>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z \<or> x = (\<bullet>,a)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> z) \<and> pri p z s)"
  using assms apply auto
  by (simp add: prirel_cons_imp_exists prirel_rel_less_eq_twoset)

lemma
  assumes "R pri\<^sub>[\<^sub>p\<^sub>] \<langle>[{a}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>" "b <\<^sup>*p a"
  shows "R pri\<^sub>[\<^sub>p\<^sub>] \<langle>[{b, a}]\<^sub>\<F>\<^sub>\<L>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms by (cases R, auto)

lemma prirel_cons_eq_length_imp:
  assumes "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length xs = length ys"
  shows "pri p xs ys"
  using assms apply(induct xs ys rule:pri.induct, auto)
  apply (case_tac A, auto)
  by (case_tac Z, auto)+

lemma prirel_cons_eq_length_imp_prirel_acceptances:
  assumes "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length xs = length ys" "last xs = \<bullet>"
  shows "pri p \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms apply(induct xs ys rule:pri.induct, auto)
  by (case_tac Z, auto)+

lemma prirel_cons_eq_length_imp_prirel_acceptances_last_bullet:
  assumes "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length xs = length ys" "last xs = \<bullet>"
  shows "last ys = \<bullet>"
  using assms apply(induct xs ys rule:pri.induct, auto)
  by (case_tac Z, auto)

lemma prirel_cons_eq_length_imp_prirel_acceptances_last_bullet_eq:
  assumes "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)" "length xs = length ys"
  shows "last xs = \<bullet> \<longleftrightarrow> last ys = \<bullet>"
  using assms apply(induct xs ys rule:pri.induct, auto)
   apply (case_tac Z, auto)
  by (case_tac A, auto)

lemma prirel_cons_eq_length_imp_prirel_acceptances_last_not_bullet:
  assumes "length xs = length ys" "last xs \<noteq> \<bullet>"
  shows "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) = pri p (xs) (ys)"
  using assms apply(induct xs ys rule:pri.induct, auto)
   apply (case_tac A, auto)
  by (case_tac Z, auto)+

lemma prirel_cons_eq_length_imp_prirel_acceptances_eq:
  assumes "length xs = length ys" "last xs = \<bullet>" "last ys = \<bullet>" "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  shows  "pri p (\<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) (\<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms by(induct xs ys rule:pri.induct, auto)

lemma prirel_cons_eq_length_imp_prirel_eq_prefix:
  assumes "length xs = length ys" "last xs = \<bullet>" "last ys = \<bullet>" "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  shows  "pri p xs ys"
  using assms by(induct xs ys rule:pri.induct, auto)

lemma prirel_last_bullets_cons_imp:
  assumes "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) (ys &\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>)" "last xs = \<bullet>" "last ys = \<bullet>"
  shows "(x = \<bullet>) \<or> (\<exists>xA yA. x = [xA]\<^sub>\<F>\<^sub>\<L> \<and> y = [yA]\<^sub>\<F>\<^sub>\<L>)"
  using assms apply (induct p xs ys rule:pri.induct, auto)
  by (cases x, auto, cases y, auto)+

lemma prirelacc_trans:
  assumes "priacc p A = Z" "priacc p Z = Y"
  shows "priacc p A = Y"
  using assms
  by (cases A, auto)

lemma prirel_trans:
  assumes "pri p xs ys" "pri p ys zs"
  shows "pri p xs zs"
  using assms apply (induct p xs zs arbitrary:ys rule:pri.induct, auto)
        apply (metis fltrace.exhaust pri.simps(1) pri.simps(3) prirelacc_trans)
       apply (metis fltrace.exhaust pri.simps(2))
      apply (metis fltrace.exhaust pri.simps(3))
     apply (case_tac ysa, auto)
        apply (metis prirelacc_trans less_eq_acceptance.elims(2) priacc.simps(1))
       apply (metis prirelacc_trans less_eq_acceptance.elims(2) priacc.simps(1))
      apply (metis prirelacc_trans less_eq_acceptance.elims(2) priacc.simps(1))
     apply (metis prirelacc_trans less_eq_acceptance.elims(2) priacc.simps(1))
    apply (metis (mono_tags, hide_lams) fltrace.exhaust pri.simps(3) pri.simps(4))
   apply (case_tac ysa, auto)
  by (metis fltrace.exhaust pri.simps(2) pri.simps(4))

lemma
  assumes "pri p x Z" "pri p Z Za" "Za \<in> P"
  shows "\<exists>Z. pri p x Z \<and> Z \<in> P"
  using assms(1) assms(2) assms(3) prirel_trans by blast

lemma prirel_extend_both_acceptance:
  assumes "pri p xs zs" "pri p \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>"
  shows "pri p (xs &\<^sub>\<F>\<^sub>\<L> \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>) (zs &\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  using assms
  apply (induct p xs zs rule:pri.induct, auto)
  by (cases y, auto, case_tac Z, auto)

lemma prirelacc_decompose:
  assumes "priacc p xs = ys"
  shows "\<exists>Z. priacc p xs = Z \<and> priacc p Z = ys"
  using assms by(induct p xs rule:priacc.induct, auto)

lemma priacc_less_eq_some_pri:
  assumes "(A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] Z"
  shows "acceptance A \<le> priacc\<^sub>[\<^sub>p\<^sub>] (acceptance A)"
  using assms
  apply (cases A, auto, cases Z, auto)
  by (metis Finite_Linear_Pri.prirelacc_trans amember.simps(1) not_bullet_less_eq_imp)+

lemma pri_prefix_consFL:
  assumes "\<rho> pri\<^sub>[\<^sub>p\<^sub>] \<sigma>" "(A #\<^sub>\<F>\<^sub>\<L> \<sigma>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<tau>)" "acceptance Z = \<bullet>"
  shows "(A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] (A #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
  using assms apply (cases Z, auto)
  apply (cases A, auto)
  by (case_tac a, auto)

lemma pri_prefix_consFL':
  assumes "(A #\<^sub>\<F>\<^sub>\<L> \<sigma>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<tau>)"
  shows "((priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> \<sigma>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<tau>)"
proof -
  have "event Z \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z) \<or> acceptance Z = \<bullet>"
    using assms
    apply (simp_all add: maximal_iff)
    by (cases Z, auto)
  then show ?thesis
    using assms by (cases Z, auto)
qed

lemma pri_prefix_consFL'':
  assumes "\<rho> pri\<^sub>[\<^sub>p\<^sub>] \<tau>" "(A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
  shows "(A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] ((priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> \<tau>)"
 proof -
  have "event Z \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z) \<or> acceptance Z = \<bullet>"
    using assms
    apply (simp_all add: maximal_iff)
    by (cases Z, auto)
  then have "acceptance (priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> = priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z)"
    by auto
  then have "((A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>))
            =
            (acceptance A \<le> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z)
             \<and> (pri p \<rho> \<sigma>) \<and> event(A) = event(Z) \<and>
               (\<not> maximal(p,event(A)) \<longrightarrow> event(Z) \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z)))"
    by simp
  then show ?thesis
    by (metis Finite_Linear_Pri.prirelacc_trans \<open>acceptance (priacc\<^sub>[\<^sub>p\<^sub>] acceptance Z,event Z)\<^sub>\<F>\<^sub>\<L> = priacc\<^sub>[\<^sub>p\<^sub>] acceptance Z\<close> \<open>event Z \<in>\<^sub>\<F>\<^sub>\<L> priacc\<^sub>[\<^sub>p\<^sub>] acceptance Z \<or> acceptance Z = \<bullet>\<close> acceptance_event assms(1) assms(2) pri.simps(4) priacc.simps(1))
qed

lemma prirel_decompose:
  assumes "pri p xs ys"
  shows "\<exists>Z. pri p xs Z \<and> pri p Z ys"
  using assms
proof(induct p xs ys rule:pri.induct)
  case (1 p A Z)
  then show ?case
    by (metis pri.simps(1) prirelacc_trans)
next
  case (2 p A Z \<sigma>)
  then show ?case
    by (cases A, auto)
next
  case (3 p A \<rho> Z)
  then show ?case
    by (cases A, auto)
next
  case (4 p A \<rho> Z \<sigma>)
  then have "\<rho> pri\<^sub>[\<^sub>p\<^sub>] \<sigma>"
            "(A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
            "\<exists>Z. \<rho> pri\<^sub>[\<^sub>p\<^sub>] Z \<and> Z pri\<^sub>[\<^sub>p\<^sub>] \<sigma>"
    by auto
  then have hyp:"\<exists>Za. \<rho> pri\<^sub>[\<^sub>p\<^sub>] Za \<and> (A #\<^sub>\<F>\<^sub>\<L> Za) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
    using 4 by auto
  then have hyp2:"\<exists>Za. \<rho> pri\<^sub>[\<^sub>p\<^sub>] Za \<and> ((priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> Za) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
    using pri_prefix_consFL' hyp by blast
  then have "\<exists>Za. (A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] ((priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> Za)
                    \<and> ((priacc\<^sub>[\<^sub>p\<^sub>](acceptance Z),event Z)\<^sub>\<F>\<^sub>\<L> #\<^sub>\<F>\<^sub>\<L> Za) pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
    using pri_prefix_consFL'' "4.prems" by blast
  then have "\<exists>Za. (A #\<^sub>\<F>\<^sub>\<L> \<rho>) pri\<^sub>[\<^sub>p\<^sub>] Za \<and> Za pri\<^sub>[\<^sub>p\<^sub>] (Z #\<^sub>\<F>\<^sub>\<L> \<sigma>)"
    by blast
  then show ?case
    by blast
qed

lemma
  assumes "pri p xs ys" "ys \<in> P" "FL1 P"
  shows "\<exists>Z. pri p xs Z \<and> (\<exists>Za. pri p Z Za \<and> Za \<in> P)"
  using assms prirel_decompose by blast

end


theory Bipartite_Vertex_Weighted_Matching_LP
  imports Bipartite_Matching_LP
begin

locale bipartite_vertex_weighted_matching_lp = bipartite_matching_lp +
  fixes v :: "'a \<Rightarrow> real"
  assumes weights_pos: "i \<in> L \<Longrightarrow> 0 < v i"
begin

abbreviation "matching_value M \<equiv> \<Sum>e\<in>M. v (THE l. l \<in> L \<and> l \<in> e)"

definition "max_value_matching M \<longleftrightarrow> M \<subseteq> G \<and> matching M \<and>
  (\<forall>M'. M' \<subseteq> G \<and> matching M' \<longrightarrow> matching_value M' \<le> matching_value M)"

abbreviation vertex_weighted_coeffs :: "real vec" where
  "vertex_weighted_coeffs \<equiv> vec m (\<lambda>i. v (THE l. l \<in> L \<and> l \<in> from_nat_into G i))"

lemma max_value_matchingD:
  assumes "max_value_matching M"
  shows "M \<subseteq> G" "matching M"
  using assms
  unfolding max_value_matching_def
  by auto

lemma value_pos:
  "e \<in> G \<Longrightarrow> 0 < v (THE l. l \<in> L \<and> l \<in> e)"
  by (auto elim: the_lE intro: weights_pos)

lemma max_value_matching_non_empty:
  assumes "max_value_matching M"
  assumes "G \<noteq> {}"
  shows "M \<noteq> {}"
proof (rule ccontr, simp)
  assume "M = {}"

  then have M_zero: "matching_value M = 0"
    by auto

  from assms obtain e where "e \<in> G"
    by blast

  with bipartite_graph obtain l r where lr: "e = {l,r}" "l \<in> L" "r \<in> R"
    by (auto elim: bipartite_edgeE)

  from \<open>e \<in> G\<close> have e: "matching {e}" "{e} \<subseteq> G"
    unfolding matching_def
    by blast+

  with lr have the_l: "(THE l. l \<in> L \<and> l \<in> e) = l"
    by auto

  with \<open>l \<in> L\<close> have "0 < matching_value {e}"
    by (auto dest: weights_pos)

  with M_zero e \<open>max_value_matching M\<close> show False
    unfolding max_value_matching_def
    by auto
qed

lemma non_empty_matching_value_pos:
  assumes "M \<subseteq> G"
  assumes "M \<noteq> {}"
  shows "0 < matching_value M"
  using assms
  by (auto intro!: sum_pos intro: finite_subset value_pos)

lemma primal_dot_coeffs_eq_value:
  assumes "M \<subseteq> G"
  shows "vertex_weighted_coeffs \<bullet> primal_sol M = matching_value M"
  unfolding scalar_prod_def primal_sol_def
  using assms
  by (auto intro!: sum.reindex_bij_witness[where j = "from_nat_into G" and i = "to_nat_on G"]
           intro: to_nat_on_from_nat_into_less simp: to_nat_on_less_card countable_finite)

lemma matching_value_bound_by_feasible_dual:
  fixes y :: "real vec"
  assumes "M \<subseteq> G"
  assumes "matching M"

  assumes "incidence_matrix\<^sup>T *\<^sub>v y \<ge> vertex_weighted_coeffs"
  assumes "y \<ge> 0\<^sub>v n"

  shows "matching_value M \<le> 1\<^sub>v n \<bullet> y"
proof -
  from \<open>M \<subseteq> G\<close> have "matching_value M = vertex_weighted_coeffs \<bullet> primal_sol M"
    by (auto simp: primal_dot_coeffs_eq_value)

  also from assms have "\<dots> \<le> 1\<^sub>v n \<bullet> y"
    by (auto intro: weak_duality_theorem_nonneg_primal[where A = incidence_matrix] matching_feasible)

  finally show ?thesis .
qed

lemma max_value_matching_bound_by_feasible_dual:
  fixes y :: "real vec"
  assumes "max_value_matching M"

  assumes "incidence_matrix\<^sup>T *\<^sub>v y \<ge> vertex_weighted_coeffs"
  assumes "y \<ge> 0\<^sub>v n"

  shows "matching_value M \<le> 1\<^sub>v n \<bullet> y"
  using assms
  by (auto intro: matching_value_bound_by_feasible_dual dest: max_value_matchingD)

end

end


(*  Title:      HOL/Bali/Basis.thy
    Author:     David von Oheimb
*)
subsection \<open>Definitions extending HOL as logical basis of Bali\<close>

theory Basis
imports MainRLT
begin

subsubsection "misc"

ML \<open>fun strip_tac ctxt i = REPEAT (resolve_tac ctxt [impI, allI] i)\<close>

declare if_split_asm  [split] option.split [split] option.split_asm [split]
setup \<open>map_theory_simpset (fn ctxt => ctxt addloop ("split_all_tac", split_all_tac))\<close>
declare if_weak_cong [cong del] option.case_cong_weak [cong del]
declare length_Suc_conv [iff]

lemma Collect_split_eq: "{p. P (case_prod f p)} = {(a,b). P (f a b)}"
  by auto

lemma subset_insertD: "A \<subseteq> insert x B \<Longrightarrow> A \<subseteq> B \<and> x \<notin> A \<or> (\<exists>B'. A = insert x B' \<and> B' \<subseteq> B)"
  apply (case_tac "x \<in> A")
   apply (rule disjI2)
   apply (rule_tac x = "A - {x}" in exI)
   apply fast+
  done

abbreviation nat3 :: nat  ("3") where "3 \<equiv> Suc 2"
abbreviation nat4 :: nat  ("4") where "4 \<equiv> Suc 3"

(* irrefl_tranclI in Transitive_Closure.thy is more general *)
lemma irrefl_tranclI': "r\<inverse> \<inter> r\<^sup>+ = {} \<Longrightarrow> \<forall>x. (x, x) \<notin> r\<^sup>+"
  by (blast elim: tranclE dest: trancl_into_rtrancl)

lemma trancl_rtrancl_trancl: "\<lbrakk>(x, y) \<in> r\<^sup>+; (y, z) \<in> r\<^sup>*\<rbrakk> \<Longrightarrow> (x, z) \<in> r\<^sup>+"
  by (auto dest: tranclD rtrancl_trans rtrancl_into_trancl2)

lemma rtrancl_into_trancl3: "\<lbrakk>(a, b) \<in> r\<^sup>*; a \<noteq> b\<rbrakk> \<Longrightarrow> (a, b) \<in> r\<^sup>+"
  apply (drule rtranclD)
  apply auto
  done

lemma rtrancl_into_rtrancl2: "\<lbrakk>(a, b) \<in>  r; (b, c) \<in> r\<^sup>*\<rbrakk> \<Longrightarrow> (a, c) \<in> r\<^sup>*"
  by (auto intro: rtrancl_trans)

lemma triangle_lemma:
  assumes unique: "\<And>a b c. \<lbrakk>(a,b)\<in>r; (a,c)\<in>r\<rbrakk> \<Longrightarrow> b = c"
    and ax: "(a,x)\<in>r\<^sup>*" and ay: "(a,y)\<in>r\<^sup>*"
  shows "(x,y)\<in>r\<^sup>* \<or> (y,x)\<in>r\<^sup>*"
  using ax ay
proof (induct rule: converse_rtrancl_induct)
  assume "(x,y)\<in>r\<^sup>*"
  then show ?thesis by blast
next
  fix a v
  assume a_v_r: "(a, v) \<in> r"
    and v_x_rt: "(v, x) \<in> r\<^sup>*"
    and a_y_rt: "(a, y) \<in> r\<^sup>*"
    and hyp: "(v, y) \<in> r\<^sup>* \<Longrightarrow> (x, y) \<in> r\<^sup>* \<or> (y, x) \<in> r\<^sup>*"
  from a_y_rt show "(x, y) \<in> r\<^sup>* \<or> (y, x) \<in> r\<^sup>*"
  proof (cases rule: converse_rtranclE)
    assume "a = y"
    with a_v_r v_x_rt have "(y,x) \<in> r\<^sup>*"
      by (auto intro: rtrancl_trans)
    then show ?thesis by blast
  next
    fix w
    assume a_w_r: "(a, w) \<in> r"
      and w_y_rt: "(w, y) \<in> r\<^sup>*"
    from a_v_r a_w_r unique have "v=w" by auto
    with w_y_rt hyp show ?thesis by blast
  qed
qed

lemma rtrancl_cases:
  assumes "(a,b)\<in>r\<^sup>*"
  obtains (Refl) "a = b"
    | (Trancl) "(a,b)\<in>r\<^sup>+"
  apply (rule rtranclE [OF assms])
   apply (auto dest: rtrancl_into_trancl1)
  done

lemma Ball_weaken: "\<lbrakk>Ball s P; \<And> x. P x\<longrightarrow>Q x\<rbrakk>\<Longrightarrow>Ball s Q"
  by auto

lemma finite_SetCompr2:
  "finite {f y x |x y. P y}" if "finite (Collect P)"
    "\<forall>y. P y \<longrightarrow> finite (range (f y))"
proof -
  have "{f y x |x y. P y} = (\<Union>y\<in>Collect P. range (f y))"
    by auto
  with that show ?thesis by simp
qed

lemma list_all2_trans: "\<forall>a b c. P1 a b \<longrightarrow> P2 b c \<longrightarrow> P3 a c \<Longrightarrow>
    \<forall>xs2 xs3. list_all2 P1 xs1 xs2 \<longrightarrow> list_all2 P2 xs2 xs3 \<longrightarrow> list_all2 P3 xs1 xs3"
  apply (induct_tac xs1)
   apply simp
  apply (rule allI)
  apply (induct_tac xs2)
   apply simp
  apply (rule allI)
  apply (induct_tac xs3)
   apply auto
  done

subsubsection "pairs"

lemma surjective_pairing5:
  "p = (fst p, fst (snd p), fst (snd (snd p)), fst (snd (snd (snd p))),
    snd (snd (snd (snd p))))"
  by auto

lemma fst_splitE [elim!]:
  assumes "fst s' = x'"
  obtains x s where "s' = (x,s)" and "x = x'"
  using assms by (cases s') auto

lemma fst_in_set_lemma: "(x, y) \<in> set l \<Longrightarrow> x \<in> fst ` set l"
  by (induct l) auto

subsubsection "quantifiers"

lemma All_Ex_refl_eq2 [simp]: "(\<forall>x. (\<exists>b. x = f b \<and> Q b) \<longrightarrow> P x) = (\<forall>b. Q b \<longrightarrow> P (f b))"
  by auto

lemma ex_ex_miniscope1 [simp]: "(\<exists>w v. P w v \<and> Q v) = (\<exists>v. (\<exists>w. P w v) \<and> Q v)"
  by auto

lemma ex_miniscope2 [simp]: "(\<exists>v. P v \<and> Q \<and> R v) = (Q \<and> (\<exists>v. P v \<and> R v))"
  by auto

lemma ex_reorder31: "(\<exists>z x y. P x y z) = (\<exists>x y z. P x y z)"
  by auto

lemma All_Ex_refl_eq1 [simp]: "(\<forall>x. (\<exists>b. x = f b) \<longrightarrow> P x) = (\<forall>b. P (f b))"
  by auto

subsubsection "sums"

notation case_sum  (infixr "'(+')" 80)

primrec the_Inl :: "'a + 'b \<Rightarrow> 'a"
  where "the_Inl (Inl a) = a"

primrec the_Inr :: "'a + 'b \<Rightarrow> 'b"
  where "the_Inr (Inr b) = b"

datatype ('a, 'b, 'c) sum3 = In1 'a | In2 'b | In3 'c

primrec the_In1 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'a"
  where "the_In1 (In1 a) = a"

primrec the_In2 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'b"
  where "the_In2 (In2 b) = b"

primrec the_In3 :: "('a, 'b, 'c) sum3 \<Rightarrow> 'c"
  where "the_In3 (In3 c) = c"

abbreviation In1l :: "'al \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
  where "In1l e \<equiv> In1 (Inl e)"

abbreviation In1r :: "'ar \<Rightarrow> ('al + 'ar, 'b, 'c) sum3"
  where "In1r c \<equiv> In1 (Inr c)"

abbreviation the_In1l :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'al"
  where "the_In1l \<equiv> the_Inl \<circ> the_In1"

abbreviation the_In1r :: "('al + 'ar, 'b, 'c) sum3 \<Rightarrow> 'ar"
  where "the_In1r \<equiv> the_Inr \<circ> the_In1"

ML \<open>
fun sum3_instantiate ctxt thm =
  map (fn s =>
    simplify (ctxt delsimps @{thms not_None_eq})
      (Rule_Insts.read_instantiate ctxt [((("t", 0), Position.none), "In" ^ s ^ " x")] ["x"] thm))
    ["1l","2","3","1r"]
\<close>
(* e.g. lemmas is_stmt_rews = is_stmt_def [of "In1l x", simplified] *)

subsubsection "quantifiers for option type"

syntax
  "_Oall" :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3! _:_:/ _)" [0,0,10] 10)
  "_Oex"  :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3? _:_:/ _)" [0,0,10] 10)

syntax (symbols)
  "_Oall" :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3\<forall>_\<in>_:/ _)"  [0,0,10] 10)
  "_Oex"  :: "[pttrn, 'a option, bool] \<Rightarrow> bool"   ("(3\<exists>_\<in>_:/ _)"  [0,0,10] 10)

translations
  "\<forall>x\<in>A: P" \<rightleftharpoons> "\<forall>x\<in>CONST set_option A. P"
  "\<exists>x\<in>A: P" \<rightleftharpoons> "\<exists>x\<in>CONST set_option A. P"

subsubsection "Special map update"

text\<open>Deemed too special for theory Map.\<close>

definition chg_map :: "('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"
  where "chg_map f a m = (case m a of None \<Rightarrow> m | Some b \<Rightarrow> m(a\<mapsto>f b))"

lemma chg_map_new[simp]: "m a = None \<Longrightarrow> chg_map f a m = m"
  unfolding chg_map_def by auto

lemma chg_map_upd[simp]: "m a = Some b \<Longrightarrow> chg_map f a m = m(a\<mapsto>f b)"
  unfolding chg_map_def by auto

lemma chg_map_other [simp]: "a \<noteq> b \<Longrightarrow> chg_map f a m b = m b"
  by (auto simp: chg_map_def)

subsubsection "unique association lists"

definition unique :: "('a \<times> 'b) list \<Rightarrow> bool"
  where "unique = distinct \<circ> map fst"

lemma uniqueD: "unique l \<Longrightarrow> (x, y) \<in> set l \<Longrightarrow> (x', y') \<in> set l \<Longrightarrow> x = x' \<Longrightarrow> y = y'"
  unfolding unique_def o_def
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_Nil [simp]: "unique []"
  by (simp add: unique_def)

lemma unique_Cons [simp]: "unique ((x,y)#l) = (unique l \<and> (\<forall>y. (x,y) \<notin> set l))"
  by (auto simp: unique_def dest: fst_in_set_lemma)

lemma unique_ConsD: "unique (x#xs) \<Longrightarrow> unique xs"
  by (simp add: unique_def)

lemma unique_single [simp]: "\<And>p. unique [p]"
  by simp

lemma unique_append [rule_format (no_asm)]: "unique l' \<Longrightarrow> unique l \<Longrightarrow>
    (\<forall>(x,y)\<in>set l. \<forall>(x',y')\<in>set l'. x' \<noteq> x) \<longrightarrow> unique (l @ l')"
  by (induct l) (auto dest: fst_in_set_lemma)

lemma unique_map_inj: "unique l \<Longrightarrow> inj f \<Longrightarrow> unique (map (\<lambda>(k,x). (f k, g k x)) l)"
  by (induct l) (auto dest: fst_in_set_lemma simp add: inj_eq)

lemma map_of_SomeI: "unique l \<Longrightarrow> (k, x) \<in> set l \<Longrightarrow> map_of l k = Some x"
  by (induct l) auto

subsubsection "list patterns"

definition lsplit :: "[['a, 'a list] \<Rightarrow> 'b, 'a list] \<Rightarrow> 'b"
  where "lsplit = (\<lambda>f l. f (hd l) (tl l))"

text \<open>list patterns -- extends pre-defined type "pttrn" used in abstractions\<close>
syntax
  "_lpttrn" :: "[pttrn, pttrn] \<Rightarrow> pttrn"    ("_#/_" [901,900] 900)
translations
  "\<lambda>y # x # xs. b" \<rightleftharpoons> "CONST lsplit (\<lambda>y x # xs. b)"
  "\<lambda>x # xs. b" \<rightleftharpoons> "CONST lsplit (\<lambda>x xs. b)"

lemma lsplit [simp]: "lsplit c (x#xs) = c x xs"
  by (simp add: lsplit_def)

lemma lsplit2 [simp]: "lsplit P (x#xs) y z = P x xs y z"
  by (simp add: lsplit_def)

end


theory SINVAR_Dependability_impl
imports SINVAR_Dependability "../TopoS_Interface_impl"
begin

code_identifier code_module SINVAR_Dependability_impl => (Scala) SINVAR_Dependability

subsubsection \<open>SecurityInvariant Dependability List Implementation\<close>

text \<open>Less-equal other nodes depend on the output of a node than its dependability level.\<close>
fun sinvar :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> set (edgesL G). (num_reachable G e1) \<le> (nP e1))"

value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 3)"
value "sinvar
    \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
    (\<lambda>e. 2)"

text\<open>Generate a valid configuration to start from:\<close>
   fun dependability_fix_nP :: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "dependability_fix_nP G nP = (\<lambda>v. let nr = num_reachable G v in (if nr \<le> (nP v) then (nP v) else nr))"

   theorem dependability_fix_nP_impl_correct: "wf_list_graph G \<Longrightarrow> dependability_fix_nP G nP  = SINVAR_Dependability.dependability_fix_nP (list_graph_to_graph G) nP"
   by(simp add: num_reachable_correct fun_eq_iff)

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1), (2,1), (3,1), (4,1), (1,2), (1,3)] \<rparr> in (let nP = dependability_fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

   value "let G = \<lparr> nodesL = [1::nat,2,3,4], edgesL = [(1,1)] \<rparr> in (let nP = dependability_fix_nP G (\<lambda>e. 0) in map (\<lambda>v. nP v) (nodesL G))"

definition Dependability_offending_list:: "'v list_graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<times> 'v) list list" where
  "Dependability_offending_list = Generic_offending_list sinvar"

definition "NetModel_node_props P = (\<lambda> i. (case (node_properties P) i of Some property \<Rightarrow> property | None \<Rightarrow> SINVAR_Dependability.default_node_properties))"

definition "Dependability_eval G P = (wf_list_graph G \<and>
  sinvar G (SecurityInvariant.node_props SINVAR_Dependability.default_node_properties P))"

lemma sinvar_correct: "wf_list_graph G \<Longrightarrow> SINVAR_Dependability.sinvar (list_graph_to_graph G) nP = sinvar G nP"
   apply(simp)
   apply(rule all_edges_list_I)
   apply(simp add: fun_eq_iff)
   apply(clarify)
   apply(rename_tac x)
   apply(drule_tac v="x" in  num_reachable_correct)
  apply presburger
done

interpretation Dependability_impl:TopoS_List_Impl
  where default_node_properties=SINVAR_Dependability.default_node_properties
  and sinvar_spec=SINVAR_Dependability.sinvar
  and sinvar_impl=sinvar
  and receiver_violation=SINVAR_Dependability.receiver_violation
  and offending_flows_impl=Dependability_offending_list
  and node_props_impl=NetModel_node_props
  and eval_impl=Dependability_eval
 apply(unfold TopoS_List_Impl_def)
 apply(rule conjI)
  apply(rule conjI)
   apply(simp add: TopoS_Dependability; fail)
  apply(intro allI impI)
  apply(fact sinvar_correct)
 apply(rule conjI)
  apply(unfold Dependability_offending_list_def)
  apply(intro allI impI)
  apply(rule Generic_offending_list_correct)
   apply(assumption)
  apply(simp only: sinvar_correct)
 apply(rule conjI)
  apply(intro allI)
  apply(simp only: NetModel_node_props_def)
  apply(metis Dependability.node_props.simps Dependability.node_props_eq_node_props_formaldef)
 apply(simp only: Dependability_eval_def)
 apply(intro allI impI)
 apply(rule TopoS_eval_impl_proofrule[OF TopoS_Dependability])
 apply(simp only: sinvar_correct)
done

subsubsection \<open>Dependability packing\<close>
  definition SINVAR_LIB_Dependability :: "('v::vertex, SINVAR_Dependability.dependability_level) TopoS_packed" where
    "SINVAR_LIB_Dependability \<equiv>
    \<lparr> nm_name = ''Dependability'',
      nm_receiver_violation = SINVAR_Dependability.receiver_violation,
      nm_default = SINVAR_Dependability.default_node_properties,
      nm_sinvar = sinvar,
      nm_offending_flows = Dependability_offending_list,
      nm_node_props = NetModel_node_props,
      nm_eval = Dependability_eval
      \<rparr>"
  interpretation SINVAR_LIB_Dependability_interpretation: TopoS_modelLibrary SINVAR_LIB_Dependability
      SINVAR_Dependability.sinvar
    apply(unfold TopoS_modelLibrary_def SINVAR_LIB_Dependability_def)
    apply(rule conjI)
     apply(simp)
    apply(simp)
    by(unfold_locales)

text \<open>Example:\<close>
  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=3, 2:=2, 3:=1, 4:=0, 8:=2, 9:=2, 10:=0))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. SINVAR_Dependability.default_node_properties)(1:=10, 2:=10, 3:=10, 4:=10, 8:=10, 9:=10, 10:=10))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in sinvar G  ((\<lambda> n. 2))"

  value "let G = \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr>
      in Dependability_eval G  \<lparr>node_properties=[1\<mapsto>3, 2\<mapsto>2, 3\<mapsto>1, 4\<mapsto>0, 8\<mapsto>2, 9\<mapsto>2, 10\<mapsto>0] \<rparr>"

  value "Dependability_offending_list \<lparr> nodesL = [1::nat,2,3,4,8,9,10], edgesL = [(1,2), (2,3), (3,4), (8,9),(9,8)] \<rparr> (\<lambda> n. 2)"

hide_fact (open) sinvar_correct
hide_const (open) sinvar NetModel_node_props

end