theory Assign
  imports Main
begin

subsection \<open> preparation \<close>

consts order :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infixr "\<sqsubseteq>" 60)

type_synonym 'a proc = "('a \<times> 'a) list"
consts uskip :: "'a proc" ("II")
consts uzero :: "'a proc" ("\<bottom>")

lemma "[x,y,z]@[u] = [x,y,z,u]"  by simp
lemma "set [a,b,c,a] = {a,b,c,a}"  by simp
lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]"  by simp
lemma "map f [a,b] = [f a,f b]"  by simp
lemma "fst (a,b) = a" by simp

subsection \<open>assignment operater \<close>

class assi =
  fixes assi :: "'a list\<Rightarrow> 'a list\<Rightarrow> 'a proc"  (infixl ":=" 65)
  assumes assi_equal: "set (zip X A) = set(zip Y B) \<Longrightarrow> X := A = Y:=B"
      and assi_orde1: "set (zip X A) \<subseteq> set(zip Y B) \<Longrightarrow> X := A \<sqsubseteq> Y:=B"
      and assi_orde2: "X := A \<sqsubseteq> Y:=B \<Longrightarrow> set (zip X A) \<subseteq> set(zip Y B)"
      and assi_uskip: "set (zip u u) = {}"
  assumes assi_setadd: "Z = X @ Y \<Longrightarrow> c= A @ B \<Longrightarrow>set (zip Z C) = set (zip X A) \<union> set(zip Y B) "

lemma l1:" [x,y,z] := [a,b,c] = [x,y,z,u] := [a,b,c,u]"
  by (metis append.right_neutral assi_equal assi_setadd assi_uskip)

lemma l2:  "[x,y,z,w] := [a,b,c,d] = [x,y,w,z] := [a,b,d,c]"
proof -
  have f1: "set (zip [x,y,w,z] [a,b,d,c]) = set (zip [x,y,z,w] [a,b,c,d])"
    by (simp add: insert_commute)
  show ?thesis
    using assi_equal f1 by blast
qed

lemma l4: "[x,y,z] := [a,b,c] \<sqsubseteq> [x,y,z,w] := [a,b,c,d]"
  by (simp add: assi_orde1)

class serial =  assi +
  fixes nep :: "'a proc \<Rightarrow>'a proc \<Rightarrow>'a proc" (infixl ";;" 60)
  assumes serial_assoc : "(x ;; y) ;; z = x ;; (y ;; z)"
      and serial_skip_left : "II ;; x = x"
      and serial_skip_right : "x ;; II = x"
  assumes assi_serial_map : "X:=A ;; X:=map f X = X:=map f A"

lemma l3: "[x,y]:=[a,b] ;; [x,y]:= [f x,f y] = [x,y]:=[f a,f b]"
  by (metis (mono_tags, hide_lams) assi_serial_map insert_Nil list.simps(8) list.simps(9))

end


theory prop_22
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun max2 :: "Nat => Nat => Nat" where
    (*"max2 Z Z = Z"*)
    "max2 (Z) ( y) = y"
  | "max2 (S z) (Z) = S z"
  | "max2 (S z) (S x2) = S (max2 z x2)"
  (*hipster max2 *)
thm max2.induct
(*
lemma lemma_a [thy_expl]: "max2 x x = x"
by (hipster_induct_schemes max2.simps)

lemma lemma_aa [thy_expl]: "max2 x Z = x"
by (hipster_induct_schemes max2.simps)

lemma lemma_ab [thy_expl]: "max2 x (max2 x y) = max2 x y"
by (hipster_induct_schemes max2.simps)

lemma lemma_ac [thy_expl]: "max2 x (max2 y x) = max2 y x"
by (hipster_induct_schemes max2.simps)

lemma lemma_ad [thy_expl]: "max2 (max2 x y) x = max2 x y"
by (hipster_induct_schemes max2.simps)

lemma lemma_ae []: "max2 (S x) y = max2 y (S x)"
by (hipster_induct_schemes max2.simps)

lemma lemma_af []: "max2 x y = max2 y x"
by (hipster_induct_schemes max2.simps)
*)
lemma lemma_a []: "max2 x2 y2 = max2 y2 x2"
by (hipster_induct_schemes max2.simps Nat.exhaust)

lemma lemma_aa [thy_expl]: "max2 x2 x2 = x2"
by (hipster_induct_schemes max2.simps)

lemma lemma_ab [thy_expl]: "max2 x2 Z = x2"
by (hipster_induct_schemes max2.simps)

lemma lemma_ac [thy_expl]: "max2 x1 (max2 x1 y1) = max2 x1 y1"
by (hipster_induct_schemes max2.simps)

lemma lemma_ad [thy_expl]: "max2 x2 (S x2) = S x2"
by (hipster_induct_schemes max2.simps)

lemma lemma_ae [thy_expl]: "max2 (max2 x1 y1) (S x1) = max2 y1 (S x1)"
by (hipster_induct_schemes max2.simps)

(*
lemma dd :"max2 (S x) x = S x"
by hipster_induct_simp_metis

lemma triv_a []: "max2 (max2 x y) y = max2 x y"
by (tactic {* Tactic_Data.routine_tac @{context}*})
*)
(*
lemma ax:"max2 (max2 x y) (max2 y z) = max2 x (max2 y z)"
apply(induction y z rule: max2.induct)
apply(simp_all add: lemma_aa lemma_ad triv_a)

apply (simp_all add:lemma_aa lemma_a lemma_ab lemma_ac lemma_ad dd triv_a)
lemma aa: "max2 (max2 a b) c = max2 a (max2 b c) \<Longrightarrow> max2 (max2 a b) (S c) = max2 a (max2 b (S c))"
apply hipster_induct_schemes*)

setup\<open>Hip_Tac_Ops.set_metis_to @{context} 15000\<close>
setup\<open>Hip_Tac_Ops.set_metis_filter @{context} (K false)\<close>

  theorem x0 :
    "(max2 (max2 a b) c) = (max2 a (max2 b c))"
    by (hipster_induct_schemes max2.simps Nat.exhaust)

    apply(induction a b arbitrary: c rule: max2.induct)
    apply(simp_all)
    by (metis  max2.simps Nat.exhaust)

    (*
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})*)
end


theory Suc_Theory
  imports Main "HOL-Library.Adhoc_Overloading" Fresh_Identifiers.Fresh
begin

chapter \<open>Solver for the Theory of the Successor Function\<close>
text \<open>
  This theory implements a solver for the theory consisting of
  variables, 0, and the successor function.
  We only deal with equality and not with disequality or inequality.
  Disequalities of the form \<^term>\<open>l \<noteq> 0\<close> are translated to
  \<^term>\<open>l = Suc x\<close> for some fresh \<^term>\<open>x\<close>.

  Note that disequalities and inequalities can always be fulfilled
  by choosing large enough values for the variables.
\<close>

datatype 'a suc_term = Var 'a | Zero | Succ nat "'a suc_term"

datatype 'a suc_atom = is_Eq: Eq "'a suc_term" "'a suc_term" | is_NEq: NEq "'a suc_term" "'a suc_term"

lemma finite_set_suc_term[simp]: "finite (set_suc_term t)"
  by (induction t) auto

lemma finite_set_suc_atom[simp]: "finite (set_suc_atom a)"
  by (cases a) auto

fun succ :: "nat \<Rightarrow> 'a suc_term \<Rightarrow> 'a suc_term" where
  "succ n (Succ k t) = succ (n + k) t"
| "succ 0 t = t"
| "succ n t = Succ n t"

fun is_Succ_normal_term :: "'a suc_term \<Rightarrow> bool" where
  "is_Succ_normal_term (Var _) \<longleftrightarrow> True"
| "is_Succ_normal_term Zero \<longleftrightarrow> True"
| "is_Succ_normal_term (Succ n Zero) \<longleftrightarrow> n \<noteq> 0"
| "is_Succ_normal_term (Succ n (Var _)) \<longleftrightarrow> n \<noteq> 0"
| "is_Succ_normal_term (Succ _ (Succ _ _)) \<longleftrightarrow> False"

lemma not_is_Succ_normal_Succ_0[simp]: "\<not> is_Succ_normal_term (Succ 0 t)"
  by (cases t) auto

lemma is_Succ_normal_term_SuccD[simp]: "is_Succ_normal_term (Succ n t) \<Longrightarrow> is_Succ_normal_term t"
  by (cases t) auto

fun is_Succ_normal_atom :: "'a suc_atom \<Rightarrow> bool" where
  "is_Succ_normal_atom (Eq t1 t2) \<longleftrightarrow> is_Succ_normal_term t1 \<and> is_Succ_normal_term t2"
| "is_Succ_normal_atom (NEq t1 t2) \<longleftrightarrow> is_Succ_normal_term t1 \<and> is_Succ_normal_term t2"

consts is_Succ_normal :: "'a \<Rightarrow> bool"
adhoc_overloading is_Succ_normal is_Succ_normal_term is_Succ_normal_atom

fun I_term :: "('a \<Rightarrow> nat) \<Rightarrow> 'a suc_term \<Rightarrow> nat" where
  "I_term v (Var x) = v x"
| "I_term v Zero = 0"
| "I_term v (Succ n t) = (Suc ^^ n) (I_term v t)"

fun I_atom :: "('a \<Rightarrow> nat) \<Rightarrow> 'a suc_atom \<Rightarrow> bool" where
  "I_atom v (Eq t1 t2) \<longleftrightarrow> I_term v t1 = I_term v t2"
| "I_atom v (NEq t1 t2) \<longleftrightarrow> I_term v t1 \<noteq> I_term v t2"

fun subst_term :: "('a \<Rightarrow> 'a suc_term) \<Rightarrow> 'a suc_term \<Rightarrow> 'a suc_term" where
  "subst_term \<sigma> (Var x) = succ 0 (\<sigma> x)"
| "subst_term _ Zero = Zero"
| "subst_term \<sigma> (Succ n t) = succ n (subst_term \<sigma> t)"

fun subst_atom :: "('a \<Rightarrow> 'a suc_term) \<Rightarrow> 'a suc_atom \<Rightarrow> 'a suc_atom" where
  "subst_atom \<sigma> (Eq t1 t2) = Eq (subst_term \<sigma> t1) (subst_term \<sigma> t2)"
| "subst_atom \<sigma> (NEq t1 t2) = NEq (subst_term \<sigma> t1) (subst_term \<sigma> t2)"

lemma I_term_succ: "I_term v (succ n t) = I_term v (Succ n t)"
  by (induction n t rule: succ.induct) auto

lemma is_Succ_normal_succ[simp]: "is_Succ_normal (succ n t)"
  by (induction n t rule: succ.induct) auto

lemma is_Succ_normal_subst_term[simp]: "is_Succ_normal (subst_term \<sigma> t)"
  by (induction t) auto

lemma is_Succ_normal_subst_atom[simp]: "is_Succ_normal (subst_atom \<sigma> a)"
  by (cases a) simp_all

lemma is_NEq_subst_atom[simp]:
  "is_NEq (subst_atom v a) \<longleftrightarrow> is_NEq a"
  by (cases a) auto

