(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Map_Extra.thy                                                        *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Map Type: extra functions and properties \<close>

theory Map_Extra
  imports
  "HOL-Library.Countable_Set"
  "HOL-Library.Monad_Syntax"
begin

subsection \<open> Functional Relations \<close>

definition functional :: "('a * 'b) set \<Rightarrow> bool" where
"functional g = inj_on fst g"

definition functional_list :: "('a * 'b) list \<Rightarrow> bool" where
"functional_list xs = (\<forall> x y z. ListMem (x,y) xs \<and> ListMem (x,z) xs \<longrightarrow> y = z)"

lemma functional_insert [simp]: "functional (insert (x,y) g) \<longleftrightarrow> (g``{x} \<subseteq> {y} \<and> functional g)"
  by (auto simp add:functional_def inj_on_def image_def)

lemma functional_list_nil[simp]: "functional_list []"
  by (simp add:functional_list_def ListMem_iff)

lemma functional_list: "functional_list xs \<longleftrightarrow> functional (set xs)"
  apply (induct xs)
   apply (simp add:functional_def)
  apply (simp add:functional_def functional_list_def ListMem_iff)
  apply (safe)
         apply (force)
        apply (force)
       apply (force)
      apply (force)
     apply (force)
    apply (force)
   apply (force)
  apply (force)
  done

subsection \<open> Graphing Maps \<close>

definition map_graph :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a * 'b) set" where
"map_graph f = {(x,y) | x y. f x = Some y}"

definition graph_map :: "('a * 'b) set \<Rightarrow> ('a \<rightharpoonup> 'b)" where
"graph_map g = (\<lambda> x. if (x \<in> fst ` g) then Some (SOME y. (x,y) \<in> g) else None)"

definition graph_map' :: "('a \<times> 'b) set \<rightharpoonup> ('a \<rightharpoonup> 'b)" where
"graph_map' R = (if (functional R) then Some (graph_map R) else None)"

lemma map_graph_mem_equiv: "(x, y) \<in> map_graph f \<longleftrightarrow> f(x) = Some y"
  by (simp add: map_graph_def)

lemma map_graph_functional[simp]: "functional (map_graph f)"
  by (simp add:functional_def map_graph_def inj_on_def)

lemma map_graph_countable [simp]: "countable (dom f) \<Longrightarrow> countable (map_graph f)"
  apply (auto simp add:map_graph_def countable_def)
  apply (rename_tac f')
  apply (rule_tac x="f' \<circ> fst" in exI)
  apply (auto simp add:inj_on_def dom_def)
  apply fastforce
  done

lemma map_graph_inv [simp]: "graph_map (map_graph f) = f"
  by (auto intro!:ext simp add:map_graph_def graph_map_def image_def)

lemma graph_map_empty[simp]: "graph_map {} = Map.empty"
  by (simp add:graph_map_def)

lemma graph_map_insert [simp]: "\<lbrakk>functional g; g``{x} \<subseteq> {y}\<rbrakk> \<Longrightarrow> graph_map (insert (x,y) g) = (graph_map g)(x \<mapsto> y)"
  by (rule ext, auto simp add:graph_map_def)

lemma dom_map_graph: "dom f = Domain(map_graph f)"
  by (simp add: map_graph_def dom_def image_def)

lemma ran_map_graph: "ran f = Range(map_graph f)"
  by (simp add: map_graph_def ran_def image_def)

lemma ran_map_add_subset:
  "ran (x ++ y) \<subseteq> (ran x) \<union> (ran y)"
  by (auto simp add:ran_def)

lemma finite_dom_graph: "finite (dom f) \<Longrightarrow> finite (map_graph f)"
  by (metis dom_map_graph finite_imageD fst_eq_Domain functional_def map_graph_functional)

lemma finite_dom_ran [simp]: "finite (dom f) \<Longrightarrow> finite (ran f)"
  by (metis finite_Range finite_dom_graph ran_map_graph)

lemma graph_map_inv [simp]: "functional g \<Longrightarrow> map_graph (graph_map g) = g"
  apply (auto simp add:map_graph_def graph_map_def functional_def)
    apply (metis (lifting, no_types) image_iff option.distinct(1) option.inject someI surjective_pairing)
   apply (simp add:inj_on_def)
   apply (metis fst_conv snd_conv some_equality)
  apply (metis (lifting) fst_conv image_iff)
  done

lemma graph_map_dom: "dom (graph_map R) = fst ` R"
  by (simp add: graph_map_def dom_def)

lemma graph_map_countable_dom: "countable R \<Longrightarrow> countable (dom (graph_map R))"
  by (simp add: graph_map_dom)

lemma countable_ran:
  assumes "countable (dom f)"
  shows "countable (ran f)"
proof -
  have "countable (map_graph f)"
    by (simp add: assms)
  then have "countable (Range(map_graph f))"
    by (simp add: Range_snd)
  thus ?thesis
    by (simp add: ran_map_graph)
qed

lemma map_graph_inv' [simp]:
  "graph_map' (map_graph f) = Some f"
  by (simp add: graph_map'_def)

lemma map_graph_inj:
  "inj map_graph"
  by (metis injI map_graph_inv)

lemma map_eq_graph: "f = g \<longleftrightarrow> map_graph f = map_graph g"
  by (auto simp add: inj_eq map_graph_inj)

lemma map_le_graph: "f \<subseteq>\<^sub>m g \<longleftrightarrow> map_graph f \<subseteq> map_graph g"
  by (force simp add: map_le_def map_graph_def)

lemma map_graph_comp: "map_graph (g \<circ>\<^sub>m f) = (map_graph f) O (map_graph g)"
  apply (auto simp add: map_comp_def map_graph_def relcomp_unfold)
  apply (rename_tac a b)
  apply (case_tac "f a", auto)
  done

subsection \<open> Map Application \<close>

definition map_apply :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>m" [999,0] 999) where
"map_apply = (\<lambda> f x. the (f x))"

subsection \<open> Map Membership \<close>

fun map_member :: "'a \<times> 'b \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<in>\<^sub>m" 50) where
"(k, v) \<in>\<^sub>m m \<longleftrightarrow> m(k) = Some(v)"

lemma map_ext:
  "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>m A \<longleftrightarrow> (x, y) \<in>\<^sub>m B \<rbrakk> \<Longrightarrow> A = B"
  by (rule ext, auto, metis not_Some_eq)

lemma map_member_alt_def:
  "(x, y) \<in>\<^sub>m A \<longleftrightarrow> (x \<in> dom A \<and> A(x)\<^sub>m = y)"
  by (auto simp add: map_apply_def)

lemma map_le_member:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> (\<forall> x y. (x,y) \<in>\<^sub>m f \<longrightarrow> (x,y) \<in>\<^sub>m g)"
  by (force simp add: map_le_def)

subsection \<open> Preimage \<close>

definition preimage :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set" where
"preimage f B = {x \<in> dom(f). the(f(x)) \<in> B}"

lemma preimage_range: "preimage f (ran f) = dom f"
  by (auto simp add: preimage_def ran_def)

lemma dom_preimage: "dom (m \<circ>\<^sub>m f) = preimage f (dom m)"
  apply (auto simp add: dom_def preimage_def)
   apply (meson map_comp_Some_iff)
  apply (metis map_comp_def option.case_eq_if option.distinct(1))
  done

lemma countable_preimage:
  "\<lbrakk> countable A; inj_on f (preimage f A) \<rbrakk> \<Longrightarrow> countable (preimage f A)"
  apply (auto simp add: countable_def)
  apply (rename_tac g)
  apply (rule_tac x="g \<circ> the \<circ> f" in exI)
  apply (rule inj_onI)
  apply (drule inj_onD)
     apply (auto simp add: preimage_def inj_onD)
  done

subsection \<open> Minus operation for maps \<close>

definition map_minus :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "--" 100)
where "map_minus f g = (\<lambda> x. if (f x = g x) then None else f x)"

lemma map_minus_apply [simp]: "y \<in> dom(f -- g) \<Longrightarrow> (f -- g)(y)\<^sub>m = f(y)\<^sub>m"
  by (auto simp add: map_minus_def dom_def map_apply_def)

lemma map_member_plus:
  "(x, y) \<in>\<^sub>m f ++ g \<longleftrightarrow> ((x \<notin> dom(g) \<and> (x, y) \<in>\<^sub>m f) \<or> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_add_Some_iff)

lemma map_member_minus:
  "(x, y) \<in>\<^sub>m f -- g \<longleftrightarrow> (x, y) \<in>\<^sub>m f \<and> (\<not> (x, y) \<in>\<^sub>m g)"
  by (auto simp add: map_minus_def)

lemma map_minus_plus_commute:
  "dom(g) \<inter> dom(h) = {} \<Longrightarrow> (f -- g) ++ h = (f ++ h) -- g"
  apply (rule map_ext)
  apply (auto simp add: map_member_plus map_member_minus simp del: map_member.simps)
  apply (auto simp add: map_member_alt_def)
  done

lemma map_graph_minus: "map_graph (f -- g) = map_graph f - map_graph g"
  by (auto simp add: map_minus_def map_graph_def, (meson option.distinct(1))+)

lemma map_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>m f; h \<subseteq>\<^sub>m g \<rbrakk> \<Longrightarrow> (f -- h = g -- h) = (f = g)"
  by (auto simp add: map_eq_graph map_graph_minus map_le_graph)

subsection \<open> Map Bind \<close>

text \<open> Create some extra intro/elim rules to help dealing with proof about option bind. \<close>

lemma option_bindSomeE [elim!]:
  "\<lbrakk> X >>= F = Some(v); \<And> x. \<lbrakk> X = Some(x); F(x) = Some(v) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac X, auto)

lemma option_bindSomeI [intro]:
  "\<lbrakk> X = Some(x); F(x) = Some(y) \<rbrakk> \<Longrightarrow> X >>= F = Some(y)"
  by (simp)

lemma ifSomeE [elim]: "\<lbrakk> (if c then Some(x) else None) = Some(y); \<lbrakk> c; x = y \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (case_tac c, auto)

subsection \<open> Range Restriction \<close>

text \<open>A range restriction operator; only domain restriction is provided in HOL.\<close>

definition ran_restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a \<rightharpoonup> 'b" ("_\<upharpoonleft>\<^bsub>_\<^esub>" [111,110] 110) where
"ran_restrict_map f B = (\<lambda>x. do { v <- f(x); if (v \<in> B) then Some(v) else None })"

lemma ran_restrict_empty [simp]: "f\<upharpoonleft>\<^bsub>{}\<^esub> = Map.empty"
  by (simp add:ran_restrict_map_def)

lemma ran_restrict_ran [simp]: "f\<upharpoonleft>\<^bsub>ran(f) \<^esub> = f"
  apply (auto simp add:ran_restrict_map_def ran_def)
  apply (rule ext)
  apply (case_tac "f(x)", auto)
  done

lemma ran_ran_restrict [simp]: "ran(f\<upharpoonleft>\<^bsub>B\<^esub>) = ran(f) \<inter> B"
  by (auto intro!:option_bindSomeI simp add:ran_restrict_map_def ran_def)

lemma dom_ran_restrict: "dom(f\<upharpoonleft>\<^bsub>B\<^esub>) \<subseteq> dom(f)"
  by (auto simp add:ran_restrict_map_def dom_def)

lemma ran_restrict_finite_dom [intro]:
  "finite(dom(f)) \<Longrightarrow> finite(dom(f\<upharpoonleft>\<^bsub>B\<^esub>))"
  by (metis finite_subset dom_ran_restrict)

lemma dom_Some [simp]: "dom (Some \<circ> f) = UNIV"
  by (auto)

lemma dom_left_map_add [simp]: "x \<in> dom g \<Longrightarrow> (f ++ g) x = g x"
  by (auto simp add:map_add_def dom_def)

lemma dom_right_map_add [simp]: "\<lbrakk> x \<notin> dom g; x \<in> dom f \<rbrakk> \<Longrightarrow> (f ++ g) x = f x"
  by (auto simp add:map_add_def dom_def)

lemma map_add_restrict:
  "f ++ g = (f |` (- dom g)) ++ g"
  by (rule ext, auto simp add: map_add_def restrict_map_def)

subsection \<open> Map Inverse and Identity \<close>

definition map_inv :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<rightharpoonup> 'a)" where
"map_inv f \<equiv> \<lambda> y. if (y \<in> ran f) then Some (SOME x. f x = Some y) else None"

definition map_id_on :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'a)" where
"map_id_on xs \<equiv> \<lambda> x. if (x \<in> xs) then Some x else None"

lemma map_id_on_in [simp]:
  "x \<in> xs \<Longrightarrow> map_id_on xs x = Some x"
  by (simp add:map_id_on_def)

lemma map_id_on_out [simp]:
  "x \<notin> xs \<Longrightarrow> map_id_on xs x = None"
  by (simp add:map_id_on_def)

lemma map_id_dom [simp]: "dom (map_id_on xs) = xs"
  by (simp add:dom_def map_id_on_def)

lemma map_id_ran [simp]: "ran (map_id_on xs) = xs"
  by (force simp add:ran_def map_id_on_def)

lemma map_id_on_UNIV[simp]: "map_id_on UNIV = Some"
  by (simp add:map_id_on_def)

lemma map_id_on_inj [simp]:
  "inj_on (map_id_on xs) xs"
  by (simp add:inj_on_def)

lemma map_inv_empty [simp]: "map_inv Map.empty = Map.empty"
  by (simp add:map_inv_def)

lemma map_inv_id [simp]:
  "map_inv (map_id_on xs) = map_id_on xs"
  by (force simp add:map_inv_def map_id_on_def ran_def)

lemma map_inv_Some [simp]: "map_inv Some = Some"
  by (simp add:map_inv_def ran_def)

lemma map_inv_f_f [simp]:
  "\<lbrakk> inj_on f (dom f); f x = Some y \<rbrakk> \<Longrightarrow> map_inv f y = Some x"
  apply (auto simp add: map_inv_def)
   apply (rule some_equality)
    apply (auto simp add:inj_on_def dom_def ran_def)
  done

lemma dom_map_inv [simp]:
  "dom (map_inv f) = ran f"
  by (auto simp add:map_inv_def)

lemma ran_map_inv [simp]:
  "inj_on f (dom f) \<Longrightarrow> ran (map_inv f) = dom f"
  apply (auto simp add:map_inv_def ran_def)
   apply (rename_tac a b)
   apply (rule_tac x="a" in exI)
   apply (force intro:someI)
  apply (rename_tac x y)
  apply (rule_tac x="y" in exI)
  apply (auto)
  apply (rule some_equality, simp_all)
  apply (auto simp add:inj_on_def dom_def)
  done

lemma dom_image_ran: "f ` dom f = Some ` ran f"
  by (auto simp add:dom_def ran_def image_def)

lemma inj_map_inv [intro]:
  "inj_on f (dom f) \<Longrightarrow> inj_on (map_inv f) (ran f)"
  apply (auto simp add:map_inv_def inj_on_def dom_def ran_def)
  apply (rename_tac x y u v)
  apply (frule_tac P="\<lambda> xa. f xa = Some x" in some_equality)
   apply (auto)
  apply (metis (mono_tags) option.sel someI)
  done

lemma inj_map_bij: "inj_on f (dom f) \<Longrightarrow> bij_betw f (dom f) (Some ` ran f)"
  by (auto simp add:inj_on_def dom_def ran_def image_def bij_betw_def)

lemma map_inv_map_inv [simp]:
  assumes "inj_on f (dom f)"
  shows "map_inv (map_inv f) = f"
proof -

  from assms have "inj_on (map_inv f) (ran f)"
    by auto

  thus ?thesis
    apply (rule_tac ext)
    apply (rename_tac x)
    apply (case_tac "\<exists> y. map_inv f y = Some x")
     apply (auto)[1]
     apply (simp add:map_inv_def)
     apply (rename_tac x y)
     apply (case_tac "y \<in> ran f", simp_all)
     apply (auto)
     apply (rule someI2_ex)
      apply (simp add:ran_def)
     apply (simp)
    apply (metis assms dom_image_ran dom_map_inv image_iff map_add_dom_app_simps(2) map_add_dom_app_simps(3) ran_map_inv)
    done
qed

lemma map_self_adjoin_complete [intro]:
  assumes "dom f \<inter> ran f = {}" "inj_on f (dom f)"
  shows "inj_on (map_inv f ++ f) (dom f \<union> ran f)"
  apply (rule inj_onI)
  apply (insert assms)
  apply (rename_tac x y)
  apply (case_tac "x \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> dom f")
    apply (simp add:inj_on_def)
   apply (case_tac "y \<in> ran f")
    apply (subgoal_tac "y \<in> dom (map_inv f)")
     apply (simp)
     apply (metis Int_iff domD empty_iff ranI ran_map_inv)
    apply (simp)
   apply (simp)
  apply (simp)
  apply (case_tac "y \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> ran f")
    apply (subgoal_tac "y \<in> dom (map_inv f)")
     apply (simp)
     apply (metis Int_iff empty_iff)
    apply (simp)
   apply (metis Int_iff domD empty_iff ranI ran_map_inv)
  apply (simp)
  apply (metis (lifting) inj_map_inv inj_on_contraD)
  done

lemma inj_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow> inj (Some ++ f)"
  apply (drule inj_map_bij)
  apply (auto simp add:bij_betw_def)
  apply (auto simp add:inj_on_def)[1]
  apply (rename_tac x y)
  apply (case_tac "x \<in> dom f")
   apply (simp)
   apply (case_tac "y \<in> dom f")
    apply (simp)
   apply (simp add:ran_def)
  apply (case_tac "y \<in> dom f")
   apply (auto intro:ranI)
  done

lemma bij_completed_map [intro]:
  "\<lbrakk> dom f = ran f; inj_on f (dom f) \<rbrakk> \<Longrightarrow>
   bij_betw (Some ++ f) UNIV (range Some)"
  apply (auto simp add:bij_betw_def)
   apply (rename_tac x)
   apply (case_tac "x \<in> dom f")
    apply (simp)
    apply (metis domD rangeI)
   apply (simp)
  apply (simp add:image_def)
  apply (metis (full_types) dom_image_ran dom_left_map_add image_iff map_add_dom_app_simps(3))
  done

lemma bij_map_Some:
  "bij_betw f a (Some ` b) \<Longrightarrow> bij_betw (the \<circ> f) a b"
  apply (simp add:bij_betw_def)
  apply (safe)
    apply (metis (hide_lams, no_types) comp_inj_on_iff f_the_inv_into_f inj_on_inverseI option.sel)
   apply (metis (hide_lams, no_types) image_iff option.sel)
  apply (metis Option.these_def Some_image_these_eq image_image these_image_Some_eq)
  done

lemma ran_map_add [simp]:
  "m`(dom m \<inter> dom n) = n`(dom m \<inter> dom n) \<Longrightarrow>
   ran(m++n) = ran n \<union> ran m"
  apply (auto simp add:ran_def)
   apply (metis map_add_find_right)
  apply (rename_tac x a)
  apply (case_tac "a \<in> dom n")
   apply (subgoal_tac "\<exists> b. n b = Some x")
    apply (auto)
    apply (rename_tac x a b y)
    apply (rule_tac x="b" in exI)
    apply (simp)
   apply (metis (hide_lams, no_types) IntI domI image_iff)
  apply (metis (full_types) map_add_None map_add_dom_app_simps(1) map_add_dom_app_simps(3) not_None_eq)
  done

lemma ran_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow> ran [xs [\<mapsto>] ys] = set ys"
    by (induct rule:list_induct2, simp_all)

lemma inj_map_add:
  "\<lbrakk> inj_on f (dom f); inj_on g (dom g); ran f \<inter> ran g = {} \<rbrakk> \<Longrightarrow>
   inj_on (f ++ g) (dom f \<union> dom g)"
  apply (auto simp add:inj_on_def)
      apply (metis (full_types) disjoint_iff_not_equal domI dom_left_map_add map_add_dom_app_simps(3) ranI)
     apply (metis domI)
    apply (metis disjoint_iff_not_equal ranI)
   apply (metis disjoint_iff_not_equal domIff map_add_Some_iff ranI)
  apply (metis domI)
  done

lemma map_inv_add [simp]:
  assumes "inj_on f (dom f)" "inj_on g (dom g)"
          "dom f \<inter> dom g = {}" "ran f \<inter> ran g = {}"
  shows "map_inv (f ++ g) = map_inv f ++ map_inv g"
proof (rule ext)

  from assms have minj: "inj_on (f ++ g) (dom (f ++ g))"
    by (simp, metis inj_map_add sup_commute)

  fix x
  have "x \<in> ran g \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<in> ran g"
    then obtain y where dom:"g y = Some x" "y \<in> dom g"
      by (auto simp add:ran_def)

    hence "(f ++ g) y = Some x"
      by simp

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover have "\<lbrakk> x \<notin> ran g; x \<in> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
  proof -
    assume ran:"x \<notin> ran g" "x \<in> ran f"
    with assms obtain y where dom:"f y = Some x" "y \<in> dom f" "y \<notin> dom g"
      by (auto simp add:ran_def)

    with ran have "(f ++ g) y = Some x"
      by (simp)

    with assms minj ran dom show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
      by simp
  qed

  moreover from assms minj have "\<lbrakk> x \<notin> ran g; x \<notin> ran f \<rbrakk> \<Longrightarrow> map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (auto simp add:map_inv_def ran_def map_add_def)
    apply (metis dom_left_map_add map_add_def map_add_dom_app_simps(3))
    done

  ultimately show "map_inv (f ++ g) x = (map_inv f ++ map_inv g) x"
    apply (case_tac "x \<in> ran g")
     apply (simp)
    apply (case_tac "x \<in> ran f")
     apply (simp_all)
    done
qed

lemma map_add_lookup [simp]:
  "x \<notin> dom f \<Longrightarrow> ([x \<mapsto> y] ++ f) x = Some y"
  by (simp add:map_add_def dom_def)

lemma map_add_Some: "Some ++ f = map_id_on (- dom f) ++ f"
  apply (rule ext)
  apply (rename_tac x)
  apply (case_tac "x \<in> dom f")
   apply (simp_all)
  done

lemma distinct_map_dom:
  "x \<notin> set xs \<Longrightarrow> x \<notin> dom [xs [\<mapsto>] ys]"
  by (simp add:dom_def)

lemma distinct_map_ran:
  "\<lbrakk> distinct xs; y \<notin> set ys; length xs = length ys \<rbrakk> \<Longrightarrow>
   y \<notin> ran ([xs [\<mapsto>] ys])"
  apply (simp add:map_upds_def)
  apply (subgoal_tac "distinct (map fst (rev (zip xs ys)))")
  apply (simp add:ran_distinct)
  apply (metis (hide_lams, no_types) image_iff set_zip_rightD surjective_pairing)
  apply (simp add:zip_rev[THEN sym])
done

lemma maplets_lookup[rule_format,dest]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
     \<forall> y. [xs [\<mapsto>] ys] x = Some y \<longrightarrow> y \<in> set ys"
  by (induct rule:list_induct2, auto)

lemma maplets_distinct_inj [intro]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
   inj_on [xs [\<mapsto>] ys] (set xs)"
  apply (induct rule:list_induct2)
   apply (simp_all)
  apply (rule conjI)
   apply (rule inj_onI)
   apply (rename_tac x xs y ys xa ya)
   apply (case_tac "xa = x")
    apply (simp)
   apply (case_tac "xa = y")
    apply (simp)
   apply (simp)
   apply (case_tac "ya = x")
    apply (simp)
   apply (simp add:inj_on_def)
  apply (auto)
  apply (rename_tac x xs y ys xa)
  apply (case_tac "xa = y")
   apply (simp)
  apply (metis maplets_lookup)
  done

lemma map_inv_maplet[simp]: "map_inv [x \<mapsto> y] = [y \<mapsto> x]"
  by (auto simp add:map_inv_def)

lemma map_inv_maplets [simp]:
  "\<lbrakk> length xs = length ys; distinct xs; distinct ys; set xs \<inter> set ys = {} \<rbrakk> \<Longrightarrow>
  map_inv [xs [\<mapsto>] ys] = [ys [\<mapsto>] xs]"
  apply (induct rule:list_induct2)
   apply (simp_all)
  apply (rename_tac x xs y ys)
  apply (subgoal_tac "map_inv ([xs [\<mapsto>] ys] ++ [x \<mapsto> y]) = map_inv [xs [\<mapsto>] ys] ++ map_inv [x \<mapsto> y]")
   apply (simp)
  apply (rule map_inv_add)
     apply (auto)
  done

lemma maplets_lookup_nth [rule_format,simp]:
  "\<lbrakk> length xs = length ys; distinct xs \<rbrakk> \<Longrightarrow>
   \<forall> i < length ys. [xs [\<mapsto>] ys] (xs ! i) = Some (ys ! i)"
  apply (induct rule:list_induct2)
   apply (auto)
   apply (rename_tac x xs y ys i)
   apply (case_tac i)
    apply (simp_all)
   apply (metis nth_mem)
  apply (rename_tac x xs y ys i)
  apply (case_tac i)
   apply (auto)
  done

theorem inv_map_inv:
  "\<lbrakk> inj_on f (dom f); ran f = dom f \<rbrakk>
  \<Longrightarrow> inv (the \<circ> (Some ++ f)) = the \<circ> map_inv (Some ++ f)"
  apply (rule ext)
  apply (simp add:map_add_Some)
  apply (simp add:inv_def)
  apply (rename_tac x)
  apply (case_tac "\<exists> y. f y = Some x")
   apply (erule exE)
   apply (rename_tac x y)
   apply (subgoal_tac "x \<in> ran f")
    apply (subgoal_tac "y \<in> dom f")
     apply (simp)
     apply (rule some_equality)
      apply (simp)
     apply (metis (hide_lams, mono_tags) domD domI dom_left_map_add inj_on_contraD map_add_Some map_add_dom_app_simps(3) option.sel)
    apply (simp add:dom_def)
   apply (metis ranI)
  apply (simp)
  apply (rename_tac x)
  apply (subgoal_tac "x \<notin> ran f")
   apply (simp)
   apply (rule some_equality)
    apply (simp)
   apply (metis domD dom_left_map_add map_add_Some map_add_dom_app_simps(3) option.sel)
  apply (metis dom_image_ran image_iff)
  done

lemma map_comp_dom: "dom (g \<circ>\<^sub>m f) \<subseteq> dom f"
  by (metis (lifting, full_types) Collect_mono dom_def map_comp_simps(1))

lemma map_comp_assoc: "f \<circ>\<^sub>m (g \<circ>\<^sub>m h) = f \<circ>\<^sub>m g \<circ>\<^sub>m h"
proof
  fix x
  show "(f \<circ>\<^sub>m (g \<circ>\<^sub>m h)) x = (f \<circ>\<^sub>m g \<circ>\<^sub>m h) x"
  proof (cases "h x")
    case None thus ?thesis
      by (auto simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (auto simp add: map_comp_def)
  qed
qed

lemma map_comp_runit [simp]: "f \<circ>\<^sub>m Some = f"
  by (simp add: map_comp_def)

lemma map_comp_lunit [simp]: "Some \<circ>\<^sub>m f = f"
proof
  fix x
  show "(Some \<circ>\<^sub>m f) x = f x"
  proof (cases "f x")
    case None thus ?thesis
      by (simp add: map_comp_def)
  next
    case (Some y) thus ?thesis
      by (simp add: map_comp_def)
  qed
qed

lemma map_comp_apply [simp]: "(f \<circ>\<^sub>m g) x = g(x) >>= f"
  by (auto simp add: map_comp_def option.case_eq_if)

subsection \<open> Merging of compatible maps \<close>

definition comp_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infixl "\<parallel>\<^sub>m" 60) where
"comp_map f g = (\<forall> x \<in> dom(f) \<inter> dom(g). the(f(x)) = the(g(x)))"

lemma comp_map_unit: "Map.empty \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_refl: "f \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

lemma comp_map_sym: "f \<parallel>\<^sub>m g \<Longrightarrow> g \<parallel>\<^sub>m f"
  by (simp add: comp_map_def)

definition merge :: "('a \<rightharpoonup> 'b) set \<Rightarrow> 'a \<rightharpoonup> 'b" where
"merge fs =
  (\<lambda> x. if (\<exists> f \<in> fs. x \<in> dom(f)) then (THE y. \<forall> f \<in> fs. x \<in> dom(f) \<longrightarrow> f(x) = y) else None)"

lemma merge_empty: "merge {} = Map.empty"
  by (simp add: merge_def)

lemma merge_singleton: "merge {f} = f"
  apply (auto intro!: ext simp add: merge_def)
  using option.collapse apply fastforce
  done

subsection \<open> Conversion between lists and maps \<close>

definition map_of_list :: "'a list \<Rightarrow> (nat \<rightharpoonup> 'a)" where
"map_of_list xs = (\<lambda> i. if (i < length xs) then Some (xs!i) else None)"

lemma map_of_list_nil [simp]: "map_of_list [] = Map.empty"
  by (simp add: map_of_list_def)

lemma dom_map_of_list [simp]: "dom (map_of_list xs) = {0..<length xs}"
  by (auto simp add: map_of_list_def dom_def)

lemma ran_map_of_list [simp]: "ran (map_of_list xs) = set xs"
  apply (simp add: ran_def map_of_list_def)
  apply (safe)
   apply (force)
  apply (meson in_set_conv_nth)
  done

definition list_of_map :: "(nat \<rightharpoonup> 'a) \<Rightarrow> 'a list" where
"list_of_map f = (if (f = Map.empty) then [] else map (the \<circ> f) [0 ..< Suc(GREATEST x. x \<in> dom f)])"

lemma list_of_map_empty [simp]: "list_of_map Map.empty = []"
  by (simp add: list_of_map_def)

definition list_of_map' :: "(nat \<rightharpoonup> 'a) \<rightharpoonup> 'a list" where
"list_of_map' f = (if (\<exists> n. dom f = {0..<n}) then Some (list_of_map f) else None)"