abbreviation solve_Var_Eq_Succ where
"solve_Var_Eq_Succ solve x n t es \<equiv>
    (if (Var x) = t
      then (if n = 0 then solve es else None)
      else map_option ((#) (Eq (Var x) (succ n t)))
            (solve (map (subst_atom (Var(x := succ n t))) es))
    )"

lemma size_succ_leq[termination_simp]: "size (succ n t) \<le> Suc (size t)"
  by (induction n t rule: succ.induct) auto

function (sequential) solve :: "'a suc_atom list \<Rightarrow> 'a suc_atom list option" where
  "solve [] = Some []"
| "solve (Eq (Var x) (Var y) # es) = solve_Var_Eq_Succ solve x 0 (Var y) es"
| "solve (Eq (Var x) (Succ n t) # es) = solve_Var_Eq_Succ solve x n t es"
| "solve (Eq (Succ n t) (Var x) # es) = solve_Var_Eq_Succ solve x n t es"
| "solve (Eq (Succ n s) (Succ k t) # es) =
    (if n \<ge> k
      then solve (Eq t (succ (n - k) s) # es)
      else solve (Eq s (succ (k - n) t) # es)
    )"
| "solve (Eq Zero Zero # es) = solve es"
| "solve (Eq Zero (Var x) # es) = solve_Var_Eq_Succ solve x 0 Zero es"
| "solve (Eq (Var x) Zero # es) = solve_Var_Eq_Succ solve x 0 Zero es"
| "solve (Eq Zero (Succ 0 t) # es) = solve (Eq t Zero # es)"
| "solve (Eq Zero (Succ n t) # es) = None"
| "solve (Eq (Succ 0 t) Zero # es) = solve (Eq t Zero # es)"
| "solve (Eq (Succ n t) Zero # es) = None"
  by pat_completeness auto
termination by size_change

abbreviation "is_normal a \<equiv> \<not> is_NEq a \<and> is_Succ_normal a"

lemma is_Succ_normal_solve:
  assumes "solve es = Some ss" "\<forall>a \<in> set es. is_normal a"
  assumes "a \<in> set ss"
  shows "is_Succ_normal a"
  using assms
  by (induction es arbitrary: ss rule: solve.induct) (auto split: if_splits)

lemma I_term_subst_term:
  assumes "I_atom v (Eq (Var x) t)"
  shows "I_term v (subst_term (Var(x := t)) s) = I_term v s"
  using assms
  by (induction s) (auto simp: I_term_succ)

lemma I_atom_subst_atom:
  assumes "I_atom v (Eq (Var x) t)"
  shows "I_atom v (subst_atom (Var(x := t)) a) \<longleftrightarrow> I_atom v a"
  using assms
  by (cases a) (auto simp: I_term_subst_term)

lemma I_atom_solve_None:
  assumes "solve es = None" "\<forall>a \<in> set es. is_normal a"
  shows "\<exists>a \<in> set es. \<not> I_atom v a"
proof -
  have "False" if "\<forall>a \<in> set es. I_atom v a"
    using assms that
    by (induction es rule: solve.induct)
       (force simp: I_atom_subst_atom I_term_succ split: if_splits)+
  then show ?thesis
    by blast
qed

lemma set_suc_term_succ[simp]: "set_suc_term (succ n t) = set_suc_term t"
  by (induction n t rule: succ.induct) auto

lemma not_mem_subst_term_self:
  assumes "x \<notin> set_suc_term t"
  shows "x \<notin> set_suc_term (subst_term (Var(x := t)) s)"
  using assms
  by (induction s) auto

lemma not_mem_subst_atom_self:
  assumes "x \<notin> set_suc_term t"
  shows "x \<notin> set_suc_atom (subst_atom (Var(x := t)) a)"
  using not_mem_subst_term_self[OF assms] by (cases a) simp_all

lemma not_mem_subst_term:
  assumes "z \<notin> set_suc_term t" "z \<notin> set_suc_term s"
  shows "z \<notin> set_suc_term (subst_term (Var(x := t)) s)"
  using assms
  by (induction s) auto

lemma not_mem_subst_atom:
  assumes "z \<notin> set_suc_term t" "z \<notin> set_suc_atom a"
  shows "z \<notin> set_suc_atom (subst_atom (Var(x := t)) a)"
  using not_mem_subst_term[OF assms(1)] assms(2) by (cases a) simp_all

lemma not_mem_suc_atom_solve:
  assumes "solve es = Some ss" "\<forall>a \<in> set es. is_normal a"
  assumes "\<forall>a \<in> set es. z \<notin> set_suc_atom a"
  shows "\<forall>a \<in> set ss. z \<notin> set_suc_atom a"
  using assms
  by (induction es arbitrary: ss rule: solve.induct)
     (force simp: not_mem_subst_atom split: if_splits)+

lemma not_mem_suc_atom_if_solve:
  assumes "solve es = Some (Eq (Var x) t # ss)" "\<forall>a \<in> set es. is_normal a"
  shows "\<forall>a \<in> set ss. x \<notin> set_suc_atom a"
  using assms
proof(induction es arbitrary: ss rule: solve.induct)
  case (2 y z es)
  note not_mem_suc_atom_solve[where ?es="map (subst_atom (Var(y := Var z))) es" and ?z=y]
  with 2 show ?case
    by (auto simp: not_mem_subst_atom_self split: if_splits)
next
  case (3 y n t es)
  note not_mem_suc_atom_solve[
      where ?es="map (subst_atom (Var(y := succ n t))) es" and ?z=y]
  with 3 show ?case
    apply (simp split: if_splits)
    by (metis is_Succ_normal_term.simps(5) not_mem_subst_atom_self set_suc_term_succ suc_term.set_cases)
next
  case (4 n t y es)
  note not_mem_suc_atom_solve[
      where ?es="map (subst_atom (Var(y := succ n t))) es" and ?z=y]
  with 4 show ?case
    apply (simp split: if_splits)
    by (metis is_Succ_normal_term.simps(5) not_mem_subst_atom_self set_suc_term_succ suc_term.set_cases)
next
  case (7 y es)
  note not_mem_suc_atom_solve[
      where ?es="map (subst_atom (Var(y := Zero))) es" and ?z=y]
  with 7 show ?case
    by (auto simp: not_mem_subst_atom_self split: if_splits)
next
  case (8 y es)
  note not_mem_suc_atom_solve[
      where ?es="map (subst_atom (Var(y := Zero))) es" and ?z=y]
  with 8 show ?case
    by (auto simp: not_mem_subst_atom_self split: if_splits)
qed (auto split: if_splits)

fun assign :: "'a suc_atom list \<Rightarrow> ('a \<Rightarrow> nat)" where
  "assign [] = (\<lambda>x. 0)"
| "assign (Eq (Var x) (Var y) # ss) = (let ass = assign ss in ass(x := ass y))"
| "assign (Eq (Var x) (Succ n (Var y)) # ss) = (let ass = assign ss in ass(x := (Suc^^n) (ass y)))"
| "assign (Eq (Var x) Zero # ss) = (let ass = assign ss in ass(x := 0))"
| "assign (Eq (Var x) (Succ n Zero) # ss) = (let ass = assign ss in ass (x := (Suc^^n) 0))"
| "assign (Eq (Var x) (Succ n (Succ k t)) # ss) = assign (Eq (Var x) (Succ (n + k) t) # ss)"

lemma assign_succ:
  "assign (Eq (Var x) (succ n t) # ss) = assign (Eq (Var x) (Succ n t) # ss)"
  by (induction n t rule: succ.induct) auto

lemma I_term_fun_upd:
  assumes "x \<notin> set_suc_term t"
  shows "I_term (v(x := s)) t = I_term v t"
  using assms by (induction t) auto

lemma I_atom_fun_upd:
  assumes "x \<notin> set_suc_atom a"
  shows "I_atom (v(x := s)) a = I_atom v a"
  using assms by (cases a) (auto simp: I_term_fun_upd)

lemma I_atom_fun_updI:
  assumes "x \<notin> set_suc_atom a" "I_atom v a"
  shows "I_atom (v(x := s)) a"
  using assms I_atom_fun_upd by metis

lemma I_atom_assign_if_solve_Some:
  assumes "solve es = Some ss" "\<forall>a \<in> set es. is_normal a"
  shows "\<forall>a \<in> set ss. I_atom (assign ss) a"
  using assms
proof(induction es arbitrary: ss rule: solve.induct)
  case (2 x y es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Var y) # es" and ?x=x]
  with 2 show ?case
    by (auto simp: Let_def I_atom_fun_upd split: if_splits)
next
  case (3 x n t es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Succ n t) # es" and ?x=x]
  with 3 show ?case
    by (cases t)
       (auto simp: Let_def I_term_succ I_atom_fun_upd assign_succ split: if_splits)
next
  case (4 n t x es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Succ n t) # es" and ?x=x]
  with 4 show ?case
    by (cases t)
       (auto simp: Let_def I_term_succ I_atom_fun_upd assign_succ split: if_splits)
next
  case (7 x es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) Zero # es" and ?x=x]
  with 7 show ?case
    by (auto simp: Let_def I_atom_fun_upd split: if_splits)
next
  case (8 x es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) Zero # es" and ?x=x]
  with 8 show ?case
    by (auto simp: Let_def I_atom_fun_upd split: if_splits)
qed (auto split: if_splits)

lemma I_atom_iff_if_I_atom_solve_Some:
  assumes "solve es = Some ss" "\<forall>a \<in> set es. is_normal a"
  shows "(\<forall>a \<in> set ss. I_atom v a) \<longleftrightarrow> (\<forall>a \<in> set es. I_atom v a)"
  using assms
  by (induction es arbitrary: ss rule: solve.induct)
     (auto simp: I_term_succ I_atom_subst_atom split: if_splits)

lemma assign_minimal_if_solve_Some:
  assumes "solve es = Some ss" "\<forall>a \<in> set es. is_normal a"
  assumes "\<forall>a \<in> set ss. I_atom v a"
  shows "assign ss z \<le> v z"
  using assms
proof(induction es arbitrary: ss z rule: solve.induct)
  case (2 x y es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Var y) # es" and ?x=x]
  with 2 show ?case
    by (auto simp: Let_def split: if_splits)
next
  case (3 x n t es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Succ n t) # es" and ?x=x]
  with 3 show ?case
    by (cases t) (auto simp: Let_def I_term_succ assign_succ split: if_splits)
next
  case (4 n t x es)
  note not_mem_suc_atom_if_solve[where ?es="Eq (Var x) (Succ n t) # es" and ?x=x]
  with 4 show ?case
    by (cases t) (auto simp: Let_def I_term_succ assign_succ split: if_splits)
qed (auto split: if_splits)

fun elim_NEq_Zero_aux :: "('a::fresh) set \<Rightarrow> 'a suc_atom list \<Rightarrow> 'a suc_atom list" where
  "elim_NEq_Zero_aux _ [] = []"
| "elim_NEq_Zero_aux us (NEq (Var x) Zero # es) =
    (let fx = fresh us x in Eq (Var x) (Succ 1 (Var fx)) # elim_NEq_Zero_aux (insert fx us) es)"
| "elim_NEq_Zero_aux us (e # es) = e # elim_NEq_Zero_aux us es"

definition elim_NEq_Zero :: "('a::fresh) suc_atom list \<Rightarrow> 'a suc_atom list"
  where "elim_NEq_Zero es \<equiv> elim_NEq_Zero_aux (\<Union>(set_suc_atom ` set es)) es"

lemma is_normal_elim_NEq_Zero_aux:
  assumes "\<forall>a \<in> set es. is_Eq a \<longrightarrow> is_normal a"
  assumes "\<forall>a \<in> set es. is_NEq a \<longrightarrow> (\<exists>x. a = NEq (Var x) Zero)"
  shows "\<forall>a \<in> set (elim_NEq_Zero_aux us es). is_normal a"
  using assms
  by (induction es rule: elim_NEq_Zero_aux.induct) (auto simp: Let_def)

lemma is_normal_elim_NEq_Zero:
  assumes "\<forall>a \<in> set es. is_Eq a \<longrightarrow> is_normal a"
  assumes "\<forall>a \<in> set es. is_NEq a \<longrightarrow> (\<exists>x. a = NEq (Var x) Zero)"
  shows "\<forall>a \<in> set (elim_NEq_Zero es). is_normal a"
  using is_normal_elim_NEq_Zero_aux[OF assms] unfolding elim_NEq_Zero_def by blast

lemma I_atom_Var_NEq_Zero_if_I_atom_Var_Eq_Succ:
  "I_atom v (Eq (Var x) (Succ 1 (Var fx))) \<Longrightarrow> I_atom v (NEq (Var x) Zero)"
  by simp

lemma I_atom_if_I_atom_elim_NEq_Zero_aux:
  assumes "\<forall>a \<in> set (elim_NEq_Zero_aux us es). I_atom v a"
  shows "\<forall>a \<in> set es. I_atom v a"
  using assms I_atom_Var_NEq_Zero_if_I_atom_Var_Eq_Succ
  by (induction us es rule: elim_NEq_Zero_aux.induct) (auto simp: Let_def)

lemma I_atom_if_I_atom_elim_NEq_Zero:
  assumes "\<forall>a \<in> set (elim_NEq_Zero es). I_atom v a"
  shows "\<forall>a \<in> set es. I_atom v a"
  using assms I_atom_if_I_atom_elim_NEq_Zero_aux
  unfolding elim_NEq_Zero_def by blast

lemma I_term_if_eq_on_set_suc_term:
  assumes "\<forall>x \<in> set_suc_term t. v' x = v x"
  shows "I_term v' t = I_term v t"
  using assms
  by (induction t) auto

lemma I_atom_if_eq_on_set_suc_atom:
  assumes "\<forall>x \<in> set_suc_atom a. v' x = v x"
  shows "I_atom v' a = I_atom v a"
  using assms
  by (cases a) (simp; metis I_term_if_eq_on_set_suc_term UnI1 UnI2)+

lemma not_mem_set_suc_atom_elim_NEq_zero_aux:
  assumes "finite us" "\<Union>(set_suc_atom ` set es) \<subseteq> us"
  assumes "a \<in> set (elim_NEq_Zero_aux us es)"
  assumes "x \<in> us - \<Union>(set_suc_atom ` set es)"
  shows "x \<notin> set_suc_atom a"
  using assms
  by (induction us es arbitrary: x rule: elim_NEq_Zero_aux.induct)
     (auto simp: fresh_notIn Let_def)

lemma I_atom_elim_NEq_Zero_aux_if_I_atom:
  assumes "\<Union>(set_suc_atom ` set es) \<subseteq> us" "finite us"
  assumes "\<forall>a \<in> set es. I_atom v a"
  obtains v' where "\<forall>a \<in> set (elim_NEq_Zero_aux us es). I_atom v' a"
                   "\<forall>x \<in> us. v' x = v x"
  using assms
proof(induction us es arbitrary: thesis rule: elim_NEq_Zero_aux.induct)
  case (1 us)
  then show ?case by auto
next
  case (2 us x es thesis)
  then obtain v' where
    v': "\<forall>a \<in> set (elim_NEq_Zero_aux (insert (fresh us x) us) es). I_atom v' a"
        "\<forall>x \<in> insert (fresh us x) us. v' x = v x"
    by (auto simp: subset_insertI2)
  define v'' where "v'' \<equiv> v'(fresh us x := nat.pred (v' x))"

  from v' "2.prems"(3) have "fresh us x \<notin> us" "\<forall>x \<in> us. v'' x = v x"
    unfolding v''_def using fresh_notIn by (metis fun_upd_apply insertCI)+
  moreover from "2.prems"(2) have "x \<in> us"
    by auto
  moreover from "2.prems"(4) have "v x \<noteq> 0"
    by simp
  with v' \<open>x \<in> us\<close> have "v' x \<noteq> 0"
    by simp
  with \<open>x \<in> us\<close> have "v x = Suc (v'' (fresh us x))"
    unfolding v''_def by (auto simp: v'(2))
  moreover have "I_atom v'' a = I_atom v' a"
    if "a \<in> set (elim_NEq_Zero_aux (insert (fresh us x) us) es)" for a
  proof -
    have "fresh us x \<in> insert (fresh us x) us - \<Union>(set_suc_atom ` set es)"
      using "2.prems"(2) \<open>fresh us x \<notin> us\<close> by auto
    note not_mem_set_suc_atom_elim_NEq_zero_aux[OF _ _ _ this]
    with that have "fresh us x \<notin> set_suc_atom a"
      using "2.prems"(2,3) by auto
    then show ?thesis
      unfolding v''_def by (simp add: I_atom_fun_upd)
  qed
  ultimately show ?case
    by (intro "2"(2)[where ?v'=v'']) (auto simp: v'(1) Let_def)
qed (simp; metis I_term_if_eq_on_set_suc_term in_mono)+

lemma I_atom_elim_NEq_Zero_if_I_atom:
  assumes "\<forall>a \<in> set es. I_atom v a"
  obtains v' where "\<forall>a \<in> set (elim_NEq_Zero es). I_atom v' a"
                   "\<forall>x \<in> \<Union>(set_suc_atom ` set es). v' x = v x"
proof -
  have "finite (\<Union>(set_suc_atom ` set es))"
    by simp
  note I_atom_elim_NEq_Zero_aux_if_I_atom[OF _ this assms]
  with that show ?thesis
    unfolding elim_NEq_Zero_def by blast
qed

lemma not_I_atom_if_solve_elim_NEq_Zero_None:
  assumes "\<forall>a \<in> set es. is_Eq a \<longrightarrow> is_normal a"
  assumes "\<forall>a \<in> set es. is_NEq a \<longrightarrow> (\<exists>x. a = NEq (Var x) Zero)"
  assumes "solve (elim_NEq_Zero es) = None"
  shows "\<exists>a \<in> set es. \<not> I_atom v a"
proof -
  from is_normal_elim_NEq_Zero assms have "\<forall>a \<in> set (elim_NEq_Zero es). is_normal a"
    by blast
  note I_atom_solve_None[OF assms(3) this]
  then have "\<exists>a \<in> set (elim_NEq_Zero es). \<not> I_atom v a" for v
    by blast
  with I_atom_elim_NEq_Zero_if_I_atom show ?thesis
    by metis
qed

lemma
  assumes "\<forall>a \<in> set es. is_Eq a \<longrightarrow> is_normal a"
  assumes "\<forall>a \<in> set es. is_NEq a \<longrightarrow> (\<exists>x. a = NEq (Var x) Zero)"
  assumes "solve (elim_NEq_Zero es) = Some ss"
  shows I_atom_assign_if_solve_elim_NEq_Zero_Some:
      "\<forall>a \<in> set es. I_atom (assign ss) a"
    and I_atom_assign_minimal_if_solve_elim_NEq_Zero_Some:
      "\<lbrakk> \<forall>a \<in> set es. I_atom v a; z \<in> \<Union>(set_suc_atom ` set es) \<rbrakk>
       \<Longrightarrow> assign ss z \<le> v z"
proof -
  from is_normal_elim_NEq_Zero assms have normal: "\<forall>a \<in> set (elim_NEq_Zero es). is_normal a"
    by blast
  note I_atom_assign_if_solve_Some[OF assms(3) normal]
  note this[unfolded I_atom_iff_if_I_atom_solve_Some[OF assms(3) normal]]
  from I_atom_if_I_atom_elim_NEq_Zero[OF this] show "\<forall>a \<in> set es. I_atom (assign ss) a" .

  note assign_minimal_if_solve_Some[OF assms(3) normal]
  then have "assign ss z \<le> v z" if "\<forall>a \<in> set (elim_NEq_Zero es). I_atom v a" for v
    using that I_atom_iff_if_I_atom_solve_Some[OF assms(3) normal] by blast
  then show "assign ss z \<le> v z"
    if "\<forall>a \<in> set es. I_atom v a" "z \<in> \<Union>(set_suc_atom ` set es)" for v
    using that I_atom_elim_NEq_Zero_if_I_atom by metis
qed

hide_const (open) Var Eq NEq subst_term subst_atom is_normal I_term I_atom is_Eq is_NEq assign solve

end


theory Chapter10_3
imports
  "HOL-IMP.Live"
  "HOL-IMP.Small_Step"
  "Short_Theory"
begin

text{*
\exercise
Prove the following termination-insensitive version of the correctness of
@{const L}:
*}

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on L c X \<rbrakk> \<Longrightarrow> s' = t' on X"
(* your definition/proof here *)

text{*
Do not derive it as a corollary of the original correctness theorem
but prove it separately. Hint: modify the original proof.
\endexercise

\exercise\label{exe:bury-not-idemp}
Find a command @{text c} such that @{prop"bury (bury c {}) {} \<noteq> bury c {}"}.
For an arbitrary command, can you put a limit on the amount of burying needed
until everything that is dead is also buried?
*}

text{*
\endexercise

\exercise
Let @{term"lvars c"} / @{term"rvars c"} be the set of variables that
occur on the left-hand / right-hand side of an assignment in @{text c}.
Let @{term "rvars c"} additionally including those variables mentioned in
the conditionals of @{text IF} and @{text WHILE}.
Both functions are predefined in theory @{short_theory "Vars"}.
Show the following two properties of the small-step semantics.
Variables that are not assigned to do not change their value:
*}

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
(* your definition/proof here *)

text{*
The reduction behaviour of a command is only influenced by the variables
read by the command:
*}

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); s = t on X; rvars c \<subseteq> X\<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<rightarrow>* (c',t') \<and> s' = t' on X"
(* your definition/proof here *)

text{*
Hint: prove single step versions of the lemmas first.
\endexercise

\exercise
An \concept{available definitions} analysis determines which previous
assignments \texttt{x := a} are valid equalities \texttt{x = a} at later
program points.  For example, after \texttt{x := y+1} the equality \texttt{x =
y+1} is available, but after \mbox{\texttt{x := y+1;}} \texttt{y := 2} the equality \texttt{x = y+1} is
no longer available. The motivation for the analysis is that if \texttt{x =
a} is available before \texttt{v := a} then \mbox{\texttt{v := a}} can be replaced by
\texttt{v := x}.

Define an available definitions analysis as a gen/kill analysis,
for suitably defined @{text gen} and @{text kill} (which may need to be
mutually recursive):
*}
hide_const (open) gen "kill"
fun gen :: "com \<Rightarrow> (vname * aexp) set"
and "kill" :: "com \<Rightarrow> (vname * aexp) set" where
(* your definition/proof here *)

definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
"AD A c = gen c \<union> (A - kill c)"

text{*
The defining equations for both @{const gen} and @{const kill} follow
the \isacom{where} and are separated by ``@{text "|"}'' as usual.

A call \ @{term"AD A c"} \ should compute the available definitions
after the execution of @{text c} assuming that the definitions in @{text A}
are available before the execution of @{text c}.

Prove correctness of the analysis:
*}

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  \<forall> (x,a) \<in> A. s x = aval a s \<rbrakk>
  \<Longrightarrow> \<forall> (x,a) \<in> AD A c. s' x = aval a s'"
(* your definition/proof here *)

text{*
\endexercise
*}

end


\<^marker>\<open>creator "Johannes Hölzl"\<close>
section \<open>Probabilistic Guarded Command Language (pGCL)\<close>

theory PGCL_Angelic
  imports "Markov_Models.Markov_Decision_Process"
begin

datatype 's pgcl =
    Skip
  | Abort
  | Assign "'s \<Rightarrow> 's"
  | Seq "'s pgcl" "'s pgcl"
  | Par "'s pgcl" "'s pgcl"
  | If "'s \<Rightarrow> bool" "'s pgcl" "'s pgcl"
  | Prob "bool pmf" "'s pgcl" "'s pgcl"
  | While "'s \<Rightarrow> bool" "'s pgcl"

primrec wp :: "'s pgcl \<Rightarrow> ('s \<Rightarrow> ennreal) \<Rightarrow> ('s \<Rightarrow> ennreal)" where
  "wp Skip f          = f"
| "wp Abort f         = (\<lambda>_. 0)"
| "wp (Assign u) f    = f \<circ> u"
| "wp (Seq c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 (wp c\<^sub>2 f)"
| "wp (If b c\<^sub>1 c\<^sub>2) f   = (\<lambda>s. if b s then wp c\<^sub>1 f s else wp c\<^sub>2 f s)"
| "wp (Par c\<^sub>1 c\<^sub>2) f    = wp c\<^sub>1 f \<squnion> wp c\<^sub>2 f"
| "wp (Prob p c\<^sub>1 c\<^sub>2) f = (\<lambda>s. pmf p True * wp c\<^sub>1 f s + pmf p False * wp c\<^sub>2 f s)"
| "wp (While b c) f   = lfp (\<lambda>X s. if b s then wp c X s else f s)"

lemma wp_mono: "mono (wp c)"
  by (induction c)
     (auto simp: mono_def le_fun_def intro: order_trans sup_mono le_supI1 le_supI2
           intro!: add_mono mult_left_mono lfp_mono[THEN le_funD])

abbreviation det :: "'s pgcl \<Rightarrow> 's \<Rightarrow> ('s pgcl \<times> 's) pmf set" ("\<lless> _, _ \<ggreater>") where
  "det c s \<equiv> {return_pmf (c, s)}"

fun step :: "('s pgcl \<times> 's) \<Rightarrow> ('s pgcl \<times> 's) pmf set" where
  "step (Skip, s)        = \<lless>Skip, s\<ggreater>"
| "step (Abort, s)       = \<lless>Abort, s\<ggreater>"
| "step (Assign u, s)    = \<lless>Skip, u s\<ggreater>"
| "step (Seq c\<^sub>1 c\<^sub>2, s)    = (map_pmf (\<lambda>(p1', s'). (if p1' = Skip then c\<^sub>2 else Seq p1' c\<^sub>2, s'))) ` step (c\<^sub>1, s)"
| "step (If b c\<^sub>1 c\<^sub>2, s)   = (if b s then \<lless>c\<^sub>1, s\<ggreater> else \<lless>c\<^sub>2, s\<ggreater>)"
| "step (Par c\<^sub>1 c\<^sub>2, s)    = \<lless>c\<^sub>1, s\<ggreater> \<union> \<lless>c\<^sub>2, s\<ggreater>"
| "step (Prob p c\<^sub>1 c\<^sub>2, s) = {map_pmf (\<lambda>b. if b then (c\<^sub>1, s) else (c\<^sub>2, s)) p}"
| "step (While b c, s)   = (if b s then \<lless>Seq c (While b c), s\<ggreater> else \<lless>Skip, s\<ggreater>)"

lemma step_finite: "finite (step x)"
  by (induction x rule: step.induct) simp_all

lemma step_non_empty: "step x \<noteq> {}"
  by (induction x rule: step.induct) simp_all

interpretation step: Markov_Decision_Process step
  proof qed (rule step_non_empty)

definition rF :: "('s \<Rightarrow> ennreal) \<Rightarrow> (('s pgcl \<times> 's) stream \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "rF f F \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else F (stl \<omega>))"

abbreviation r :: "('s \<Rightarrow> ennreal) \<Rightarrow> ('s pgcl \<times> 's) stream \<Rightarrow> ennreal" where
  "r f \<equiv> lfp (rF f)"

lemma continuous_rF: "sup_continuous (rF f)"
  unfolding rF_def[abs_def]
  by (auto simp: sup_continuous_def fun_eq_iff SUP_sup_distrib[symmetric] SUP_image
           simp del: sup_ennreal_def
           split: prod.splits pgcl.splits)

lemma mono_rF: "mono (rF f)"
  using continuous_rF by (rule sup_continuous_mono)

lemma r_unfold: "r f \<omega> = (if fst (shd \<omega>) = Skip then f (snd (shd \<omega>)) else r f (stl \<omega>))"
  by (subst lfp_unfold[OF mono_rF]) (simp add: rF_def)

lemma mono_r: "F \<le> G \<Longrightarrow> r F \<omega> \<le> r G \<omega>"
  by (rule le_funD[of _ _ \<omega>], rule lfp_mono)
     (auto intro!: lfp_mono simp: rF_def le_fun_def max.coboundedI2)

lemma measurable_rF:
  assumes F[measurable]: "F \<in> borel_measurable step.St"
  shows "rF f F \<in> borel_measurable step.St"
  unfolding rF_def[abs_def]
  apply measurable
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable []
  apply (rule measurable_compose[OF measurable_stl])
  apply measurable []
  apply (rule predE)
  apply (rule measurable_compose[OF measurable_shd])
  apply measurable
  done

lemma measurable_r[measurable]: "r f \<in> borel_measurable step.St"
  using continuous_rF measurable_rF by (rule borel_measurable_lfp)

lemma mono_r': "mono (\<lambda>F s. \<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D)"
  by (auto intro!: monoI le_funI SUP_mono[OF bexI] nn_integral_mono simp: le_fun_def)

lemma E_sup_r:
  "step.E_sup s (r f) =
    lfp (\<lambda>F s. \<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
proof -
  have "step.E_sup s (r f) =
    lfp (\<lambda>F s. \<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) s"
    unfolding rF_def[abs_def]
  proof (rule step.E_sup_lfp[THEN fun_cong])
    let ?F = "\<lambda>t x. (if fst t = Skip then f (snd t) else x)"
    show "(\<lambda>(s, x). ?F s x) \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M borel)"
      apply (simp add: measurable_split_conv split_beta')
      apply (intro borel_measurable_max borel_measurable_const measurable_If predE
         measurable_compose[OF measurable_snd] measurable_compose[OF measurable_fst])
      apply measurable
      done
    show "\<And>s. sup_continuous (?F s)"
      by (auto simp: sup_continuous_def SUP_sup_distrib[symmetric] split: prod.split pgcl.split)
    show "\<And>F cfg. (\<integral>\<^sup>+\<omega>. ?F (state cfg) (F \<omega>) \<partial>step.T cfg) =
      ?F (state cfg) (nn_integral (step.T cfg) F)"
      by (auto simp: split: pgcl.split prod.split)
  qed
  then show ?thesis
    by simp
qed

lemma E_sup_r_unfold:
  "step.E_sup s (r f) = (\<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else step.E_sup t (r f)) \<partial>measure_pmf D)"
  unfolding E_sup_r by (simp add: lfp_unfold[OF mono_r'])

lemma E_sup_r_induct[consumes 1, case_names step]:
  assumes "P s y"
  assumes *: "\<And>F s y. P s y \<Longrightarrow>
    (\<And>s y. P s y \<Longrightarrow> F s \<le> y) \<Longrightarrow> (\<And>s. F s \<le> step.E_sup s (r f)) \<Longrightarrow>
    (\<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le> y"
  shows "step.E_sup s (r f) \<le> y"
  using `P s y`
  unfolding E_sup_r
proof (induction arbitrary: s y rule: lfp_ordinal_induct[OF mono_r'[where f=f]])
  case (1 F) with *[of s y F] show ?case
    unfolding le_fun_def E_sup_r[where f=f, symmetric] by simp
qed (auto intro: SUP_least)

lemma E_sup_Skip: "step.E_sup (Skip, s) (r f) = f s"
  by (subst E_sup_r_unfold) simp

lemma E_sup_Seq:
  assumes [simp]: "\<And>x. 0 \<le> f x"
  shows "step.E_sup (Seq a b, s) (r f) = step.E_sup (a, s) (r (\<lambda>s. step.E_sup (b, s) (r f)))"
proof (rule antisym)
  show "step.E_sup (Seq a b, s) (r f) \<le> step.E_sup (a, s) (r (\<lambda>s. step.E_sup (b, s) (r f)))"
  proof (coinduction arbitrary: a s rule: E_sup_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_sup_r_unfold)
         (force intro!: SUP_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_sup_Skip SUP_image simp del: inf_ennreal_def)
  qed
  show "step.E_sup (a, s) (r (\<lambda>s. step.E_sup (b, s) (r f))) \<le> step.E_sup (Seq a b, s) (r f)"
  proof (coinduction arbitrary: a s rule: E_sup_r_induct)
    case step then show ?case
      by (rewrite in "_ \<le> \<hole>" E_sup_r_unfold)
         (force intro!: SUP_mono[OF bexI] nn_integral_mono intro: le_infI2
                simp: E_sup_Skip SUP_image simp del: inf_ennreal_def)
   qed
qed

lemma E_sup_While:
  "step.E_sup (While g c, s) (r f) =
    lfp (\<lambda>F s. if g s then step.E_sup (c, s) (r F) else f s) s"
proof (rule antisym)
  have E_sup_While_step: "step.E_sup (While g c, s) (r f) =
    (if g s then step.E_sup (c, s) (r (\<lambda>s. step.E_sup (While g c, s) (r f))) else f s)" for f s
    by (rewrite E_sup_r_unfold) (simp add: min_absorb1 E_sup_Seq)

  have "mono (\<lambda>F s. if g s then step.E_sup (c, s) (r F) else f s)" (is "mono ?F")
    by (auto intro!: mono_r step.E_sup_mono simp: mono_def le_fun_def max.coboundedI2)
  then show "lfp ?F s \<le> step.E_sup (While g c, s) (r f)"
  proof (induction arbitrary: s rule: lfp_ordinal_induct[consumes 1])
    case mono then show ?case
      by (rewrite E_sup_While_step) (auto intro!: step.E_sup_mono mono_r le_funI)
  qed (auto intro: SUP_least)

  define w where "w \<equiv> \<lambda>F s. \<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then if g (snd t) then F (c, snd t) else f (snd t) else F t) \<partial>measure_pmf D"
  have "mono w"
    by (auto simp: w_def mono_def le_fun_def intro!: SUP_mono[OF bexI] nn_integral_mono) []

  define d where "d \<equiv> c"
  define t where "t \<equiv>Seq d (While g c)"
  then have "(t = While g c \<and> d = c \<and> g s) \<or> t = Seq d (While g c)"
    by auto
  then have "step.E_sup (t, s) (r f) \<le> lfp w (d, s)"
  proof (coinduction arbitrary: t d s rule: E_sup_r_induct)
    case (step F t d s)
    from step(1)
    show ?case
    proof (elim conjE disjE)
      { fix s have "\<not> g s \<Longrightarrow> F (While g c, s) \<le> f s"
          using step(3)[of "(While g c, s)"] by (simp add: E_sup_While_step) }
      note [simp] = this
      assume "t = Seq d (While g c)" then show ?thesis
        by (rewrite lfp_unfold[OF \<open>mono w\<close>])
           (auto simp: max.absorb2 w_def SUP_image intro!: SUP_mono[OF bexI] nn_integral_mono step)
    qed (auto intro!: step)
  qed
  also have "lfp w = lfp (\<lambda>F s. step.E_sup s (r (\<lambda>s. if g s then F (c, s) else f s)))"
    unfolding E_sup_r w_def
    by (rule lfp_lfp[symmetric]) (auto simp: le_fun_def intro!: SUP_mono[OF bexI] nn_integral_mono)
  finally have "step.E_sup (While g c, s) (r f) \<le> (if g s then \<dots> (c, s) else f s)"
    unfolding t_def d_def by (rewrite E_sup_r_unfold) simp
  also have "\<dots> = lfp ?F s"
    by (rewrite lfp_rolling[symmetric, of "\<lambda>F s. if g s then F (c, s) else f s"  "\<lambda>F s. step.E_sup s (r F)"])
       (auto simp: mono_def le_fun_def sup_apply[abs_def] if_distrib[of "max 0"] max.coboundedI2 max.absorb2
                intro!: step.E_sup_mono mono_r cong del: if_cong)
  finally show "step.E_sup (While g c, s) (r f) \<le> \<dots>"
    .
qed

lemma E_sup_r_eq_wp: "step.E_sup (c, s) (r f) = wp c f s"
proof (induction c arbitrary: f s)
  case Skip then show ?case
    by (simp add: E_sup_Skip)
next
  case Abort then show ?case
  proof (intro antisym)
    have "lfp (\<lambda>F s. \<Squnion>D\<in>step s. \<integral>\<^sup>+ t. (if fst t = Skip then f (snd t) else F t) \<partial>measure_pmf D) \<le>
      (\<lambda>s. if \<exists>t. s = (Abort, t) then 0 else \<top>)"
      by (intro lfp_lowerbound) (auto simp: le_fun_def)
    then show "step.E_sup (Abort, s) (r f) \<le> wp Abort f s"
      by (auto simp: E_sup_r le_fun_def split: if_split_asm)
  qed simp
next
  case Assign then show ?case
    by (rewrite E_sup_r_unfold) (simp add: min_absorb1)
next
  case (If b c1 c2) then show ?case
    by (rewrite E_sup_r_unfold) auto
next
  case (Prob p c1 c2) then show ?case
    apply (rewrite E_sup_r_unfold)
    apply auto
    apply (rewrite nn_integral_measure_pmf_support[of "UNIV::bool set"])
    apply (auto simp: UNIV_bool ac_simps)
    done
next
  case (Par c1 c2) then show ?case
    by (rewrite E_sup_r_unfold) (auto intro: sup.commute)
next
  case (Seq c1 c2) then show ?case
    by (simp add: E_sup_Seq)
next
  case (While g c) then show ?case
    apply (simp add: E_sup_While)
    apply (rewrite While)
    apply auto
    done
qed

end


(* Title: Rank_Argument_General.thy
   Author: Chelsea Edmonds
*)

section \<open>Rank Argument - General \<close>
text \<open>General lemmas to enable reasoning using the rank argument. This is described by Godsil
\cite{godsilToolsLinearAlgebra} and Bukh \cite{bukhAlgebraicMethodsCombinatoricsa}, both of whom
present it as a foundational technique \<close>
theory Rank_Argument_General imports Dual_Systems Jordan_Normal_Form.Determinant
Jordan_Normal_Form.DL_Rank Jordan_Normal_Form.Ring_Hom_Matrix BenOr_Kozen_Reif.More_Matrix
begin

subsection \<open>Row/Column Operations \<close>
text \<open>Extensions to the existing elementary operations are made to enable reasoning on multiple
operations at once, similar to mathematical literature\<close>

lemma index_mat_addrow_basic [simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> addrow a k l A $$ (i,j) = (if k = i then
    ( a * (A $$ (l,j)) + (A $$ (i,j))) else A $$ (i,j))"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> addrow a i l A $$ (i,j) = (a * (A $$ (l,j)) + (A $$ (i,j)))"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> k \<noteq> i \<Longrightarrow> addrow a k l A $$ (i,j) = A $$(i,j)"
  "dim_row (addrow a k l A) = dim_row A" "dim_col (addrow a k l A) = dim_col A"
  unfolding mat_addrow_def by auto

text\<open>Function to add a column to multiple other columns \<close>
fun add_col_to_multiple :: "'a :: semiring_1 \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
"add_col_to_multiple a [] l A = A" |
"add_col_to_multiple a (k # ks) l A = (addcol a k l (add_col_to_multiple a ks l A))"

text \<open>Function to add a row to multiple other rows \<close>
fun add_row_to_multiple :: "'a :: semiring_1 \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
"add_row_to_multiple a [] l A = A" |
"add_row_to_multiple a (k # ks) l A = (addrow a k l (add_row_to_multiple a ks l A))"

text \<open>Function to add multiple rows to a single row \<close>
fun add_multiple_rows :: "'a :: semiring_1 \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
"add_multiple_rows a k [] A = A" |
"add_multiple_rows a k (l # ls) A = (addrow a k l (add_multiple_rows a k ls A))"

text \<open>Function to add multiple columns to a single col \<close>
fun add_multiple_cols :: "'a :: semiring_1 \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
"add_multiple_cols a k [] A = A" |
"add_multiple_cols a k (l # ls) A = (addcol a k l (add_multiple_cols a k ls A))"

text \<open>Basic lemmas on dimension and indexing of resulting matrix from above functions \<close>
lemma add_multiple_rows_dim [simp]:
"dim_row (add_multiple_rows a k ls A) = dim_row A"
"dim_col (add_multiple_rows a k ls A) = dim_col A"
  by (induct ls) simp_all

lemma add_multiple_rows_index_unchanged [simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> k \<noteq> i \<Longrightarrow> add_multiple_rows a k ls A $$ (i,j) = A $$(i,j)"
  by (induct ls) (simp_all)

lemma add_multiple_rows_index_eq:
  assumes "i < dim_row A" and "j < dim_col A" and "i \<notin> set ls" and "\<And> l . l \<in> set ls \<Longrightarrow> l < dim_row A"
  shows "add_multiple_rows a i ls A $$ (i,j) = (\<Sum>l\<leftarrow>ls. a * A $$(l,j)) + A$$(i,j)"
  using assms proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  then have ne: "i \<noteq> aa"
    by auto
  have lt: "aa < dim_row A" using assms(1)
    by (simp add: Cons.prems(4))
  have "(add_multiple_rows a i (aa # ls) A) $$ (i, j) =
      (addrow a i aa (add_multiple_rows a i ls A)) $$ (i, j)"
    by simp
  also have "... = a * add_multiple_rows a i ls A $$ (aa, j) + (add_multiple_rows a i ls A) $$ (i, j)"
    using assms(1) assms(2) index_mat_addrow_basic(2)[of "i" "(add_multiple_rows a i ls A)" "j" "a" "aa"]
    by simp
  also have "... = a * A $$(aa, j) + (add_multiple_rows a i ls A) $$ (i, j)"
    using lt ne by (simp add: assms(2))
  also have "... = a * A $$(aa, j) + (\<Sum>l\<leftarrow>ls. a * A $$ (l, j)) + A $$ (i, j)"
    using Cons.hyps assms(1) assms(2) Cons.prems(3) Cons.prems(4)
    by (metis (mono_tags, lifting) ab_semigroup_add_class.add_ac(1) list.set_intros(2))
  finally show "(add_multiple_rows a i (aa # ls) A) $$ (i, j) =
      (\<Sum>l\<leftarrow>(aa #ls). a * A $$ (l, j)) + A $$ (i, j)"
    by simp
qed

lemma add_multiple_rows_index_eq_bounds:
  assumes "i < dim_row A" and "j < dim_col A" and "i < low \<or> i \<ge> up" and "up \<le> dim_row A"
  shows "add_multiple_rows a i [low..<up] A $$ (i,j) = (\<Sum>l=low..<up. a * A $$(l,j)) + A$$(i,j)"
proof -
  have notin: "i \<notin> set [low..<up]" using assms(3) by auto
  have "\<And> l . l \<in> set [low..<up] \<Longrightarrow> l < dim_row A" using assms(4) by auto
  thus ?thesis  using add_multiple_rows_index_eq[of i A j "[low..<up]"]
      sum_set_upt_eq_sum_list[of "\<lambda> l. a * A $$(l,j)" low up]  notin assms(1) assms(2) by simp
qed

lemma add_multiple_cols_dim [simp]:
  "dim_row (add_multiple_cols a k ls A) = dim_row A"
  "dim_col (add_multiple_cols a k ls A) = dim_col A"
  by (induct ls) simp_all

lemma add_multiple_cols_index_unchanged [simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> k \<noteq> j \<Longrightarrow> add_multiple_cols a k ls A $$ (i,j) = A $$(i,j)"
  by (induct ls) (simp_all)

lemma add_multiple_cols_index_eq:
  assumes "i < dim_row A" and "j < dim_col A" and "j \<notin> set ls" and "\<And> l . l \<in> set ls \<Longrightarrow> l < dim_col A"
  shows "add_multiple_cols a j ls A $$ (i,j) = (\<Sum>l\<leftarrow>ls. a * A $$(i,l)) + A$$(i,j)"
  using assms
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  then have ne: "j \<noteq> aa"
    by auto
  have lt: "aa < dim_col A" using assms
    by (simp add: Cons.prems(4))
  have "(add_multiple_cols a j (aa # ls) A) $$ (i, j) = (addcol a j aa (add_multiple_cols a j ls A)) $$ (i, j)"
    by simp
  also have "... = a * add_multiple_cols a j ls A $$ (i, aa) + (add_multiple_cols a j ls A) $$ (i, j)"
    using assms index_mat_addcol by simp
  also have "... = a * A $$(i, aa) + (add_multiple_cols a j ls A) $$ (i, j)"
    using lt ne by (simp add: assms(1))
  also have "... = a * A $$(i, aa) + (\<Sum>l\<leftarrow>ls. a * A $$ (i, l)) + A $$ (i, j)"
    using Cons.hyps assms(1) assms(2)  Cons.prems(3) Cons.prems(4)
    by (metis (mono_tags, lifting) ab_semigroup_add_class.add_ac(1)  list.set_intros(2))
  finally show ?case by simp
qed

lemma add_multiple_cols_index_eq_bounds:
  assumes "i < dim_row A" and "j < dim_col A" and "j < low \<or> j \<ge> up" and "up \<le> dim_col A"
  shows "add_multiple_cols a j [low..<up] A $$ (i,j) = (\<Sum>l=low..<up. a * A $$(i,l)) + A$$(i,j)"
proof -
  have notin: "j \<notin> set [low..<up]" using assms(3) by auto
  have "\<And> l . l \<in> set [low..<up] \<Longrightarrow> l < dim_col A" using assms(4) by auto
  thus ?thesis using add_multiple_cols_index_eq[of i A j "[low..<up]" a]
      sum_set_upt_eq_sum_list[of "\<lambda> l. a * A $$(i,l)" low up] notin assms(1) assms(2) by simp
qed

lemma add_row_to_multiple_dim [simp]:
  "dim_row (add_row_to_multiple a ks l A) = dim_row A"
  "dim_col (add_row_to_multiple a ks l A) = dim_col A"
  by (induct ks) simp_all

lemma add_row_to_multiple_index_unchanged [simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> i \<notin> set ks \<Longrightarrow> add_row_to_multiple a ks l A $$ (i,j) = A $$(i,j)"
  by (induct ks) simp_all

lemma add_row_to_multiple_index_unchanged_bound:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> i < low \<Longrightarrow> i \<ge> up \<Longrightarrow>
    add_row_to_multiple a [low..<up] l A $$ (i,j) = A $$(i,j)"
  by simp

lemma add_row_to_multiple_index_change:
  assumes "i < dim_row A" and "j < dim_col A" and "i \<in> set ks" and "distinct ks" and "l \<notin> set ks"
    and "l < dim_row A"
  shows "add_row_to_multiple a ks l A $$ (i,j) = (a * A$$(l, j)) + A$$(i,j)"
  using assms
proof (induct ks)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  then have lnotin: "l \<notin> set ls" using assms by simp
  then show ?case
  proof (cases "i = aa")
    case True
    then have inotin: "i \<notin> set ls" using assms
      using Cons.prems(4) by fastforce
    have "add_row_to_multiple a (aa # ls) l A $$ (i, j) =
        (addrow a aa l (add_row_to_multiple a ls l A)) $$ (i, j)" by simp
    also have "... = (a * ((add_row_to_multiple a ls l A) $$ (l,j)) +
        ((add_row_to_multiple a ls l A) $$ (i,j)))"
      using True assms(1) assms(2) by auto
    also have "... = a* A $$ (l, j) + ((add_row_to_multiple a ls l A) $$ (i,j))"
      using assms lnotin by simp
    finally have "add_row_to_multiple a (aa # ls) l A $$ (i, j) = a* A $$ (l,j) + A $$ (i, j)"
      using inotin assms by simp
    then show ?thesis by simp
  next
    case False
    then have iin: "i \<in> set ls" using assms
      by (meson Cons.prems(3) set_ConsD)
    have "add_row_to_multiple a (aa # ls) l A $$ (i, j) = (addrow a aa l (add_row_to_multiple a ls l A)) $$ (i, j)"
      by simp
    also have "... =  ((add_row_to_multiple a ls l A) $$ (i,j))"
      using False assms by auto
    finally have "add_row_to_multiple a (aa # ls) l A $$ (i, j) =  a * A $$ (l, j) + A $$ (i, j)"
      using Cons.hyps by (metis Cons.prems(4) assms(1) assms(2) assms(6) distinct.simps(2) iin lnotin)
    then show ?thesis by simp
  qed
qed

lemma add_row_to_multiple_index_change_bounds:
  assumes "i < dim_row A" and "j < dim_col A" and "i \<ge> low" and "i < up"  and "l < low \<or> l \<ge> up"
    and "l < dim_row A"
  shows "add_row_to_multiple a [low..<up] l A $$ (i,j) = (a * A$$(l, j)) + A$$(i,j)"
proof -
  have d: "distinct [low..<up]" by simp
  have iin: "i \<in> set [low..<up]" using assms by auto
  have lnin: "l \<notin> set [low..<up]" using assms by auto
  thus ?thesis
    using add_row_to_multiple_index_change d iin assms by blast
qed

lemma add_col_to_multiple_dim [simp]:
  "dim_row (add_col_to_multiple a ks l A) = dim_row A"
  "dim_col (add_col_to_multiple a ks l A) = dim_col A"
  by (induct ks) simp_all

lemma add_col_to_multiple_index_unchanged [simp]:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> j \<notin> set ks \<Longrightarrow> add_col_to_multiple a ks l A $$ (i,j) = A $$(i,j)"
  by (induct ks) simp_all

lemma add_col_to_multiple_index_unchanged_bound:
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> j < low \<Longrightarrow> j \<ge> up \<Longrightarrow>
    add_col_to_multiple a [low..<up] l A $$ (i,j) = A $$(i,j)"
  by simp

lemma add_col_to_multiple_index_change:
  assumes "i < dim_row A" and "j < dim_col A" and "j \<in> set ks" and "distinct ks" and "l \<notin> set ks"
    and "l < dim_col A"
  shows "add_col_to_multiple a ks l A $$ (i,j) = (a * A$$(i, l)) + A$$(i,j)"
  using assms
proof (induct ks)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  then have lnotin: "l \<notin> set ls" using assms by simp
  then show ?case
  proof (cases "j = aa")
    case True
    then have inotin: "j \<notin> set ls" using assms
      using Cons.prems(4) by fastforce
    have "add_col_to_multiple a (aa # ls) l A $$ (i, j) =
        (addcol a aa l (add_col_to_multiple a ls l A)) $$ (i, j)" by simp
    also have "... = (a * ((add_col_to_multiple a ls l A) $$ (i,l)) +
        ((add_col_to_multiple a ls l A) $$ (i,j)))"
      using True assms(1) assms(2) by auto
    also have "... = a* A $$ (i, l) + ((add_col_to_multiple a ls l A) $$ (i,j))"
      using assms lnotin by simp
    finally have "add_col_to_multiple a (aa # ls) l A $$ (i, j) = a* A $$ (i,l) + A $$ (i, j)"
      using inotin assms by simp
    then show ?thesis by simp
  next
    case False
    then have iin: "j \<in> set ls" using assms
      by (meson Cons.prems(3) set_ConsD)
    have "add_col_to_multiple a (aa # ls) l A $$ (i, j) =
        (addcol a aa l (add_col_to_multiple a ls l A)) $$ (i, j)" by simp
    also have "... =  ((add_col_to_multiple a ls l A) $$ (i,j))"
      using False assms by auto
    finally have "add_col_to_multiple a (aa # ls) l A $$ (i, j) =  a * A $$ (i, l) + A $$ (i, j)"
      using Cons.hyps by (metis Cons.prems(4) assms(1) assms(2) assms(6) distinct.simps(2) iin lnotin)
    then show ?thesis by simp
  qed
qed

lemma add_col_to_multiple_index_change_bounds:
  assumes "i < dim_row A" and "j < dim_col A" and "j \<ge> low" and "j < up"  and "l < low \<or> l \<ge> up"
    and "l < dim_col A"
  shows "add_col_to_multiple a [low..<up] l A $$ (i,j) = (a * A$$(i, l)) + A$$(i,j)"
proof -
  have d: "distinct [low..<up]" by simp
  have jin: "j \<in> set [low..<up]" using assms by auto
  have lnin: "l \<notin> set [low..<up]" using assms by auto
  thus ?thesis
    using add_col_to_multiple_index_change d jin assms by blast
qed

text \<open> Operations specifically on 1st row/column \<close>

lemma add_first_row_to_multiple_index:
  assumes "i < dim_row M" and "j < dim_col M"
  shows "i = 0 \<Longrightarrow> (add_row_to_multiple a [1..<dim_row M] 0 M) $$ (i, j) = M $$ (i, j)"
  and "i \<noteq> 0 \<Longrightarrow> (add_row_to_multiple a [1..<dim_row M] 0 M) $$ (i, j) = (a * M$$(0, j)) + M$$(i,j)"
  using assms add_row_to_multiple_index_change_bounds[of i "M" j 1 "dim_row M" 0 "a"] by (simp,linarith)

lemma add_all_cols_to_first:
  assumes "i < dim_row (M)"
  assumes "j < dim_col (M)"
  shows "j \<noteq> 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j)  = M $$ (i, j)"
  and "j = 0 \<Longrightarrow> add_multiple_cols 1 0 [1..<dim_col M] M $$ (i, j) = (\<Sum>l = 1..<dim_col M.  M $$(i,l)) + M$$(i,0)"
  using assms add_multiple_cols_index_eq_bounds[of "i" "M" "j" "1" "dim_col M" "1"] assms by (simp_all)

text \<open>Lemmas on the determinant of the matrix under extended row/column operations \<close>

lemma add_row_to_multiple_carrier:
  "A \<in> carrier_mat n n \<Longrightarrow> add_row_to_multiple a ks l A \<in> carrier_mat n n"
  by (metis add_row_to_multiple_dim(1) add_row_to_multiple_dim(2) carrier_matD(1) carrier_matD(2) carrier_matI)

lemma add_col_to_multiple_carrier:
  "A \<in> carrier_mat n n \<Longrightarrow> add_col_to_multiple a ks l A \<in> carrier_mat n n"
  by (metis add_col_to_multiple_dim carrier_matD(1) carrier_matD(2) carrier_matI)

lemma add_multiple_rows_carrier:
  "A \<in> carrier_mat n n \<Longrightarrow> add_multiple_rows a k ls A \<in> carrier_mat n n"
  by (metis add_multiple_rows_dim carrier_matD(1) carrier_matD(2) carrier_matI)

lemma add_multiple_cols_carrier:
  "A \<in> carrier_mat n n \<Longrightarrow> add_multiple_cols a k ls A \<in> carrier_mat n n"
  by (metis add_multiple_cols_dim carrier_matD(1) carrier_matD(2) carrier_matI)

lemma add_row_to_multiple_det:
  assumes "l \<notin> set ks" and "l < n" and "A \<in> carrier_mat n n"
  shows "det (add_row_to_multiple a ks l A) = det A"
  using assms
proof (induct ks)
  case Nil
  then show ?case by simp
next
  case (Cons aa ks)
  have ne: "aa \<noteq> l"
    using Cons.prems(1) by auto
  have "det (add_row_to_multiple a (aa # ks) l A) = det (addrow a aa l (add_row_to_multiple a ks l A))"
    by simp
  also have "... = det (add_row_to_multiple a ks l A)"
    by (meson det_addrow add_row_to_multiple_carrier ne assms)
  finally have "det (add_row_to_multiple a (aa # ks) l A) = det A"
    using Cons.hyps assms by (metis Cons.prems(1) list.set_intros(2))
  then show ?case by simp
qed

lemma add_col_to_multiple_det:
  assumes "l \<notin> set ks" and "l < n" and "A \<in> carrier_mat n n"
  shows "det (add_col_to_multiple a ks l A) = det A"
  using assms
proof (induct ks)
  case Nil
  then show ?case by simp
next
  case (Cons aa ks)
  have ne: "aa \<noteq> l"
    using Cons.prems(1) by auto
  have "det (add_col_to_multiple a (aa # ks) l A) = det (addcol a aa l (add_col_to_multiple a ks l A))"
    by simp
  also have "... = det (add_col_to_multiple a ks l A)"
    by (meson det_addcol add_col_to_multiple_carrier ne assms)
  finally have "det (add_col_to_multiple a (aa # ks) l A) = det A"
    using Cons.hyps assms by (metis Cons.prems(1) list.set_intros(2))
  then show ?case by simp
qed

lemma add_multiple_cols_det:
  assumes "k \<notin> set ls" and "\<And>l. l \<in> set ls \<Longrightarrow> l < n" and "A \<in> carrier_mat n n"
  shows "det (add_multiple_cols a k ls A) = det A"
  using assms
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  have ne: "aa \<noteq> k"
    using Cons.prems(1) by auto
  have "det (add_multiple_cols a k (aa # ls) A) = det (addcol a k aa (add_multiple_cols a k ls A))"
    by simp
  also have "... = det (add_multiple_cols a k ls A)"
    using det_addcol add_multiple_cols_carrier ne assms by (metis Cons.prems(2) list.set_intros(1))
  finally have "det (add_multiple_cols a k (aa # ls) A) = det A"
    using Cons.hyps assms by (metis Cons.prems(1) Cons.prems(2) list.set_intros(2))
  then show ?case by simp
qed

lemma add_multiple_rows_det:
  assumes "k \<notin> set ls" and "\<And>l. l \<in> set ls \<Longrightarrow> l < n" and "A \<in> carrier_mat n n"
  shows "det (add_multiple_rows a k ls A) = det A"
  using assms
proof (induct ls)
  case Nil
  then show ?case by simp
next
  case (Cons aa ls)
  have ne: "aa \<noteq> k"
    using Cons.prems(1) by auto
  have "det (add_multiple_rows a k (aa # ls) A) = det (addrow a k aa (add_multiple_rows a k ls A))"
    by simp
  also have "... = det (add_multiple_rows a k ls A)"
    using det_addrow add_multiple_rows_carrier ne assms by (metis Cons.prems(2) list.set_intros(1))
  finally have "det (add_multiple_rows a k (aa # ls) A) = det A"
    using Cons.hyps assms by (metis Cons.prems(1) Cons.prems(2) list.set_intros(2))
  then show ?case by simp
qed

subsection \<open>Rank and Linear Independence\<close>

abbreviation "rank v M \<equiv> vec_space.rank v M"

text \<open>Basic lemma: the rank of the multiplication of two matrices will be less than the minimum
of the individual ranks of those matrices. This directly follows from an existing lemmas in the
linear algebra library which show independently that the resulting matrices rank is less than either
the right or left matrix rank in the product \<close>
lemma rank_mat_mult_lt_min_rank_factor:
  fixes A :: "'a::{conjugatable_ordered_field} mat"
  assumes "A \<in> carrier_mat n m"
  assumes "B \<in> carrier_mat m nc"
  shows "rank n (A * B) \<le> min (rank n A) (rank m B)"
proof -
  have 1: "rank n (A * B) \<le> (rank n A)"
    using assms(1) assms(2) vec_space.rank_mat_mul_right by blast
  have "rank n (A* B) \<le> rank m B"
    by (meson assms(1) assms(2) rank_mat_mul_left)
  thus ?thesis using 1 by simp
qed

text \<open>Rank Argument 1: Given two a $x \times y$ matrix $M$ where $MM^T$ has rank x, $x \le y$\<close>
lemma rank_argument:
  fixes M :: "('c :: {conjugatable_ordered_field}) mat"
  assumes "M \<in> carrier_mat x y"
  assumes "vec_space.rank x (M* M\<^sup>T) = x"
  shows "x \<le> y"
proof -
  let ?B = "(M * M\<^sup>T)"
  have Mt_car: "M\<^sup>T \<in> carrier_mat y x" using assms by simp
  have b_car: "?B \<in> carrier_mat x x"
    using transpose_carrier_mat assms by simp
  then have "rank x ?B \<le> min (rank x M) (rank y M\<^sup>T)"
    using rank_mat_mult_lt_min_rank_factor Mt_car b_car assms(1) by blast
  thus ?thesis using le_trans vec_space.rank_le_nc
    by (metis assms(1) assms(2) min.bounded_iff)
qed

text \<open>Generalise the rank argument to use the determinant. If the determinant of the matrix
is non-zero, than it's rank must be equal to $x$. This removes the need for someone to use
facts on rank in their proofs. \<close>
lemma rank_argument_det:
  fixes M :: "('c :: {conjugatable_ordered_field}) mat"
  assumes "M \<in> carrier_mat x y"
  assumes "det (M* M\<^sup>T) \<noteq> 0"
  shows "x \<le> y"
proof -
  let ?B = "(M * M\<^sup>T)"
  have Mt_car: "M\<^sup>T \<in> carrier_mat y x" using assms by simp
  have b_car: "?B \<in> carrier_mat x x"
    using transpose_carrier_mat assms by simp
  then have b_rank: "vec_space.rank x ?B = x"
    using vec_space.low_rank_det_zero assms(2) by blast
  then have "rank x ?B \<le> min (rank x M) (rank y M\<^sup>T)"
    using rank_mat_mult_lt_min_rank_factor Mt_car b_car assms(1) by blast
  thus ?thesis using le_trans vec_space.rank_le_nc
    by (metis assms(1) b_rank min.bounded_iff)
qed

end


(*  Title:      HOL/Library/Multiset_Order.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
*)

section \<open>More Theorems about the Multiset Order\<close>

theory Multiset_Order
imports Multiset
begin

subsection \<open>Alternative Characterizations\<close>

context preorder
begin

lemma order_mult: "class.order
  (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y} \<or> M = N)
  (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y})"
  (is "class.order ?le ?less")
proof -
  have irrefl: "\<And>M :: 'a multiset. \<not> ?less M M"
  proof
    fix M :: "'a multiset"
    have "trans {(x'::'a, x). x' < x}"
      by (rule transI) (blast intro: less_trans)
    moreover
    assume "(M, M) \<in> mult {(x, y). x < y}"
    ultimately have "\<exists>I J K. M = I + J \<and> M = I + K
      \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})"
      by (rule mult_implies_one_step)
    then obtain I J K where "M = I + J" and "M = I + K"
      and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})" by blast
    then have aux1: "K \<noteq> {#}" and aux2: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. k < j" by auto
    have "finite (set_mset K)" by simp
    moreover note aux2
    ultimately have "set_mset K = {}"
      by (induct rule: finite_induct)
       (simp, metis (mono_tags) insert_absorb insert_iff insert_not_empty less_irrefl less_trans)
    with aux1 show False by simp
  qed
  have trans: "\<And>K M N :: 'a multiset. ?less K M \<Longrightarrow> ?less M N \<Longrightarrow> ?less K N"
    unfolding mult_def by (blast intro: trancl_trans)
  show "class.order ?le ?less"
    by standard (auto simp add: less_eq_multiset_def irrefl dest: trans)
qed

text \<open>The Dershowitz--Manna ordering:\<close>

definition less_multiset\<^sub>D\<^sub>M where
  "less_multiset\<^sub>D\<^sub>M M N \<longleftrightarrow>
   (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"

text \<open>The Huet--Oppen ordering:\<close>

definition less_multiset\<^sub>H\<^sub>O where
  "less_multiset\<^sub>H\<^sub>O M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"

lemma mult_imp_less_multiset\<^sub>H\<^sub>O:
  "(M, N) \<in> mult {(x, y). x < y} \<Longrightarrow> less_multiset\<^sub>H\<^sub>O M N"
proof (unfold mult_def, induct rule: trancl_induct)
  case (base P)
  then show ?case
    by (auto elim!: mult1_lessE simp add: count_eq_zero_iff less_multiset\<^sub>H\<^sub>O_def split: if_splits dest!: Suc_lessD)
next
  case (step N P)
  from step(3) have "M \<noteq> N" and
    **: "\<And>y. count N y < count M y \<Longrightarrow> (\<exists>x>y. count M x < count N x)"
    by (simp_all add: less_multiset\<^sub>H\<^sub>O_def)
  from step(2) obtain M0 a K where
    *: "P = add_mset a M0" "N = M0 + K" "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> b < a"
    by (blast elim: mult1_lessE)
  from \<open>M \<noteq> N\<close> ** *(1,2,3) have "M \<noteq> P" by (force dest: *(4) elim!: less_asym split: if_splits )
  moreover
  { assume "count P a \<le> count M a"
    with \<open>a \<notin># K\<close> have "count N a < count M a" unfolding *(1,2)
      by (auto simp add: not_in_iff)
      with ** obtain z where z: "z > a" "count M z < count N z"
        by blast
      with * have "count N z \<le> count P z"
        by (auto elim: less_asym intro: count_inI)
      with z have "\<exists>z > a. count M z < count P z" by auto
  } note count_a = this
  { fix y
    assume count_y: "count P y < count M y"
    have "\<exists>x>y. count M x < count P x"
    proof (cases "y = a")
      case True
      with count_y count_a show ?thesis by auto
    next
      case False
      show ?thesis
      proof (cases "y \<in># K")
        case True
        with *(4) have "y < a" by simp
        then show ?thesis by (cases "count P a \<le> count M a") (auto dest: count_a intro: less_trans)
      next
        case False
        with \<open>y \<noteq> a\<close> have "count P y = count N y" unfolding *(1,2)
          by (simp add: not_in_iff)
        with count_y ** obtain z where z: "z > y" "count M z < count N z" by auto
        show ?thesis
        proof (cases "z \<in># K")
          case True
          with *(4) have "z < a" by simp
          with z(1) show ?thesis
            by (cases "count P a \<le> count M a") (auto dest!: count_a intro: less_trans)
        next
          case False
          with \<open>a \<notin># K\<close> have "count N z \<le> count P z" unfolding *
            by (auto simp add: not_in_iff)
          with z show ?thesis by auto
        qed
      qed
    qed
  }
  ultimately show ?case unfolding less_multiset\<^sub>H\<^sub>O_def by blast
qed

lemma less_multiset\<^sub>D\<^sub>M_imp_mult:
  "less_multiset\<^sub>D\<^sub>M M N \<Longrightarrow> (M, N) \<in> mult {(x, y). x < y}"
proof -
  assume "less_multiset\<^sub>D\<^sub>M M N"
  then obtain X Y where
    "X \<noteq> {#}" and "X \<subseteq># N" and "M = N - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)"
    unfolding less_multiset\<^sub>D\<^sub>M_def by blast
  then have "(N - X + Y, N - X + X) \<in> mult {(x, y). x < y}"
    by (intro one_step_implies_mult) (auto simp: Bex_def trans_def)
  with \<open>M = N - X + Y\<close> \<open>X \<subseteq># N\<close> show "(M, N) \<in> mult {(x, y). x < y}"
    by (metis subset_mset.diff_add)
qed

lemma less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M: "less_multiset\<^sub>H\<^sub>O M N \<Longrightarrow> less_multiset\<^sub>D\<^sub>M M N"
unfolding less_multiset\<^sub>D\<^sub>M_def
proof (intro iffI exI conjI)
  assume "less_multiset\<^sub>H\<^sub>O M N"
  then obtain z where z: "count M z < count N z"
    unfolding less_multiset\<^sub>H\<^sub>O_def by (auto simp: multiset_eq_iff nat_neq_iff)
  define X where "X = N - M"
  define Y where "Y = M - N"
  from z show "X \<noteq> {#}" unfolding X_def by (auto simp: multiset_eq_iff not_less_eq_eq Suc_le_eq)
  from z show "X \<subseteq># N" unfolding X_def by auto
  show "M = (N - X) + Y" unfolding X_def Y_def multiset_eq_iff count_union count_diff by force
  show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)"
  proof (intro allI impI)
    fix k
    assume "k \<in># Y"
    then have "count N k < count M k" unfolding Y_def
      by (auto simp add: in_diff_count)
    with \<open>less_multiset\<^sub>H\<^sub>O M N\<close> obtain a where "k < a" and "count M a < count N a"
      unfolding less_multiset\<^sub>H\<^sub>O_def by blast
    then show "\<exists>a. a \<in># X \<and> k < a" unfolding X_def
      by (auto simp add: in_diff_count)
  qed
qed

lemma mult_less_multiset\<^sub>D\<^sub>M: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>D\<^sub>M M N"
  by (metis less_multiset\<^sub>D\<^sub>M_imp_mult less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M mult_imp_less_multiset\<^sub>H\<^sub>O)

lemma mult_less_multiset\<^sub>H\<^sub>O: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
  by (metis less_multiset\<^sub>D\<^sub>M_imp_mult less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M mult_imp_less_multiset\<^sub>H\<^sub>O)

lemmas mult\<^sub>D\<^sub>M = mult_less_multiset\<^sub>D\<^sub>M[unfolded less_multiset\<^sub>D\<^sub>M_def]
lemmas mult\<^sub>H\<^sub>O = mult_less_multiset\<^sub>H\<^sub>O[unfolded less_multiset\<^sub>H\<^sub>O_def]

end

lemma less_multiset_less_multiset\<^sub>H\<^sub>O: "M < N \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
  unfolding less_multiset_def mult\<^sub>H\<^sub>O less_multiset\<^sub>H\<^sub>O_def ..

lemmas less_multiset\<^sub>D\<^sub>M = mult\<^sub>D\<^sub>M[folded less_multiset_def]
lemmas less_multiset\<^sub>H\<^sub>O = mult\<^sub>H\<^sub>O[folded less_multiset_def]

lemma subset_eq_imp_le_multiset:
  shows "M \<subseteq># N \<Longrightarrow> M \<le> N"
  unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O
  by (simp add: less_le_not_le subseteq_mset_def)

(* FIXME: "le" should be "less" in this and other names *)
lemma le_multiset_right_total: "M < add_mset x M"
  unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O by simp

lemma less_eq_multiset_empty_left[simp]:
  shows "{#} \<le> M"
  by (simp add: subset_eq_imp_le_multiset)

lemma ex_gt_imp_less_multiset: "(\<exists>y. y \<in># N \<and> (\<forall>x. x \<in># M \<longrightarrow> x < y)) \<Longrightarrow> M < N"
  unfolding less_multiset\<^sub>H\<^sub>O
  by (metis count_eq_zero_iff count_greater_zero_iff less_le_not_le)

lemma less_eq_multiset_empty_right[simp]: "M \<noteq> {#} \<Longrightarrow> \<not> M \<le> {#}"
  by (metis less_eq_multiset_empty_left antisym)

(* FIXME: "le" should be "less" in this and other names *)
lemma le_multiset_empty_left[simp]: "M \<noteq> {#} \<Longrightarrow> {#} < M"
  by (simp add: less_multiset\<^sub>H\<^sub>O)

(* FIXME: "le" should be "less" in this and other names *)
lemma le_multiset_empty_right[simp]: "\<not> M < {#}"
  using subset_mset.le_zero_eq less_multiset\<^sub>D\<^sub>M by blast

(* FIXME: "le" should be "less" in this and other names *)
lemma union_le_diff_plus: "P \<subseteq># M \<Longrightarrow> N < P \<Longrightarrow> M - P + N < M"
  by (drule subset_mset.diff_add[symmetric]) (metis union_le_mono2)

instantiation multiset :: (preorder) ordered_ab_semigroup_monoid_add_imp_le
begin

lemma less_eq_multiset\<^sub>H\<^sub>O:
  "M \<le> N \<longleftrightarrow> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
  by (auto simp: less_eq_multiset_def less_multiset\<^sub>H\<^sub>O)

instance by standard (auto simp: less_eq_multiset\<^sub>H\<^sub>O)

lemma
  fixes M N :: "'a multiset"
  shows
    less_eq_multiset_plus_left: "N \<le> (M + N)" and
    less_eq_multiset_plus_right: "M \<le> (M + N)"
  by simp_all

lemma
  fixes M N :: "'a multiset"
  shows
    le_multiset_plus_left_nonempty: "M \<noteq> {#} \<Longrightarrow> N < M + N" and
    le_multiset_plus_right_nonempty: "N \<noteq> {#} \<Longrightarrow> M < M + N"
    by simp_all

end

lemma all_lt_Max_imp_lt_mset: "N \<noteq> {#} \<Longrightarrow> (\<forall>a \<in># M. a < Max (set_mset N)) \<Longrightarrow> M < N"
  by (meson Max_in[OF finite_set_mset] ex_gt_imp_less_multiset set_mset_eq_empty_iff)

lemma lt_imp_ex_count_lt: "M < N \<Longrightarrow> \<exists>y. count M y < count N y"
  by (meson less_eq_multiset\<^sub>H\<^sub>O less_le_not_le)

lemma subset_imp_less_mset: "A \<subset># B \<Longrightarrow> A < B"
  by (simp add: order.not_eq_order_implies_strict subset_eq_imp_le_multiset)

lemma image_mset_strict_mono:
  assumes
    mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
    less: "M < N"
  shows "image_mset f M < image_mset f N"
proof -
  obtain Y X where
    y_nemp: "Y \<noteq> {#}" and y_sub_N: "Y \<subseteq># N" and M_eq: "M = N - Y + X" and
    ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> x < y)"
    using less[unfolded less_multiset\<^sub>D\<^sub>M] by blast

  have x_sub_M: "X \<subseteq># M"
    using M_eq by simp

  let ?fY = "image_mset f Y"
  let ?fX = "image_mset f X"

  show ?thesis
    unfolding less_multiset\<^sub>D\<^sub>M
  proof (intro exI conjI)
    show "image_mset f M = image_mset f N - ?fY + ?fX"
      using M_eq[THEN arg_cong, of "image_mset f"] y_sub_N
      by (metis image_mset_Diff image_mset_union)
  next
    obtain y where y: "\<forall>x. x \<in># X \<longrightarrow> y x \<in># Y \<and> x < y x"
      using ex_y by moura

    show "\<forall>fx. fx \<in># ?fX \<longrightarrow> (\<exists>fy. fy \<in># ?fY \<and> fx < fy)"
    proof (intro allI impI)
      fix fx
      assume "fx \<in># ?fX"
      then obtain x where fx: "fx = f x" and x_in: "x \<in># X"
        by auto
      hence y_in: "y x \<in># Y" and y_gt: "x < y x"
        using y[rule_format, OF x_in] by blast+
      hence "f (y x) \<in># ?fY \<and> f x < f (y x)"
        using mono_f y_sub_N x_sub_M x_in
        by (metis image_eqI in_image_mset mset_subset_eqD)
      thus "\<exists>fy. fy \<in># ?fY \<and> fx < fy"
        unfolding fx by auto
    qed
  qed (auto simp: y_nemp y_sub_N image_mset_subseteq_mono)
qed

lemma image_mset_mono:
  assumes
    mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
    less: "M \<le> N"
  shows "image_mset f M \<le> image_mset f N"
  by (metis eq_iff image_mset_strict_mono less less_imp_le mono_f order.not_eq_order_implies_strict)

lemma mset_lt_single_right_iff[simp]: "M < {#y#} \<longleftrightarrow> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
proof (rule iffI)
  assume M_lt_y: "M < {#y#}"
  show "\<forall>x \<in># M. x < y"
  proof
    fix x
    assume x_in: "x \<in># M"
    hence M: "M - {#x#} + {#x#} = M"
      by (meson insert_DiffM2)
    hence "\<not> {#x#} < {#y#} \<Longrightarrow> x < y"
      using x_in M_lt_y
      by (metis diff_single_eq_union le_multiset_empty_left less_add_same_cancel2 mset_le_trans)
    also have "\<not> {#y#} < M"
      using M_lt_y mset_le_not_sym by blast
    ultimately show "x < y"
      by (metis (no_types) Max_ge all_lt_Max_imp_lt_mset empty_iff finite_set_mset insertE
        less_le_trans linorder_less_linear mset_le_not_sym set_mset_add_mset_insert
        set_mset_eq_empty_iff x_in)
  qed
next
  assume y_max: "\<forall>x \<in># M. x < y"
  show "M < {#y#}"
    by (rule all_lt_Max_imp_lt_mset) (auto intro!: y_max)
qed

lemma mset_le_single_right_iff[simp]:
  "M \<le> {#y#} \<longleftrightarrow> M = {#y#} \<or> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
  by (meson less_eq_multiset_def mset_lt_single_right_iff)

subsection \<open>Simprocs\<close>

lemma mset_le_add_iff1:
  "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (repeat_mset (i-j) u + m \<le> n)"
proof -
  assume "j \<le> i"
  then have "j + (i - j) = i"
    using le_add_diff_inverse by blast
  then show ?thesis
    by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
qed

lemma mset_le_add_iff2:
  "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (m \<le> repeat_mset (j-i) u + n)"
proof -
  assume "i \<le> j"
  then have "i + (j - i) = j"
    using le_add_diff_inverse by blast
  then show ?thesis
    by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
qed

simproc_setup msetless_cancel
  ("(l::'a::preorder multiset) + m < n" | "(l::'a multiset) < m + n" |
   "add_mset a m < n" | "m < add_mset a n" |
   "replicate_mset p a < n" | "m < replicate_mset p a" |
   "repeat_mset p m < n" | "m < repeat_mset p n") =
  \<open>fn phi => Cancel_Simprocs.less_cancel\<close>

simproc_setup msetle_cancel
  ("(l::'a::preorder multiset) + m \<le> n" | "(l::'a multiset) \<le> m + n" |
   "add_mset a m \<le> n" | "m \<le> add_mset a n" |
   "replicate_mset p a \<le> n" | "m \<le> replicate_mset p a" |
   "repeat_mset p m \<le> n" | "m \<le> repeat_mset p n") =
  \<open>fn phi => Cancel_Simprocs.less_eq_cancel\<close>

subsection \<open>Additional facts and instantiations\<close>

lemma ex_gt_count_imp_le_multiset:
  "(\<forall>y :: 'a :: order. y \<in># M + N \<longrightarrow> y \<le> x) \<Longrightarrow> count M x < count N x \<Longrightarrow> M < N"
  unfolding less_multiset\<^sub>H\<^sub>O
  by (metis count_greater_zero_iff le_imp_less_or_eq less_imp_not_less not_gr_zero union_iff)

lemma mset_lt_single_iff[iff]: "{#x#} < {#y#} \<longleftrightarrow> x < y"
  unfolding less_multiset\<^sub>H\<^sub>O by simp

lemma mset_le_single_iff[iff]: "{#x#} \<le> {#y#} \<longleftrightarrow> x \<le> y" for x y :: "'a::order"
  unfolding less_eq_multiset\<^sub>H\<^sub>O by force

instance multiset :: (linorder) linordered_cancel_ab_semigroup_add
  by standard (metis less_eq_multiset\<^sub>H\<^sub>O not_less_iff_gr_or_eq)

lemma less_eq_multiset_total:
  fixes M N :: "'a :: linorder multiset"
  shows "\<not> M \<le> N \<Longrightarrow> N \<le> M"
  by simp

instantiation multiset :: (wellorder) wellorder
begin

lemma wf_less_multiset: "wf {(M :: 'a multiset, N). M < N}"
  unfolding less_multiset_def by (auto intro: wf_mult wf)

instance by standard (metis less_multiset_def wf wf_def wf_mult)

end

instantiation multiset :: (preorder) order_bot
begin

definition bot_multiset :: "'a multiset" where "bot_multiset = {#}"

instance by standard (simp add: bot_multiset_def)

end

instance multiset :: (preorder) no_top
proof standard
  fix x :: "'a multiset"
  obtain a :: 'a where True by simp
  have "x < x + (x + {#a#})"
    by simp
  then show "\<exists>y. x < y"
    by blast
qed

instance multiset :: (preorder) ordered_cancel_comm_monoid_add
  by standard

instantiation multiset :: (linorder) distrib_lattice
begin

definition inf_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "inf_multiset A B = (if A < B then A else B)"

definition sup_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
  "sup_multiset A B = (if B > A then B else A)"

instance
  by intro_classes (auto simp: inf_multiset_def sup_multiset_def)

end

end