lemma map_of_list_inv [simp]: "list_of_map (map_of_list xs) = xs"
proof (cases "xs = []")
  case True thus ?thesis by (simp)
next
  case False
  moreover hence "(GREATEST x. x \<in> dom (map_of_list xs)) = length xs - 1"
    by (auto intro: Greatest_equality)
  moreover from False have "map_of_list xs \<noteq> Map.empty"
    by (metis ran_empty ran_map_of_list set_empty)
  ultimately show ?thesis
    by (auto simp add: list_of_map_def map_of_list_def intro: nth_equalityI)
qed

subsection \<open> Map Comprehension \<close>

text \<open> Map comprehension simply converts a relation built through set comprehension into a map. \<close>

syntax
  "_Mapcompr" :: "'a \<Rightarrow> 'b \<Rightarrow> idts \<Rightarrow> bool \<Rightarrow> 'a \<rightharpoonup> 'b"    ("(1[_ \<mapsto> _ |/_./ _])")

translations
  "_Mapcompr F G xs P" == "CONST graph_map {(F, G) | xs. P}"

lemma map_compr_eta:
  "[x \<mapsto> y | x y. (x, y) \<in>\<^sub>m f] = f"
  apply (rule ext)
  apply (auto simp add: graph_map_def)
  apply (metis (mono_tags, lifting) Domain.DomainI fst_eq_Domain mem_Collect_eq old.prod.case option.distinct(1) option.expand option.sel)
  done

lemma map_compr_simple:
  "[x \<mapsto> F x y | x y. (x, y) \<in>\<^sub>m f] = (\<lambda> x. do { y \<leftarrow> f(x); Some(F x y) })"
  apply (rule ext)
  apply (auto simp add: graph_map_def image_Collect)
  done

lemma map_compr_dom_simple [simp]:
  "dom [x \<mapsto> f x | x. P x] = {x. P x}"
  by (force simp add: graph_map_dom image_Collect)

lemma map_compr_ran_simple [simp]:
  "ran [x \<mapsto> f x | x. P x] = {f x | x. P x}"
  apply (auto simp add: graph_map_def ran_def)
  apply (metis (mono_tags, lifting) fst_eqD image_eqI mem_Collect_eq someI)
  done

lemma map_compr_eval_simple [simp]:
  "[x \<mapsto> f x | x. P x] x = (if (P x) then Some (f x) else None)"
  by (auto simp add: graph_map_def image_Collect)

subsection \<open> Sorted lists from maps \<close>

definition sorted_list_of_map :: "('a::linorder \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) list" where
"sorted_list_of_map f = map (\<lambda> k. (k, the (f k))) (sorted_list_of_set(dom(f)))"

lemma sorted_list_of_map_empty [simp]:
  "sorted_list_of_map Map.empty = []"
  by (simp add: sorted_list_of_map_def)

lemma sorted_list_of_map_inv:
  assumes "finite(dom(f))"
  shows "map_of (sorted_list_of_map f) = f"
proof -
  obtain A where "finite A" "A = dom(f)"
    by (simp add: assms)
  thus ?thesis
  proof (induct A rule: finite_induct)
    case empty thus ?thesis
      by (simp add: sorted_list_of_map_def, metis dom_empty empty_iff map_le_antisym map_le_def)
  next
    case (insert x A) thus ?thesis
      by (simp add: assms sorted_list_of_map_def map_of_map_keys)
  qed
qed

declare map_member.simps [simp del]

subsection \<open> Extra map lemmas \<close>

lemma map_eqI:
  "\<lbrakk> dom f = dom g; \<forall> x\<in>dom(f). the(f x) = the(g x) \<rbrakk> \<Longrightarrow> f = g"
  by (metis domIff map_le_antisym map_le_def option.expand)

lemma map_restrict_dom [simp]: "f |` dom f = f"
  by (simp add: map_eqI)

lemma map_restrict_dom_compl: "f |` (- dom f) = Map.empty"
  by (metis dom_eq_empty_conv dom_restrict inf_compl_bot)

lemma restrict_map_neg_disj:
  "dom(f) \<inter> A = {} \<Longrightarrow> f |` (- A) = f"
  by (auto simp add: restrict_map_def, rule ext, auto, metis disjoint_iff_not_equal domIff)

lemma map_plus_restrict_dist: "(f ++ g) |` A = (f |` A) ++ (g |` A)"
  by (auto simp add: restrict_map_def map_add_def)

lemma map_plus_eq_left:
  assumes "f ++ h = g ++ h"
  shows "(f |` (- dom h)) = (g |` (- dom h))"
proof -
  have "h |` (- dom h) = Map.empty"
    by (metis Compl_disjoint dom_eq_empty_conv dom_restrict)
  then have f2: "f |` (- dom h) = (f ++ h) |` (- dom h)"
    by (simp add: map_plus_restrict_dist)
  have "h |` (- dom h) = Map.empty"
    by (metis (no_types) Compl_disjoint dom_eq_empty_conv dom_restrict)
  then show ?thesis
    using f2 assms by (simp add: map_plus_restrict_dist)
qed

lemma map_add_split:
  "dom(f) = A \<union> B \<Longrightarrow> (f |` A) ++ (f |` B) = f"
  by (rule ext, auto simp add: map_add_def restrict_map_def option.case_eq_if)

lemma map_le_via_restrict:
  "f \<subseteq>\<^sub>m g \<longleftrightarrow> g |` dom(f) = f"
  by (auto simp add: map_le_def restrict_map_def dom_def fun_eq_iff)

lemma map_add_cancel:
  "f \<subseteq>\<^sub>m g \<Longrightarrow> f ++ (g -- f) = g"
  by (auto simp add: map_le_def map_add_def map_minus_def fun_eq_iff option.case_eq_if)
     (metis domIff)

lemma map_le_iff_add: "f \<subseteq>\<^sub>m g \<longleftrightarrow> (\<exists> h. dom(f) \<inter> dom(h) = {} \<and> f ++ h = g)"
  apply (auto)
  apply (rule_tac x="g -- f" in exI)
  apply (metis (no_types, lifting) Int_emptyI domIff map_add_cancel map_le_def map_minus_def)
  apply (simp add: map_add_comm)
  done

lemma map_add_comm_weak: "(\<forall> k \<in> dom m1 \<inter> dom m2. m1(k) = m2(k)) \<Longrightarrow> m1 ++ m2 = m2 ++ m1"
  by (auto simp add: map_add_def option.case_eq_if fun_eq_iff)
     (metis IntI domI option.inject)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_06
imports "../../Test_Base" "../../../src/Build_Database/Build_Database"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
"t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) y = Z"
| "t2 (S z) (Z) = S z"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "((t2 n (t22 n m)) = Z)"
  find_proof DInd
  apply (induct n (*arbitrary: m*))
  apply auto
  done

theorem property0' :
  "((t2 n (t22 n m)) = Z)"
  apply(induct n m arbitrary: m rule:t22.induct)
   apply auto
  done

theorem property0'' :
  "((t2 n (t22 n m)) = Z)"
  find_proof DInd
  apply (induct n arbitrary: m)
  apply auto
  done

end


(*  Title:      HOL/Library/Char_ord.thy
    Author:     Norbert Voelker, Florian Haftmann
*)

section \<open>Order on characters\<close>

theory Char_ord
  imports MainRLT
begin

instantiation char :: linorder
begin

definition less_eq_char :: "char \<Rightarrow> char \<Rightarrow> bool"
  where "c1 \<le> c2 \<longleftrightarrow> of_char c1 \<le> (of_char c2 :: nat)"

definition less_char :: "char \<Rightarrow> char \<Rightarrow> bool"
  where "c1 < c2 \<longleftrightarrow> of_char c1 < (of_char c2 :: nat)"

instance
  by standard (auto simp add: less_eq_char_def less_char_def)

end

lemma less_eq_char_simp [simp]:
  "Char b0 b1 b2 b3 b4 b5 b6 b7 \<le> Char c0 c1 c2 c3 c4 c5 c6 c7
    \<longleftrightarrow> foldr (\<lambda>b k. of_bool b + k * 2) [b0, b1, b2, b3, b4, b5, b6, b7] 0
      \<le> foldr (\<lambda>b k. of_bool b + k * 2) [c0, c1, c2, c3, c4, c5, c6, c7] (0::nat)"
  by (simp add: less_eq_char_def)

lemma less_char_simp [simp]:
  "Char b0 b1 b2 b3 b4 b5 b6 b7 < Char c0 c1 c2 c3 c4 c5 c6 c7
    \<longleftrightarrow> foldr (\<lambda>b k. of_bool b + k * 2) [b0, b1, b2, b3, b4, b5, b6, b7] 0
      < foldr (\<lambda>b k. of_bool b + k * 2) [c0, c1, c2, c3, c4, c5, c6, c7] (0::nat)"
  by (simp add: less_char_def)

instantiation char :: distrib_lattice
begin

definition "(inf :: char \<Rightarrow> _) = min"
definition "(sup :: char \<Rightarrow> _) = max"

instance
  by standard (auto simp add: inf_char_def sup_char_def max_min_distrib2)

end

end


(* Title:      Omega Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Omega Algebras\<close>

theory Omega_Algebra
imports Kleene_Algebra
begin

text \<open>
\emph{Omega algebras}~\cite{cohen00omega} extend Kleene algebras by an
$\omega$-operation that axiomatizes infinite iteration (just like the
Kleene star axiomatizes finite iteration).
\<close>

subsection \<open>Left Omega Algebras\<close>

text \<open>
In this section we consider \emph{left omega algebras}, i.e., omega
algebras based on left Kleene algebras. Surprisingly, we are still
looking for statements mentioning~$\omega$ that are true in omega
algebras, but do not already hold in left omega algebras.
\<close>

class left_omega_algebra = left_kleene_algebra_zero + omega_op +
  assumes omega_unfold: "x\<^sup>\<omega> \<le> x \<cdot> x\<^sup>\<omega>"
  and omega_coinduct: "y \<le> z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
begin

text \<open>First we prove some variants of the coinduction axiom.\<close>

lemma omega_coinduct_var1: "y \<le> 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  using local.omega_coinduct by fastforce

lemma  omega_coinduct_var2: "y \<le> x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis add.commute add_zero_l annir omega_coinduct)

lemma omega_coinduct_eq: "y = z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (simp add: local.omega_coinduct)

lemma omega_coinduct_eq_var1: "y = 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (simp add: omega_coinduct_var1)

lemma  omega_coinduct_eq_var2: "y = x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (simp add: omega_coinduct_var2)

lemma "y = x \<cdot> y + z \<Longrightarrow> y = x\<^sup>\<star> \<cdot> z + x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

lemma "y = 1 + x \<cdot> y \<Longrightarrow> y = x\<^sup>\<omega> + x\<^sup>\<star>"
  (* nitpick [expect=genuine] -- "3-element counterexample" *)
oops

lemma "y = x \<cdot> y \<Longrightarrow> y = x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

text \<open>Next we strengthen the unfold law to an equation.\<close>

lemma omega_unfold_eq [simp]: "x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (simp add: local.mult_isol local.omega_unfold mult_assoc)
  thus "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_var2)
  show  "x\<^sup>\<omega> \<le> x \<cdot> x\<^sup>\<omega>"
    by (fact omega_unfold)
qed

lemma omega_unfold_var: "z + x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (simp add: local.omega_coinduct)

lemma "z + x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>We now prove subdistributivity and isotonicity of omega.\<close>

lemma omega_subdist: "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<le> (x + y) \<cdot> x\<^sup>\<omega>"
    by simp
  thus ?thesis
    by (rule omega_coinduct_var2)
qed

lemma omega_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (metis less_eq_def omega_subdist)

lemma omega_subdist_var: "x\<^sup>\<omega> + y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (simp add: omega_iso)

lemma zero_omega [simp]: "0\<^sup>\<omega> = 0"
  by (metis annil omega_unfold_eq)

text \<open>The next lemma is another variant of omega unfold\<close>

lemma star_omega_1 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by simp
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by simp
  show "x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    using local.star_inductl_var_eq2 by auto
qed

text \<open>The next lemma says that~@{term "1\<^sup>\<omega>"} is the maximal element
of omega algebra. We therefore baptise it~$\top$.\<close>

lemma max_element: "x \<le> 1\<^sup>\<omega>"
  by (simp add: omega_coinduct_eq_var2)

definition top ("\<top>")
  where "\<top> = 1\<^sup>\<omega>"

lemma star_omega_3 [simp]: "(x\<^sup>\<star>)\<^sup>\<omega> = \<top>"
proof -
  have "1 \<le> x\<^sup>\<star>"
    by (fact star_ref)
  hence "\<top> \<le> (x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: omega_iso top_def)
  thus ?thesis
    by (simp add: local.order.antisym max_element top_def)
qed

text \<open>The following lemma is strange since it is counterintuitive
that one should be able to append something after an infinite
iteration.\<close>

lemma omega_1: "x\<^sup>\<omega> \<cdot> y \<le> x\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<cdot> y \<le> x \<cdot> x\<^sup>\<omega> \<cdot> y"
    by simp
  thus ?thesis
    by (metis mult.assoc omega_coinduct_var2)
qed

lemma "x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  (*nitpick [expect=genuine] -- "2-element counterexample"*)
oops

lemma omega_sup_id: "1 \<le> y \<Longrightarrow> x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  using local.eq_iff local.mult_isol omega_1 by fastforce

lemma omega_top [simp]: "x\<^sup>\<omega> \<cdot> \<top> = x\<^sup>\<omega>"
  by (simp add: max_element omega_sup_id top_def)

lemma supid_omega: "1 \<le> x \<Longrightarrow> x\<^sup>\<omega> = \<top>"
  by (simp add: local.order.antisym max_element omega_iso top_def)

lemma "x\<^sup>\<omega> = \<top> \<Longrightarrow> 1 \<le> x"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>Next we prove a simulation law for the omega operation\<close>

lemma omega_simulation: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
proof -
  assume hyp: "z \<cdot> x \<le> y \<cdot> z"
  have "z \<cdot> x\<^sup>\<omega> = z \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (simp add: mult_assoc)
  also have "... \<le> y \<cdot> z \<cdot> x\<^sup>\<omega>"
    by (simp add: hyp local.mult_isor)
  finally show "z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_var2)
qed

lemma "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<cdot> z"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

lemma "y \<cdot> z  \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<omega> \<le> z \<cdot> x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

lemma "y \<cdot> z  \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<omega> \<cdot> z \<le> x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>Next we prove transitivity of omega elements.\<close>

lemma omega_omega: "(x\<^sup>\<omega>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_1 omega_unfold_eq)

(*
lemma "x\<^sup>\<omega> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
nitpick -- "no proof, no counterexample"

lemma "(x\<^sup>\<omega>)\<^sup>\<omega> = x\<^sup>\<omega>"
nitpick -- "no proof, no counterexample"
*)

text \<open>The next lemmas are axioms of Wagner's complete axiomatisation
for omega-regular languages~\cite{Wagner77omega}, but in a slightly
different setting.\<close>

lemma wagner_1 [simp]: "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x \<cdot> x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: local.star_slide_var mult_assoc)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc)
  also have "... = x \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc)
  thus "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    using calculation omega_coinduct_eq_var2 by auto
   show "x\<^sup>\<omega> \<le> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_eq_var2)
qed

lemma wagner_2_var: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
proof -
  have "x \<cdot> y \<cdot> x \<le> x \<cdot> y \<cdot> x"
    by auto
  thus "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (simp add: mult_assoc omega_simulation)
qed

lemma wagner_2 [simp]: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> = (x \<cdot> y)\<^sup>\<omega>"
proof (rule antisym)
  show "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (rule wagner_2_var)
  have "(x \<cdot> y)\<^sup>\<omega> = x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<omega>"
    by simp
  thus "(x \<cdot> y)\<^sup>\<omega> \<le> x \<cdot> (y \<cdot> x)\<^sup>\<omega>"
    by (metis mult.assoc mult_isol wagner_2_var)
qed

text \<open>
This identity is called~(A8) in Wagner's paper.
\<close>

lemma wagner_3:
assumes "x \<cdot> (x + y)\<^sup>\<omega> + z = (x + y)\<^sup>\<omega>"
shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
proof (rule antisym)
  show  "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    using assms local.join.sup_commute omega_coinduct_eq by auto
  have "x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    using assms local.join.sup_commute local.star_inductl_eq by auto
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (simp add: omega_subdist)
qed

text \<open>
This identity is called~(R4) in Wagner's paper.
\<close>

lemma wagner_1_var [simp]: "(x\<^sup>\<star> \<cdot> x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (simp add: local.star_slide_var)

lemma star_omega_4 [simp]: "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega>"
proof (rule antisym)
  have "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
  also have "... \<le> 1 + x\<^sup>\<omega> \<cdot> \<top>"
    by (simp add: omega_sup_id)
  finally show "(x\<^sup>\<omega>)\<^sup>\<star> \<le> 1 + x\<^sup>\<omega>"
    by simp
  show "1 + x\<^sup>\<omega> \<le> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
qed

lemma star_omega_5 [simp]: "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> = x\<^sup>\<omega>"
proof (rule antisym)
  show "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> \<le> x\<^sup>\<omega>"
    by (rule omega_1)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (simp add: omega_sup_id)
qed

text \<open>The next law shows how omegas below a sum can be unfolded.\<close>

lemma omega_sum_unfold: "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<omega> = (x + y)\<^sup>\<omega>"
proof -
  have "(x + y)\<^sup>\<omega> = x \<cdot> (x + y)\<^sup>\<omega> + y \<cdot> (x+y)\<^sup>\<omega>"
    by (metis distrib_right omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc wagner_3)
qed

text \<open>
The next two lemmas apply induction and coinduction to this law.
\<close>

lemma omega_sum_unfold_coind: "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
  by (simp add: omega_coinduct_eq omega_sum_unfold)

lemma omega_sum_unfold_ind: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (simp add: local.star_inductl_eq omega_sum_unfold)

lemma wagner_1_gen: "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> ((x + y) \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<omega>"
    using local.join.le_sup_iff local.join.sup.cobounded1 local.mult_isol_var local.star_subdist_var omega_iso by presburger
  thus ?thesis
    by (metis wagner_1)
qed

lemma wagner_1_var_gen: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by simp
  also have "... \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute mult_isol wagner_1_gen)
  also have "... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using local.mult_isor local.star_subdist by auto
  thus ?thesis
    by (metis calculation order_trans star_omega_1)
qed

text \<open>The next lemma is a variant of the denest law for the star at
the level of omega.\<close>

lemma omega_denest [simp]: "(x + y)\<^sup>\<omega> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
proof (rule antisym)
  show "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (rule omega_sum_unfold_coind)
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le>  (x + y)\<^sup>\<omega>"
    by (rule wagner_1_var_gen)
  hence "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (simp add: omega_sum_unfold_ind)
  thus "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (simp add: wagner_1_var_gen)
qed

text \<open>The next lemma yields a separation theorem for infinite
iteration in the presence of a quasicommutation property. A
nondeterministic loop over~@{term x} and~@{term y} can be refined into
separate infinite loops over~@{term x} and~@{term y}.\<close>

lemma omega_sum_refine:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
proof (rule antisym)
  have a: "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using assms local.quasicomm_var by blast
  have "(x + y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute omega_sum_unfold)
  also have "... \<le> y\<^sup>\<omega> + x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using a local.join.sup_mono local.mult_isol_var by blast
  also have "... \<le> x \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    using local.eq_refl local.join.sup_commute mult_assoc star_omega_1 by presburger
  finally show "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
    by (metis add_commute local.omega_coinduct)
  have "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega> + (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using local.join.sup.cobounded2 local.join.sup.mono local.mult_isol_var local.star_subdist omega_iso omega_subdist by presburger
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (metis local.join.sup_idem star_omega_1)
qed

text \<open>The following theorem by Bachmair and
Dershowitz~\cite{bachmair86commutation} is a corollary.\<close>

lemma bachmair_dershowitz:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = 0 \<longleftrightarrow> x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
  by (metis add_commute assms local.annir local.join.le_bot local.no_trivial_inverse omega_subdist omega_sum_refine)

text \<open>
The next lemmas consider an abstract variant of the empty word
property from language theory and match it with the absence of
infinite iteration~\cite{struth12regeq}.
\<close>

definition (in dioid_one_zero) ewp
where "ewp x \<equiv> \<not>(\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0)"

lemma ewp_super_id1: "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<Longrightarrow> ewp x"
  by (metis ewp_def mult_oner)

lemma "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<longleftrightarrow> ewp x"
  (* nitpick [expect=genuine] -- "3-element counterexample" *)
oops

text \<open>The next facts relate the absence of the empty word property
with the absence of infinite iteration.\<close>

lemma ewp_neg_and_omega: "\<not> ewp x \<longleftrightarrow> x\<^sup>\<omega> = 0"
proof
  assume "\<not> ewp x"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    by (meson ewp_def)
  thus "x\<^sup>\<omega> = 0"
    by simp
next
  assume "x\<^sup>\<omega> = 0"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    using local.join.le_bot local.omega_coinduct_var2 by blast
  thus "\<not> ewp x"
    by (meson ewp_def)
qed

lemma ewp_alt1: "(\<forall>z. x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> z) \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis add_comm less_eq_def omega_coinduct omega_unfold_eq order_prop)

lemma ewp_alt: "x\<^sup>\<omega> = 0 \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis annir antisym ewp_alt1 join.bot_least)

text \<open>So we have obtained a condition for Arden's lemma in omega
algebra.\<close>

lemma omega_super_id1: "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<Longrightarrow> x\<^sup>\<omega> \<noteq> 0"
  using ewp_neg_and_omega ewp_super_id1 by blast

lemma omega_super_id2: "0 \<noteq> 1 \<Longrightarrow> x\<^sup>\<omega> = 0 \<Longrightarrow> \<not>(1 \<le> x)"
  using omega_super_id1 by blast

text \<open>The next lemmas are abstract versions of Arden's lemma from
language theory.\<close>

lemma ardens_lemma_var:
  assumes "x\<^sup>\<omega> = 0"
  and "z + x \<cdot> y = y"
  shows "x\<^sup>\<star> \<cdot> z = y"
proof -
  have "y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (simp add: assms(2) local.omega_coinduct_eq)
  hence "y \<le> x\<^sup>\<star> \<cdot> z"
    by (simp add: assms(1))
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (simp add: assms(2) local.eq_iff local.star_inductl_eq)
qed

lemma ardens_lemma: "\<not> ewp x \<Longrightarrow> z + x \<cdot> y = y \<Longrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (simp add: ardens_lemma_var ewp_neg_and_omega)

lemma ardens_lemma_equiv:
  assumes "\<not> ewp x"
  shows "z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (metis ardens_lemma_var assms ewp_neg_and_omega local.conway.dagger_unfoldl_distr mult_assoc)

lemma ardens_lemma_var_equiv: "x\<^sup>\<omega> = 0 \<Longrightarrow> (z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y)"
  by (simp add: ardens_lemma_equiv ewp_neg_and_omega)

lemma arden_conv1: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<Longrightarrow> \<not> ewp x"
  by (metis add_zero_l annir ewp_neg_and_omega omega_unfold_eq)

lemma arden_conv2: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<Longrightarrow> x\<^sup>\<omega> = 0"
  using arden_conv1 ewp_neg_and_omega by blast

lemma arden_var3: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longleftrightarrow> x\<^sup>\<omega> = 0"
  using arden_conv2 ardens_lemma_var by blast

end

subsection \<open>Omega Algebras\<close>

class omega_algebra = kleene_algebra + left_omega_algebra

end


section \<open>Farkas' Lemma\<close>

text \<open>We prove two variants of Farkas' lemma. Note that type here is more general than in the versions
  of Farkas' Lemma which are in the AFP-entry Farkas-Lemma, which is restricted to rational matrices.
  However, there $\delta$-rationals are supported, which are not present here.\<close>

theory Farkas_Lemma
  imports Fundamental_Theorem_Linear_Inequalities
begin

context gram_schmidt
begin

lemma Farkas_Lemma: fixes A :: "'a mat" and b :: "'a vec"
  assumes A: "A \<in> carrier_mat n nr" and b: "b \<in> carrier_vec n"
  shows "(\<exists> x. x \<ge> 0\<^sub>v nr \<and> A *\<^sub>v x = b) \<longleftrightarrow> (\<forall> y. y \<in> carrier_vec n \<longrightarrow> A\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v nr \<longrightarrow> y \<bullet> b \<ge> 0)"
proof -
  let ?C = "set (cols A)"
  from A have C: "?C \<subseteq> carrier_vec n" and C': " \<forall>w\<in>set (cols A). dim_vec w = n"
    unfolding cols_def by auto
  have "(\<exists> x. x \<ge> 0\<^sub>v nr \<and> A *\<^sub>v x = b) = (b \<in> cone ?C)"
    using cone_of_cols[OF A b] by simp
  also have "\<dots> = (\<nexists>y. y \<in> carrier_vec n \<and> (\<forall>a\<^sub>i\<in>?C. 0 \<le> y \<bullet> a\<^sub>i) \<and> y \<bullet> b < 0)"
    unfolding fundamental_theorem_of_linear_inequalities(3)[OF C finite_set] mem_Collect_eq
    using b by auto
  also have "\<dots> = (\<forall>y. y \<in> carrier_vec n \<longrightarrow> (\<forall>a\<^sub>i\<in>?C. 0 \<le> y \<bullet> a\<^sub>i) \<longrightarrow> y \<bullet> b \<ge> 0)"
    by auto
  also have "\<dots> = (\<forall> y. y \<in> carrier_vec n \<longrightarrow> A\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v nr \<longrightarrow> y \<bullet> b \<ge> 0)"
  proof (intro all_cong imp_cong refl)
    fix y :: "'a vec"
    assume y: "y \<in> carrier_vec n"
    have "(\<forall>a\<^sub>i\<in> ?C. 0 \<le> y \<bullet> a\<^sub>i) = (\<forall>a\<^sub>i\<in> ?C. 0 \<le> a\<^sub>i \<bullet> y)"
      by (intro ball_cong[OF refl], subst comm_scalar_prod[OF y], insert C, auto)
    also have "\<dots> = (0\<^sub>v nr \<le> A\<^sup>T *\<^sub>v y)"
      unfolding less_eq_vec_def using C A y by (auto simp: cols_def)
    finally show "(\<forall>a\<^sub>i\<in>set (cols A). 0 \<le> y \<bullet> a\<^sub>i) = (0\<^sub>v nr \<le> A\<^sup>T *\<^sub>v y)" .
  qed
  finally show ?thesis .
qed

lemma Farkas_Lemma':
  fixes A :: "'a mat" and b :: "'a vec"
  assumes A: "A \<in> carrier_mat nr nc" and b: "b\<in> carrier_vec nr"
  shows "(\<exists>x. x\<in> carrier_vec nc \<and> A *\<^sub>v x \<le> b)
         \<longleftrightarrow> (\<forall>y. y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = 0\<^sub>v nc \<longrightarrow> y \<bullet> b \<ge> 0)"
proof -
  define B where "B = (1\<^sub>m nr) @\<^sub>c (A @\<^sub>c -A)"
  define b' where "b' = 0\<^sub>v nc @\<^sub>v (b @\<^sub>v -b)"
  define n where "n = nr + (nc + nc)"
  have id0: "0\<^sub>v (nr + (nc + nc)) = 0\<^sub>v nr @\<^sub>v (0\<^sub>v nc @\<^sub>v 0\<^sub>v nc)" by (intro eq_vecI, auto)
  have idcarr: "(1\<^sub>m nr) \<in> carrier_mat nr nr" by auto
  have B: "B \<in> carrier_mat nr n" unfolding B_def n_def using A by auto
  have "(\<exists>x \<in> carrier_vec nc. A *\<^sub>v x \<le> b) =
        (\<exists>x1 \<in> carrier_vec nr. \<exists>x2 \<in> carrier_vec nc. \<exists>x3 \<in> carrier_vec nc.
         x1 \<ge> 0\<^sub>v nr \<and> x2 \<ge> 0\<^sub>v nc \<and> x3 \<ge> 0\<^sub>v nc \<and> B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = b)"
  proof
    assume "\<exists>x\<in>carrier_vec nc. A *\<^sub>v x \<le> b"
    from this obtain x where Axb: "A *\<^sub>v x \<le> b" and xcarr: "x \<in> carrier_vec nc" by auto
    have bmAx: "b - A *\<^sub>v x \<in> carrier_vec nr" using A b xcarr by simp
    define x1 where "x1 = b - A *\<^sub>v x"
    have x1: "x1 \<in> carrier_vec nr" using bmAx unfolding x1_def by (simp add: xcarr)
    define x2 where "x2 = vec (dim_vec x) (\<lambda>i. if x $ i \<ge> 0 then x $ i else 0)"
    have x2: "x2 \<in> carrier_vec nc" using xcarr unfolding x2_def by simp
    define x3 where "x3 = vec (dim_vec x) (\<lambda>i. if x $ i < 0 then -x $ i else 0)"
    have x3: "x3 \<in> carrier_vec nc" using xcarr unfolding x3_def by simp
    have x2x3carr: "x2 @\<^sub>v x3 \<in> carrier_vec (nc + nc)" using x2 x3 by simp
    have x2x3x: "x2 - x3 = x" unfolding x2_def x3_def by auto
    have "A *\<^sub>v x -b \<le> 0\<^sub>v nr" using vec_le_iff_diff_le_0 b
      by (metis A Axb carrier_matD(1) dim_mult_mat_vec)
    hence x1lez: "x1 \<ge> 0\<^sub>v nr" using x1 unfolding x1_def
      by (smt A Axb carrier_matD(1) carrier_vecD diff_ge_0_iff_ge dim_mult_mat_vec
          index_minus_vec(1) index_zero_vec(1) index_zero_vec(2) less_eq_vec_def)
    have x2lez: "x2 \<ge> 0\<^sub>v nc" using x2 less_eq_vec_def unfolding x2_def by fastforce
    have x3lez: "x3 \<ge> 0\<^sub>v nc" using x3 less_eq_vec_def unfolding x3_def by fastforce
    have B1: "(1\<^sub>m nr) *\<^sub>v x1 = b - A *\<^sub>v x" using xcarr x1 unfolding x1_def by simp
    have "A *\<^sub>v x2 + (-A) *\<^sub>v x3 = A *\<^sub>v x2 + A *\<^sub>v (-x3)" using x2 x3 A by auto
    also have "\<dots> = A *\<^sub>v (x2 + (-x3))" using A x2 x3
      by (metis mult_add_distrib_mat_vec uminus_carrier_vec)
    also have "\<dots> = A *\<^sub>v x" using x2x3x minus_add_uminus_vec x2 x3 by fastforce
    finally have B2:"A *\<^sub>v x2 + (-A) *\<^sub>v x3 = A *\<^sub>v x" by auto
    have "B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = (1\<^sub>m nr) *\<^sub>v x1 + (A *\<^sub>v x2 + (-A) *\<^sub>v x3)" (is "\<dots> = ?p1 + ?p2")
      using x1 x2 x3 A mat_mult_append_cols unfolding B_def
      by (subst mat_mult_append_cols[OF _ _ x1 x2x3carr], auto simp add: mat_mult_append_cols)
    also have "?p1 = b - A *\<^sub>v x" using B1 unfolding x1_def by auto
    also have "?p2 = A *\<^sub>v x" using B2 by simp
    finally have res: "B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = b" using A xcarr b by auto
    show "\<exists>x\<in>carrier_vec nc. A *\<^sub>v x \<le> b \<Longrightarrow> \<exists>x1\<in>carrier_vec nr. \<exists>x2\<in>carrier_vec nc. \<exists>x3\<in>carrier_vec nc.
          0\<^sub>v nr \<le> x1 \<and> 0\<^sub>v nc \<le> x2 \<and> 0\<^sub>v nc \<le> x3 \<and> B *\<^sub>v (x1 @\<^sub>v x2 @\<^sub>v x3) = b"
      using x1 x2 x3 x1lez x2lez x3lez res by auto
  next
    assume "\<exists>x1 \<in> carrier_vec nr. \<exists>x2 \<in> carrier_vec nc. \<exists>x3 \<in> carrier_vec nc.
            x1 \<ge> 0\<^sub>v nr \<and> x2 \<ge> 0\<^sub>v nc \<and> x3 \<ge> 0\<^sub>v nc \<and> B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = b"
    from this obtain x1 x2 x3 where x1: "x1 \<in> carrier_vec nr" and x1lez: "x1 \<ge> 0\<^sub>v nr"
      and x2: "x2 \<in> carrier_vec nc" and x2lez: "x2 \<ge> 0\<^sub>v nc"
      and x3: "x3 \<in> carrier_vec nc" and x3lez: "x3 \<ge> 0\<^sub>v nc"
      and clc: "B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = b" by auto
    have x2x3carr: "x2 @\<^sub>v x3 \<in> carrier_vec (nc + nc)" using x2 x3 by simp
    define x where "x = x2 - x3"
    have xcarr: "x \<in> carrier_vec nc" using x2 x3 unfolding x_def by simp
    have "A *\<^sub>v x2 + (-A) *\<^sub>v x3 = A *\<^sub>v x2 + A *\<^sub>v (-x3)" using x2 x3 A by auto
    also have "\<dots> = A *\<^sub>v (x2 + (-x3))" using A x2 x3
      by (metis mult_add_distrib_mat_vec uminus_carrier_vec)
    also have "\<dots> = A *\<^sub>v x" using minus_add_uminus_vec x2 x3 unfolding x_def by fastforce
    finally have B2:"A *\<^sub>v x2 + (-A) *\<^sub>v x3 = A *\<^sub>v x" by auto
    have Axcarr: "A *\<^sub>v x \<in> carrier_vec nr" using A xcarr by auto
    have "b = B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3))" using clc by auto
    also have "\<dots> = (1\<^sub>m nr) *\<^sub>v x1 + (A *\<^sub>v x2 + (-A) *\<^sub>v x3)" (is "\<dots> = ?p1 + ?p2")
      using x1 x2 x3 A mat_mult_append_cols unfolding B_def
      by (subst mat_mult_append_cols[OF _ _ x1 x2x3carr], auto simp add: mat_mult_append_cols)
    also have "?p2 = A *\<^sub>v x" using B2 by simp
    finally have res: "b = (1\<^sub>m nr) *\<^sub>v x1 + A *\<^sub>v x" using A xcarr b by auto
    hence "b = x1 + A *\<^sub>v x" using x1 A b by simp
    hence "b - A *\<^sub>v x = x1" using x1 A b by auto
    hence "b - A *\<^sub>v x \<ge> 0\<^sub>v nr" using x1lez by auto
    hence "A *\<^sub>v x \<le> b" using Axcarr
      by (smt \<open>b - A *\<^sub>v x = x1\<close> \<open>b = x1 + A *\<^sub>v x\<close> carrier_vecD comm_add_vec index_zero_vec(2)
          minus_add_minus_vec minus_cancel_vec vec_le_iff_diff_le_0 x1)
    then show "\<exists>x1\<in>carrier_vec nr. \<exists>x2\<in>carrier_vec nc. \<exists>x3\<in>carrier_vec nc.
          0\<^sub>v nr \<le> x1 \<and> 0\<^sub>v nc \<le> x2 \<and> 0\<^sub>v nc \<le> x3 \<and> B *\<^sub>v (x1 @\<^sub>v x2 @\<^sub>v x3) = b \<Longrightarrow>
          \<exists>x\<in>carrier_vec nc. A *\<^sub>v x \<le> b" using xcarr by blast
  qed
  also have "\<dots> = (\<exists>x1 \<in> carrier_vec nr. \<exists>x2 \<in> carrier_vec nc. \<exists>x3 \<in> carrier_vec nc.
         (x1 @\<^sub>v (x2 @\<^sub>v x3)) \<ge> 0\<^sub>v n  \<and> B *\<^sub>v (x1 @\<^sub>v (x2 @\<^sub>v x3)) = b)"
    by (metis append_vec_le id0 n_def zero_carrier_vec)
  also have "\<dots> = (\<exists>x \<in> carrier_vec n. x \<ge> 0\<^sub>v n  \<and> B *\<^sub>v x = b)"
    unfolding n_def exists_vec_append by auto
  also have "\<dots> = (\<exists>x \<ge> 0\<^sub>v n. B *\<^sub>v x = b)" unfolding less_eq_vec_def by fastforce
  also have "\<dots> = (\<forall> y. y \<in> carrier_vec nr \<longrightarrow> B\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v n \<longrightarrow> y \<bullet> b \<ge> 0)"
    by (rule gram_schmidt.Farkas_Lemma[OF B b])
  also have "\<dots> = (\<forall> y. y \<in> carrier_vec nr \<longrightarrow> (y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = 0\<^sub>v nc) \<longrightarrow> y \<bullet> b \<ge> 0)"
  proof (intro all_cong imp_cong refl)
    fix y :: "'a vec"
    assume y: "y \<in> carrier_vec nr"
    have idtcarr: "(1\<^sub>m nr)\<^sup>T \<in> carrier_mat nr nr" by auto
    have Atcarr: "A\<^sup>T \<in> carrier_mat nc nr" using A by auto
    have mAtcarr: "(-A)\<^sup>T \<in> carrier_mat nc nr" using A by auto
    have AtAtcarr: "A\<^sup>T @\<^sub>r (-A)\<^sup>T \<in> carrier_mat (nc + nc) nr" using A by auto
    have "B\<^sup>T *\<^sub>v y = ((1\<^sub>m nr)\<^sup>T @\<^sub>r A\<^sup>T @\<^sub>r (-A)\<^sup>T) *\<^sub>v y" unfolding B_def
      by (simp add: append_cols_def)
    also have "\<dots> = ((1\<^sub>m nr)\<^sup>T *\<^sub>v y) @\<^sub>v (A\<^sup>T *\<^sub>v y) @\<^sub>v ((-A)\<^sup>T *\<^sub>v y)"
      using mat_mult_append[OF Atcarr mAtcarr y] mat_mult_append y Atcarr idtcarr mAtcarr
      by (metis AtAtcarr)
    finally have eq: "B\<^sup>T *\<^sub>v y = ((1\<^sub>m nr)\<^sup>T *\<^sub>v y) @\<^sub>v (A\<^sup>T *\<^sub>v y) @\<^sub>v ((-A)\<^sup>T *\<^sub>v y)" by auto
    have "(B\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v n) = (0\<^sub>v n \<le> (1\<^sub>m nr)\<^sup>T *\<^sub>v y @\<^sub>v A\<^sup>T *\<^sub>v y @\<^sub>v (- A)\<^sup>T *\<^sub>v y)" unfolding eq by simp
    also have "\<dots> = (((1\<^sub>m nr)\<^sup>T *\<^sub>v y) @\<^sub>v (A\<^sup>T *\<^sub>v y) @\<^sub>v ((-A)\<^sup>T *\<^sub>v y) \<ge> 0\<^sub>v nr @\<^sub>v 0\<^sub>v nc @\<^sub>v 0\<^sub>v nc)"
      using id0 by (metis eq n_def)
    also have "\<dots> = (y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v nc \<and> ((-A)\<^sup>T *\<^sub>v y) \<ge> 0\<^sub>v nc)"
      by (metis Atcarr append_vec_le mult_mat_vec_carrier one_mult_mat_vec transpose_one y zero_carrier_vec)
    also have "\<dots> = (y \<ge> 0\<^sub>v nr \<and>A\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v nc \<and> -(A\<^sup>T *\<^sub>v y) \<ge> 0\<^sub>v nc)"
      by (metis A Atcarr carrier_matD(2) carrier_vecD transpose_uminus uminus_mult_mat_vec y)
    also have "\<dots> = (y \<ge> 0\<^sub>v nr \<and>A\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v nc \<and> (A\<^sup>T *\<^sub>v y) \<le> 0\<^sub>v nc)"
      by (metis (mono_tags, lifting) A Atcarr carrier_matD(2) carrier_vecD index_zero_vec(2)
          mAtcarr mult_mat_vec_carrier transpose_uminus uminus_mult_mat_vec uminus_uminus_vec
          vec_le_iff_diff_le_0 y zero_minus_vec)
    also have "\<dots> = (y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = 0\<^sub>v nc)" by auto
    finally show "(B\<^sup>T *\<^sub>v y \<ge> 0\<^sub>v n) = (y \<ge> 0\<^sub>v nr \<and> A\<^sup>T *\<^sub>v y = 0\<^sub>v nc)" .
  qed
  finally show ?thesis by (auto simp: less_eq_vec_def)
qed

end
end


(*  Title:      ZF/Induct/PropLog.thy
    Author:     Tobias Nipkow & Lawrence C Paulson
    Copyright   1993  University of Cambridge
*)

section {* Meta-theory of propositional logic *}

theory PropLog imports Main begin

text {*
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If @{text "H |= p"} then @{text "G |= p"} where @{text "G \<in>
  Fin(H)"}
*}

subsection {* The datatype of propositions *}

consts
  propn :: i

datatype propn =
    Fls
  | Var ("n \<in> nat")    ("#_" [100] 100)
  | Imp ("p \<in> propn", "q \<in> propn")    (infixr "=>" 90)

subsection {* The proof system *}

consts thms     :: "i => i"

abbreviation
  thms_syntax :: "[i,i] => o"    (infixl "|-" 50)
  where "H |- p == p \<in> thms(H)"

inductive
  domains "thms(H)" \<subseteq> "propn"
  intros
    H:  "[| p \<in> H;  p \<in> propn |] ==> H |- p"
    K:  "[| p \<in> propn;  q \<in> propn |] ==> H |- p=>q=>p"
    S:  "[| p \<in> propn;  q \<in> propn;  r \<in> propn |]
         ==> H |- (p=>q=>r) => (p=>q) => p=>r"
    DN: "p \<in> propn ==> H |- ((p=>Fls) => Fls) => p"
    MP: "[| H |- p=>q;  H |- p;  p \<in> propn;  q \<in> propn |] ==> H |- q"
  type_intros "propn.intros"

declare propn.intros [simp]

subsection {* The semantics *}

subsubsection {* Semantics of propositional logic. *}

consts
  is_true_fun :: "[i,i] => i"
primrec
  "is_true_fun(Fls, t) = 0"
  "is_true_fun(Var(v), t) = (if v \<in> t then 1 else 0)"
  "is_true_fun(p=>q, t) = (if is_true_fun(p,t) = 1 then is_true_fun(q,t) else 1)"

definition
  is_true :: "[i,i] => o"  where
  "is_true(p,t) == is_true_fun(p,t) = 1"
  -- {* this definition is required since predicates can't be recursive *}

lemma is_true_Fls [simp]: "is_true(Fls,t) \<longleftrightarrow> False"
  by (simp add: is_true_def)

lemma is_true_Var [simp]: "is_true(#v,t) \<longleftrightarrow> v \<in> t"
  by (simp add: is_true_def)

lemma is_true_Imp [simp]: "is_true(p=>q,t) \<longleftrightarrow> (is_true(p,t)\<longrightarrow>is_true(q,t))"
  by (simp add: is_true_def)

subsubsection {* Logical consequence *}

text {*
  For every valuation, if all elements of @{text H} are true then so
  is @{text p}.
*}

definition
  logcon :: "[i,i] => o"    (infixl "|=" 50)  where
  "H |= p == \<forall>t. (\<forall>q \<in> H. is_true(q,t)) \<longrightarrow> is_true(p,t)"

text {*
  A finite set of hypotheses from @{text t} and the @{text Var}s in
  @{text p}.
*}

consts
  hyps :: "[i,i] => i"
primrec
  "hyps(Fls, t) = 0"
  "hyps(Var(v), t) = (if v \<in> t then {#v} else {#v=>Fls})"
  "hyps(p=>q, t) = hyps(p,t) \<union> hyps(q,t)"

subsection {* Proof theory of propositional logic *}

lemma thms_mono: "G \<subseteq> H ==> thms(G) \<subseteq> thms(H)"
  apply (unfold thms.defs)
  apply (rule lfp_mono)
    apply (rule thms.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemmas thms_in_pl = thms.dom_subset [THEN subsetD]

inductive_cases ImpE: "p=>q \<in> propn"

lemma thms_MP: "[| H |- p=>q;  H |- p |] ==> H |- q"
  -- {* Stronger Modus Ponens rule: no typechecking! *}
  apply (rule thms.MP)
     apply (erule asm_rl thms_in_pl thms_in_pl [THEN ImpE])+
  done

lemma thms_I: "p \<in> propn ==> H |- p=>p"
  -- {*Rule is called @{text I} for Identity Combinator, not for Introduction. *}
  apply (rule thms.S [THEN thms_MP, THEN thms_MP])
      apply (rule_tac [5] thms.K)
       apply (rule_tac [4] thms.K)
         apply simp_all
  done

subsubsection {* Weakening, left and right *}

lemma weaken_left: "[| G \<subseteq> H;  G|-p |] ==> H|-p"
  -- {* Order of premises is convenient with @{text THEN} *}
  by (erule thms_mono [THEN subsetD])

lemma weaken_left_cons: "H |- p ==> cons(a,H) |- p"
  by (erule subset_consI [THEN weaken_left])

lemmas weaken_left_Un1  = Un_upper1 [THEN weaken_left]
lemmas weaken_left_Un2  = Un_upper2 [THEN weaken_left]

lemma weaken_right: "[| H |- q;  p \<in> propn |] ==> H |- p=>q"
  by (simp_all add: thms.K [THEN thms_MP] thms_in_pl)

subsubsection {* The deduction theorem *}

theorem deduction: "[| cons(p,H) |- q;  p \<in> propn |] ==>  H |- p=>q"
  apply (erule thms.induct)
      apply (blast intro: thms_I thms.H [THEN weaken_right])
     apply (blast intro: thms.K [THEN weaken_right])
    apply (blast intro: thms.S [THEN weaken_right])
   apply (blast intro: thms.DN [THEN weaken_right])
  apply (blast intro: thms.S [THEN thms_MP [THEN thms_MP]])
  done

subsubsection {* The cut rule *}

lemma cut: "[| H|-p;  cons(p,H) |- q |] ==>  H |- q"
  apply (rule deduction [THEN thms_MP])
    apply (simp_all add: thms_in_pl)
  done

lemma thms_FlsE: "[| H |- Fls; p \<in> propn |] ==> H |- p"
  apply (rule thms.DN [THEN thms_MP])
   apply (rule_tac [2] weaken_right)
    apply (simp_all add: propn.intros)
  done

lemma thms_notE: "[| H |- p=>Fls;  H |- p;  q \<in> propn |] ==> H |- q"
  by (erule thms_MP [THEN thms_FlsE])

subsubsection {* Soundness of the rules wrt truth-table semantics *}

theorem soundness: "H |- p ==> H |= p"
  apply (unfold logcon_def)
  apply (induct set: thms)
      apply auto
  done

subsection {* Completeness *}

subsubsection {* Towards the completeness proof *}

lemma Fls_Imp: "[| H |- p=>Fls; q \<in> propn |] ==> H |- p=>q"
  apply (frule thms_in_pl)
  apply (rule deduction)
   apply (rule weaken_left_cons [THEN thms_notE])
     apply (blast intro: thms.H elim: ImpE)+
  done

lemma Imp_Fls: "[| H |- p;  H |- q=>Fls |] ==> H |- (p=>q)=>Fls"
  apply (frule thms_in_pl)
  apply (frule thms_in_pl [of concl: "q=>Fls"])
  apply (rule deduction)
   apply (erule weaken_left_cons [THEN thms_MP])
   apply (rule consI1 [THEN thms.H, THEN thms_MP])
    apply (blast intro: weaken_left_cons elim: ImpE)+
  done

lemma hyps_thms_if:
    "p \<in> propn ==> hyps(p,t) |- (if is_true(p,t) then p else p=>Fls)"
  -- {* Typical example of strengthening the induction statement. *}
  apply simp
  apply (induct_tac p)
    apply (simp_all add: thms_I thms.H)
  apply (safe elim!: Fls_Imp [THEN weaken_left_Un1] Fls_Imp [THEN weaken_left_Un2])
  apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right Imp_Fls)+
  done

lemma logcon_thms_p: "[| p \<in> propn;  0 |= p |] ==> hyps(p,t) |- p"
  -- {* Key lemma for completeness; yields a set of assumptions satisfying @{text p} *}
  apply (drule hyps_thms_if)
  apply (simp add: logcon_def)
  done

text {*
  For proving certain theorems in our new propositional logic.
*}

lemmas propn_SIs = propn.intros deduction
  and propn_Is = thms_in_pl thms.H thms.H [THEN thms_MP]

text {*
  The excluded middle in the form of an elimination rule.
*}

lemma thms_excluded_middle:
    "[| p \<in> propn;  q \<in> propn |] ==> H |- (p=>q) => ((p=>Fls)=>q) => q"
  apply (rule deduction [THEN deduction])
    apply (rule thms.DN [THEN thms_MP])
     apply (best intro!: propn_SIs intro: propn_Is)+
  done

lemma thms_excluded_middle_rule:
  "[| cons(p,H) |- q;  cons(p=>Fls,H) |- q;  p \<in> propn |] ==> H |- q"
  -- {* Hard to prove directly because it requires cuts *}
  apply (rule thms_excluded_middle [THEN thms_MP, THEN thms_MP])
     apply (blast intro!: propn_SIs intro: propn_Is)+
  done

subsubsection {* Completeness -- lemmas for reducing the set of assumptions *}

text {*
  For the case @{prop "hyps(p,t)-cons(#v,Y) |- p"} we also have @{prop
  "hyps(p,t)-{#v} \<subseteq> hyps(p, t-{v})"}.
*}

lemma hyps_Diff:
    "p \<in> propn ==> hyps(p, t-{v}) \<subseteq> cons(#v=>Fls, hyps(p,t)-{#v})"
  by (induct set: propn) auto

text {*
  For the case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"} we also have
  @{prop "hyps(p,t)-{#v=>Fls} \<subseteq> hyps(p, cons(v,t))"}.
*}

lemma hyps_cons:
    "p \<in> propn ==> hyps(p, cons(v,t)) \<subseteq> cons(#v, hyps(p,t)-{#v=>Fls})"
  by (induct set: propn) auto

text {* Two lemmas for use with @{text weaken_left} *}

lemma cons_Diff_same: "B-C \<subseteq> cons(a, B-cons(a,C))"
  by blast

lemma cons_Diff_subset2: "cons(a, B-{c}) - D \<subseteq> cons(a, B-cons(c,D))"
  by blast

text {*
  The set @{term "hyps(p,t)"} is finite, and elements have the form
  @{term "#v"} or @{term "#v=>Fls"}; could probably prove the stronger
  @{prop "hyps(p,t) \<in> Fin(hyps(p,0) \<union> hyps(p,nat))"}.
*}

lemma hyps_finite: "p \<in> propn ==> hyps(p,t) \<in> Fin(\<Union>v \<in> nat. {#v, #v=>Fls})"
  by (induct set: propn) auto

lemmas Diff_weaken_left = Diff_mono [OF _ subset_refl, THEN weaken_left]

text {*
  Induction on the finite set of assumptions @{term "hyps(p,t0)"}.  We
  may repeatedly subtract assumptions until none are left!
*}

lemma completeness_0_lemma [rule_format]:
    "[| p \<in> propn;  0 |= p |] ==> \<forall>t. hyps(p,t) - hyps(p,t0) |- p"
  apply (frule hyps_finite)
  apply (erule Fin_induct)
   apply (simp add: logcon_thms_p Diff_0)
  txt {* inductive step *}
  apply safe
   txt {* Case @{prop "hyps(p,t)-cons(#v,Y) |- p"} *}
   apply (rule thms_excluded_middle_rule)
     apply (erule_tac [3] propn.intros)
    apply (blast intro: cons_Diff_same [THEN weaken_left])
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_Diff [THEN Diff_weaken_left])
  txt {* Case @{prop "hyps(p,t)-cons(#v => Fls,Y) |- p"} *}
  apply (rule thms_excluded_middle_rule)
    apply (erule_tac [3] propn.intros)
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_cons [THEN Diff_weaken_left])
  apply (blast intro: cons_Diff_same [THEN weaken_left])
  done

subsubsection {* Completeness theorem *}

lemma completeness_0: "[| p \<in> propn;  0 |= p |] ==> 0 |- p"
  -- {* The base case for completeness *}
  apply (rule Diff_cancel [THEN subst])
  apply (blast intro: completeness_0_lemma)
  done

lemma logcon_Imp: "[| cons(p,H) |= q |] ==> H |= p=>q"
  -- {* A semantic analogue of the Deduction Theorem *}
  by (simp add: logcon_def)

lemma completeness:
     "H \<in> Fin(propn) ==> p \<in> propn \<Longrightarrow> H |= p \<Longrightarrow> H |- p"
  apply (induct arbitrary: p set: Fin)
   apply (safe intro!: completeness_0)
  apply (rule weaken_left_cons [THEN thms_MP])
   apply (blast intro!: logcon_Imp propn.intros)
  apply (blast intro: propn_Is)
  done

theorem thms_iff: "H \<in> Fin(propn) ==> H |- p \<longleftrightarrow> H |= p \<and> p \<in> propn"
  by (blast intro: soundness completeness thms_in_pl)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Left Total\<close>
theory Binary_Relations_Left_Total
  imports
    Binary_Relation_Functions
    HOL_Syntax_Bundles_Lattices
begin

consts left_total_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  left_total_on_pred \<equiv> "left_total_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "left_total_on_pred P R \<equiv> \<forall>x. P x \<longrightarrow> in_dom R x"
end

lemma left_total_onI [intro]:
  assumes "\<And>x. P x \<Longrightarrow> in_dom R x"
  shows "left_total_on P R"
  unfolding left_total_on_pred_def using assms by blast

lemma left_total_onE [elim]:
  assumes "left_total_on P R"
  and "P x"
  obtains y where "R x y"
  using assms unfolding left_total_on_pred_def by blast

lemma in_dom_if_left_total_on:
  assumes "left_total_on P R"
  and "P x"
  shows "in_dom R x"
  using assms by blast

definition "left_total (R :: 'a \<Rightarrow> _) \<equiv> left_total_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma left_total_eq_left_total_on:
  "left_total (R :: 'a \<Rightarrow> _) = left_total_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding left_total_def ..

lemma left_totalI [intro]:
  assumes "\<And>x. in_dom R x"
  shows "left_total R"
  unfolding left_total_eq_left_total_on using assms by (intro left_total_onI)

lemma left_totalE:
  assumes "left_total R"
  obtains y where "R x y"
  using assms unfolding left_total_eq_left_total_on by (blast intro: top1I)

lemma in_dom_if_left_total:
  assumes "left_total R"
  shows "in_dom R x"
  using assms by (blast elim: left_totalE)

lemma left_total_on_if_left_total:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "left_total R"
  shows "left_total_on P R"
  using assms by (intro left_total_onI) (blast dest: in_dom_if_left_total)

end


(*  Title:      HOL/BNF_Def.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Definition of bounded natural functors.
*)

section {* Definition of Bounded Natural Functors *}

theory BNF_Def
imports BNF_Cardinal_Arithmetic Fun_Def_Base
keywords
  "print_bnfs" :: diag and
  "bnf" :: thy_goal
begin

lemma Collect_splitD: "x \<in> Collect (split A) \<Longrightarrow> A (fst x) (snd x)"
  by auto

inductive
   rel_sum :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> 'c + 'd \<Rightarrow> bool" for R1 R2
where
  "R1 a c \<Longrightarrow> rel_sum R1 R2 (Inl a) (Inl c)"
| "R2 b d \<Longrightarrow> rel_sum R1 R2 (Inr b) (Inr d)"

hide_fact rel_sum_def

definition
  rel_fun :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> bool"
where
  "rel_fun A B = (\<lambda>f g. \<forall>x y. A x y \<longrightarrow> B (f x) (g y))"

lemma rel_funI [intro]:
  assumes "\<And>x y. A x y \<Longrightarrow> B (f x) (g y)"
  shows "rel_fun A B f g"
  using assms by (simp add: rel_fun_def)

lemma rel_funD:
  assumes "rel_fun A B f g" and "A x y"
  shows "B (f x) (g y)"
  using assms by (simp add: rel_fun_def)

definition rel_set :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"
  where "rel_set R = (\<lambda>A B. (\<forall>x\<in>A. \<exists>y\<in>B. R x y) \<and> (\<forall>y\<in>B. \<exists>x\<in>A. R x y))"

lemma rel_setI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> \<exists>y\<in>B. R x y"
  assumes "\<And>y. y \<in> B \<Longrightarrow> \<exists>x\<in>A. R x y"
  shows "rel_set R A B"
  using assms unfolding rel_set_def by simp

lemma predicate2_transferD:
   "\<lbrakk>rel_fun R1 (rel_fun R2 (op =)) P Q; a \<in> A; b \<in> B; A \<subseteq> {(x, y). R1 x y}; B \<subseteq> {(x, y). R2 x y}\<rbrakk> \<Longrightarrow>
   P (fst a) (fst b) \<longleftrightarrow> Q (snd a) (snd b)"
  unfolding rel_fun_def by (blast dest!: Collect_splitD)

definition collect where
  "collect F x = (\<Union>f \<in> F. f x)"

lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
  by simp

lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
  by simp

lemma bijI': "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
  unfolding bij_def inj_on_def by auto blast

(* Operator: *)
definition "Gr A f = {(a, f a) | a. a \<in> A}"

definition "Grp A f = (\<lambda>a b. b = f a \<and> a \<in> A)"

definition vimage2p where
  "vimage2p f g R = (\<lambda>x y. R (f x) (g y))"

lemma collect_comp: "collect F \<circ> g = collect ((\<lambda>f. f \<circ> g) ` F)"
  by (rule ext) (auto simp only: comp_apply collect_def)

definition convol ("\<langle>(_,/ _)\<rangle>") where
  "\<langle>f, g\<rangle> \<equiv> \<lambda>a. (f a, g a)"

lemma fst_convol: "fst \<circ> \<langle>f, g\<rangle> = f"
  apply(rule ext)
  unfolding convol_def by simp

lemma snd_convol: "snd \<circ> \<langle>f, g\<rangle> = g"
  apply(rule ext)
  unfolding convol_def by simp

lemma convol_mem_GrpI:
  "x \<in> A \<Longrightarrow> \<langle>id, g\<rangle> x \<in> (Collect (split (Grp A g)))"
  unfolding convol_def Grp_def by auto

definition csquare where
  "csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"

lemma eq_alt: "op = = Grp UNIV id"
  unfolding Grp_def by auto

lemma leq_conversepI: "R = op = \<Longrightarrow> R \<le> R^--1"
  by auto

lemma leq_OOI: "R = op = \<Longrightarrow> R \<le> R OO R"
  by auto

lemma OO_Grp_alt: "(Grp A f)^--1 OO Grp A g = (\<lambda>x y. \<exists>z. z \<in> A \<and> f z = x \<and> g z = y)"
  unfolding Grp_def by auto

lemma Grp_UNIV_id: "f = id \<Longrightarrow> (Grp UNIV f)^--1 OO Grp UNIV f = Grp UNIV f"
  unfolding Grp_def by auto

lemma Grp_UNIV_idI: "x = y \<Longrightarrow> Grp UNIV id x y"
  unfolding Grp_def by auto

lemma Grp_mono: "A \<le> B \<Longrightarrow> Grp A f \<le> Grp B f"
  unfolding Grp_def by auto

lemma GrpI: "\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> Grp A f x y"
  unfolding Grp_def by auto

lemma GrpE: "Grp A f x y \<Longrightarrow> (\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
  unfolding Grp_def by auto

lemma Collect_split_Grp_eqD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> (f \<circ> fst) z = snd z"
  unfolding Grp_def comp_def by auto

lemma Collect_split_Grp_inD: "z \<in> Collect (split (Grp A f)) \<Longrightarrow> fst z \<in> A"
  unfolding Grp_def comp_def by auto

definition "pick_middlep P Q a c = (SOME b. P a b \<and> Q b c)"

lemma pick_middlep:
  "(P OO Q) a c \<Longrightarrow> P a (pick_middlep P Q a c) \<and> Q (pick_middlep P Q a c) c"
  unfolding pick_middlep_def apply(rule someI_ex) by auto

definition fstOp where
  "fstOp P Q ac = (fst ac, pick_middlep P Q (fst ac) (snd ac))"

definition sndOp where
  "sndOp P Q ac = (pick_middlep P Q (fst ac) (snd ac), (snd ac))"

lemma fstOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> fstOp P Q ac \<in> Collect (split P)"
  unfolding fstOp_def mem_Collect_eq
  by (subst (asm) surjective_pairing, unfold prod.case) (erule pick_middlep[THEN conjunct1])

lemma fst_fstOp: "fst bc = (fst \<circ> fstOp P Q) bc"
  unfolding comp_def fstOp_def by simp

lemma snd_sndOp: "snd bc = (snd \<circ> sndOp P Q) bc"
  unfolding comp_def sndOp_def by simp

lemma sndOp_in: "ac \<in> Collect (split (P OO Q)) \<Longrightarrow> sndOp P Q ac \<in> Collect (split Q)"
  unfolding sndOp_def mem_Collect_eq
  by (subst (asm) surjective_pairing, unfold prod.case) (erule pick_middlep[THEN conjunct2])

lemma csquare_fstOp_sndOp:
  "csquare (Collect (split (P OO Q))) snd fst (fstOp P Q) (sndOp P Q)"
  unfolding csquare_def fstOp_def sndOp_def using pick_middlep by simp

lemma snd_fst_flip: "snd xy = (fst \<circ> (%(x, y). (y, x))) xy"
  by (simp split: prod.split)

lemma fst_snd_flip: "fst xy = (snd \<circ> (%(x, y). (y, x))) xy"
  by (simp split: prod.split)

lemma flip_pred: "A \<subseteq> Collect (split (R ^--1)) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> Collect (split R)"
  by auto

lemma Collect_split_mono: "A \<le> B \<Longrightarrow> Collect (split A) \<subseteq> Collect (split B)"
  by auto

lemma Collect_split_mono_strong:
  "\<lbrakk>X = fst ` A; Y = snd ` A; \<forall>a\<in>X. \<forall>b \<in> Y. P a b \<longrightarrow> Q a b; A \<subseteq> Collect (split P)\<rbrakk> \<Longrightarrow>
   A \<subseteq> Collect (split Q)"
  by fastforce

lemma predicate2_eqD: "A = B \<Longrightarrow> A a b \<longleftrightarrow> B a b"
  by simp

lemma case_sum_o_inj: "case_sum f g \<circ> Inl = f" "case_sum f g \<circ> Inr = g"
  by auto

lemma map_sum_o_inj: "map_sum f g o Inl = Inl o f" "map_sum f g o Inr = Inr o g"
  by auto

lemma card_order_csum_cone_cexp_def:
  "card_order r \<Longrightarrow> ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \<union> {Inr ()})|"
  unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order)

lemma If_the_inv_into_in_Func:
  "\<lbrakk>inj_on g C; C \<subseteq> B \<union> {x}\<rbrakk> \<Longrightarrow>
   (\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<in> Func UNIV (B \<union> {x})"
  unfolding Func_def by (auto dest: the_inv_into_into)

lemma If_the_inv_into_f_f:
  "\<lbrakk>i \<in> C; inj_on g C\<rbrakk> \<Longrightarrow> ((\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<circ> g) i = id i"
  unfolding Func_def by (auto elim: the_inv_into_f_f)

lemma the_inv_f_o_f_id: "inj f \<Longrightarrow> (the_inv f \<circ> f) z = id z"
  by (simp add: the_inv_f_f)

lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
  unfolding vimage2p_def by -

lemma rel_fun_iff_leq_vimage2p: "(rel_fun R S) f g = (R \<le> vimage2p f g S)"
  unfolding rel_fun_def vimage2p_def by auto

lemma convol_image_vimage2p: "\<langle>f \<circ> fst, g \<circ> snd\<rangle> ` Collect (split (vimage2p f g R)) \<subseteq> Collect (split R)"
  unfolding vimage2p_def convol_def by auto

lemma vimage2p_Grp: "vimage2p f g P = Grp UNIV f OO P OO (Grp UNIV g)\<inverse>\<inverse>"
  unfolding vimage2p_def Grp_def by auto

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma comp_apply_eq: "f (g x) = h (k x) \<Longrightarrow> (f \<circ> g) x = (h \<circ> k) x"
  unfolding comp_apply by assumption

ML_file "Tools/BNF/bnf_util.ML"
ML_file "Tools/BNF/bnf_tactics.ML"
ML_file "Tools/BNF/bnf_def_tactics.ML"
ML_file "Tools/BNF/bnf_def.ML"

end


theory ch31
imports Main
begin

section{* How to simplify *}

text{* No assumption: *}
lemma "ys @ [] = []"
apply(simp)
oops (* abandon proof *)

text{* Simple assumption: *}
lemma "xs = [] ==> xs @ ys = ys @ xs @ ys"
apply(simp)
oops;

text{* Simplification in assumption: *}
lemma "[| xs @ zs = ys @ xs; [] @ xs = [] @ [] |] ==> ys = zs"
apply(simp)
done;

text{* Using additional rules: *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply(simp add: ring_distribs) thm ring_distribs
done

text{* Giving a lemma the simp-attribute: *}
declare ring_distribs [simp]

subsection{* Rewriting with definitions *}

definition exor :: "bool => bool => bool" where
"exor x y = (x & y | ~x & ~y)"
definition nand :: "bool => bool => bool" where
"nand x y = (~(x & y))"

text{* Unfolding + simplification: *}
lemma "exor x x = nand x (~x)"
apply(unfold exor_def nand_def)
apply(simp)
done

text{* Just simplification: *}
lemma "exor x x = nand x (~x)"
apply(simp add: exor_def nand_def)
done

subsection{* Case distinctions *}

text{* Automatic: *}
lemma "(A & B) = (if A then B else False)"
apply(simp)
done

lemma "if A then B else C"
apply(simp)
oops

text{* By hand (for case): *}
lemma "x = (case x of 0 => n | Suc y => y+y)"
apply(simp split: nat.split)
oops;

subsection {* Arithmetic *}

text{* A bit of linear arithmetic (no multiplication) is automatic: *}
lemma "[| (x::nat) <= y+z; z+x < y |] ==> x < y"
apply(simp)
done

subsection{* Tracing: *}

lemma "rev[x] = []"
apply(simp)
oops

subsection{* Auto *}

text{* Method ``auto'' can be modified almost like ``simp'': instead of
``add'' use ``simp add'': *}

lemma "(EX u::nat. x=y+u) --> a*(b+c)+y <= x + a*b+a*c"
apply(auto simp add: add_mult_distrib2)
done

end