(*
Title: Catoids
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Catoids\<close>

theory Catoid
  imports Main

begin

subsection \<open>Multimagmas\<close>

text \<open>Multimagmas are sets equipped with multioperations. Multioperations are isomorphic to ternary relations.\<close>

class multimagma =
  fixes mcomp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a set" (infixl "\<odot>" 70)

begin

text \<open>We introduce notation for the domain of definition of the multioperation.\<close>

abbreviation "\<Delta> x y \<equiv> (x \<odot> y \<noteq> {})"

text \<open>We extend the multioperation to powersets\<close>

definition conv :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "\<star>" 70) where
  "X \<star> Y = \<Union>{x \<odot> y |x y. x \<in> X \<and> y \<in> Y}"

lemma conv_exp: "X \<star> Y = {z. \<exists>x y. z \<in> x \<odot> y \<and> x \<in> X \<and> y \<in> Y}"
  unfolding conv_def by fastforce

lemma conv_exp2: "(z \<in> X \<star> Y) = (\<exists>x y. z \<in> x \<odot> y \<and> x \<in> X \<and> y \<in> Y)"
  by (simp add: multimagma.conv_exp)

lemma conv_distl: "X \<star> \<Union>\<Y> = \<Union>{X \<star> Y |Y. Y \<in> \<Y>}"
  unfolding conv_def by blast

lemma conv_distr: "\<Union>\<X> \<star> Y = \<Union>{X \<star> Y |X. X \<in> \<X>}"
  unfolding conv_def by blast

lemma conv_isol: "X \<subseteq> Y \<Longrightarrow> Z \<star> X \<subseteq> Z \<star> Y"
  using conv_exp2 by fastforce

lemma conv_isor: "X \<subseteq> Y \<Longrightarrow> X \<star> Z \<subseteq> Y \<star> Z"
  using conv_exp2 by fastforce

lemma conv_atom [simp]: "{x} \<star> {y} = x \<odot> y"
  by (simp add: conv_def)

end

subsection \<open>Multisemigroups\<close>

text \<open>Sultisemigroups are associative multimagmas.\<close>

class multisemigroup = multimagma +
  assumes assoc: "\<Union>{x \<odot> v |v. v \<in> y \<odot> z} = \<Union>{v \<odot> z |v. v \<in> x \<odot> y}"

begin

lemma assoc_exp: "(\<exists>v. w \<in> x \<odot> v \<and> v \<in> y \<odot> z) = (\<exists>v. v \<in> x \<odot> y \<and> w \<in> v \<odot> z)"
  using assoc by blast

lemma assoc_var: "{x} \<star> (y \<odot> z) = (x \<odot> y) \<star> {z}"
  unfolding conv_def assoc_exp using local.assoc by force

text \<open>Associativity extends to powersets.\<close>

lemma conv_assoc: "X \<star> (Y \<star> Z) = (X \<star> Y) \<star> Z"
  unfolding conv_exp using assoc_exp by fastforce

end

subsection \<open>st-Multimagmas\<close>

text \<open>We equip multimagmas with source and target maps.\<close>

class st_op =
  fixes src :: "'a \<Rightarrow> 'a" ("\<sigma>")
  and tgt :: "'a \<Rightarrow> 'a" ("\<tau>")

class st_multimagma = multimagma + st_op +
  assumes Dst: "x \<odot> y \<noteq> {} \<Longrightarrow> \<tau> x = \<sigma> y"
  and s_absorb [simp]: "\<sigma> x \<odot> x = {x}"
  and t_absorb [simp]: "x \<odot> \<tau> x = {x}"

text \<open>The following sublocale proof sets up opposition/duality.\<close>

sublocale st_multimagma \<subseteq> stopp: st_multimagma "\<lambda>x y. y \<odot> x" tgt src
  rewrites "stopp.conv X Y = Y \<star> X"
  by (unfold_locales, auto simp add: local.Dst multimagma.conv_def)

lemma (in st_multimagma) ts_compat [simp]:
  "\<tau> (\<sigma> x) = \<sigma> x"
  by (simp add: Dst)

lemma (in st_multimagma) ss_idem [simp]:
  "\<sigma> (\<sigma> x) = \<sigma> x"
  by (metis local.stopp.ts_compat local.ts_compat)

lemma (in st_multimagma) st_fix:
  "(\<tau> x = x) = (\<sigma> x = x)"
proof
  assume h1: "\<tau> x = x"
  hence "\<sigma> x = \<sigma> (\<tau> x)"
    by simp
  also have "\<dots> = x"
    by (metis h1 local.stopp.ts_compat)
  finally show "\<sigma> x = x".
next
  assume h2: "\<sigma> x = x"
  hence "\<tau> x = \<tau> (\<sigma> x)"
    by simp
  also have "\<dots> = x"
    by (metis h2 ts_compat)
  finally show "\<tau> x = x".
qed

text \<open>We extend source and target operations to powersets by taking images.\<close>

abbreviation (in st_op) Src :: "'a set \<Rightarrow> 'a set" where
  "Src \<equiv> image \<sigma>"

abbreviation (in st_op) Tgt :: "'a set \<Rightarrow> 'a set" where
  "Tgt \<equiv> image \<tau>"

text \<open>Fixpoints of source and target maps model source and target elements.
These correspond to units.\<close>

abbreviation (in st_op) sfix :: "'a set" where
  "sfix \<equiv> {x. \<sigma> x = x}"

abbreviation (in st_op) tfix :: "'a set" where
  "tfix \<equiv> {x. \<tau> x = x}"

lemma (in st_multimagma) st_mm_rfix [simp]:
  "tfix = stopp.sfix"
  by simp

lemma (in st_multimagma) st_fix_set:
  "{x. \<sigma> x = x} = {x. \<tau> x = x}"
  using local.st_fix by presburger

lemma (in st_multimagma) stfix_set:
  "sfix = tfix"
  using local.st_fix_set by blast

lemma (in st_multimagma) sfix_im:
  "sfix = Src UNIV"
  by (smt (verit, ccfv_threshold) Collect_cong full_SetCompr_eq local.ss_idem)

lemma (in st_multimagma) tfix_im:
  "tfix = Tgt UNIV"
  using local.stopp.sfix_im by blast

lemma (in st_multimagma) ST_im:
  "Src UNIV = Tgt UNIV"
  using local.sfix_im local.stfix_set local.tfix_im by presburger

text \<open>Source and target elements are "orthogonal" idempotents.\<close>

lemma (in st_multimagma) s_idem [simp]:
  "\<sigma> x \<odot> \<sigma> x = {\<sigma> x}"
proof-
  have "{\<sigma> x} = \<sigma> x \<odot> \<tau> (\<sigma> x)"
    using local.t_absorb by presburger
  also have "\<dots> = \<sigma> x \<odot> \<sigma> x"
    by simp
  finally show ?thesis..
qed

lemma (in st_multimagma) s_ortho:
  "\<Delta> (\<sigma> x) (\<sigma> y) \<Longrightarrow> \<sigma> x = \<sigma> y"
proof-
  assume "\<Delta> (\<sigma> x) (\<sigma> y)"
  hence "\<tau> (\<sigma> x) = \<sigma> (\<sigma> y)"
    using local.Dst by blast
  thus ?thesis
    by simp
qed

lemma (in st_multimagma) s_ortho_iff:
  "\<Delta> (\<sigma> x) (\<sigma> y) = (\<sigma> x = \<sigma> y)"
  using local.s_ortho by auto

lemma (in st_multimagma) s_absorb_var:
  "(\<sigma> y \<noteq> \<sigma> x) = (\<sigma> y \<odot> x = {})"
  using local.Dst by force

lemma (in st_multimagma) s_absorb_var2:
  "(\<sigma> y = \<sigma> x) = (\<sigma> y \<odot> x \<noteq> {})"
  using local.s_absorb_var by blast

lemma (in st_multimagma) s_absorb_var3:
  "(\<sigma> y = \<sigma> x) = \<Delta> (\<sigma> x) y"
  by (metis local.s_absorb_var)

lemma (in st_multimagma) s_assoc:
  "{\<sigma> x} \<star> (\<sigma> y \<odot> z) = (\<sigma> x \<odot> \<sigma> y) \<star> {z}"
proof-
  {fix a
    have "(a \<in> {\<sigma> x} \<star> (\<sigma> y \<odot> z)) = (\<exists>b. a \<in> \<sigma> x \<odot> b \<and> b \<in> \<sigma> y \<odot> z)"
      by (simp add: local.conv_exp2)
    also have "\<dots> = (\<exists>b. a \<in> \<sigma> x \<odot> b \<and> b \<in> \<sigma> y \<odot> z \<and> \<sigma> y = \<sigma> z)"
    using local.s_absorb_var by auto
  also have "\<dots> = (\<exists>b. a \<in> \<sigma> x \<odot> b \<and> b \<in> \<sigma> y \<odot> z \<and> \<sigma> y = \<sigma> z \<and> \<sigma> x = \<sigma> y)"
    using local.stopp.Dst by fastforce
  also have "\<dots> = (\<exists>b. b \<in> \<sigma> x \<odot> \<sigma> y \<and> a \<in> b \<odot> z \<and> \<sigma> y = \<sigma> z \<and> \<sigma> x = \<sigma> y)"
    by fastforce
  also have "\<dots> = (\<exists>b. b \<in> \<sigma> x \<odot> \<sigma> y \<and> a \<in> b \<odot> z)"
    by (metis equals0D local.s_absorb_var3 local.s_idem singleton_iff)
  also have "\<dots> = (a \<in> (\<sigma> x \<odot> \<sigma> y) \<star> {z})"
    using local.conv_exp2 by auto
  finally have "(a \<in> {\<sigma> x} \<star> (\<sigma> y \<odot> z)) = (a \<in> (\<sigma> x \<odot> \<sigma> y) \<star> {z})".}
  thus ?thesis
    by blast
qed

lemma (in st_multimagma) sfix_absorb_var [simp]:
  "\<Union>{e \<odot> x |e. e \<in> sfix} = {x}"
  apply safe
   apply (metis local.Dst local.s_absorb local.ts_compat singletonD)
  by (smt (verit) UnionI insertI1 local.s_absorb local.ss_idem mem_Collect_eq)

lemma (in st_multimagma) tfix_absorb_var:
"\<Union>{x \<odot> e |e. e \<in> tfix} = {x}"
  using local.stopp.sfix_absorb_var by presburger

lemma (in st_multimagma) st_comm:
  "\<tau> x \<odot> \<sigma> y = \<sigma> y \<odot> \<tau> x"
  using local.Dst by fastforce

lemma (in st_multimagma) s_weak_twisted:
  "\<Union>{\<sigma> u \<odot> x |u. u \<in> x \<odot> y} \<subseteq> x \<odot> \<sigma> y"
  by (safe, metis empty_iff insertI1 local.Dst local.s_absorb local.t_absorb)

lemma (in st_multimagma) s_comm:
  "\<sigma> x \<odot> \<sigma> y = \<sigma> y \<odot> \<sigma> x"
  using local.Dst by force

lemma (in st_multimagma) s_export [simp]:
  "Src (\<sigma> x \<odot> y) = \<sigma> x \<odot> \<sigma> y"
  using local.Dst by force

lemma (in st_multimagma) st_prop:
  "(\<tau> x = \<sigma> y) = \<Delta> (\<tau> x) (\<sigma> y)"
  by (metis local.stopp.s_absorb_var2 local.stopp.st_comm local.ts_compat)

lemma (in st_multimagma) weak_local_var:
  "\<tau> x \<odot> \<sigma> y = {} \<Longrightarrow> x \<odot> y = {}"
  using local.Dst local.st_prop by auto

text \<open>The following facts hold by duality.\<close>

lemma (in st_multimagma) st_compat:
  "\<sigma> (\<tau> x) = \<tau> x"
  by simp

lemma (in st_multimagma) tt_idem:
  "\<tau> (\<tau> x) = \<tau> x"
  by simp

lemma (in st_multimagma) t_idem:
  "\<tau> x \<odot> \<tau> x = {\<tau> x}"
  by simp

lemma (in st_multimagma)t_weak_twisted:
  "\<Union>{x \<odot> \<tau> u |u. u \<in> y \<odot> x} \<subseteq> \<tau> y \<odot> x"
  using local.stopp.s_weak_twisted by auto

lemma (in st_multimagma) t_comm:
  "\<tau> x \<odot> \<tau> y = \<tau> y \<odot> \<tau> x"
  by (simp add: stopp.s_comm)

lemma (in st_multimagma) t_export:
  "image \<tau> (x \<odot> \<tau> y) = \<tau> x \<odot> \<tau> y"
  by simp

lemma (in st_multimagma) tt_comp_prop:
  "\<Delta> (\<tau> x) (\<tau> y) = (\<tau> x = \<tau> y)"
  using local.stopp.s_ortho_iff by force

text \<open>The set of all sources (and targets) are units at powerset level.\<close>

lemma (in st_multimagma) conv_uns [simp]:
  "sfix \<star> X = X"
proof-
  {fix a
    have "(a \<in> sfix \<star> X) = (\<exists>b \<in> sfix. \<exists>c \<in> X. a \<in> b \<odot> c)"
      by (meson local.conv_exp2)
    also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<sigma> b = b \<and> a \<in> b \<odot> c)"
      by blast
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. a \<in> \<sigma> b \<odot> c)"
    by (metis local.ss_idem)
  also have "\<dots> = (\<exists>c \<in> X. a \<in> \<sigma> c \<odot> c)"
    by (metis empty_iff local.s_absorb_var)
  also have "\<dots> = (a \<in> X)"
    by auto
  finally have "(a \<in> sfix \<star> X) = (a \<in> X)".}
  thus ?thesis
    by blast
qed

lemma (in st_multimagma) conv_unt:
  "X \<star> tfix = X"
  using stopp.conv_uns by blast

text \<open>We prove laws of modal powerset quantales.\<close>

lemma (in st_multimagma) Src_exp:
  "Src X = {\<sigma> x |x. x \<in> X}"
  by (simp add: Setcompr_eq_image)

lemma (in st_multimagma) ST_compat [simp]:
  "Src (Tgt X) = Tgt X"
  unfolding image_def by fastforce

lemma (in st_multimagma) TS_compat:
  "Tgt (Src X) = Src X"
  by (meson local.stopp.ST_compat)

lemma (in st_multimagma) Src_absorp [simp]:
  "Src X \<star> X = X"
proof-
  {fix a
  have "(a \<in> Src X \<star> X) = (\<exists>b \<in> Src X. \<exists>c \<in> X. a \<in> b \<odot> c)"
    using local.conv_exp2 by auto
  also have "\<dots> = (\<exists>b \<in> X. \<exists>c \<in> X. a \<in> \<sigma> b \<odot> c)"
    by blast
  also have "\<dots> = (\<exists>c \<in> X. a \<in> \<sigma> c \<odot> c)"
    by (metis empty_iff local.s_absorb_var)
 also have "\<dots> = (a \<in> X)"
   by simp
  finally have "(a \<in> Src X \<star> X) = (a \<in> X)".}
  thus ?thesis
    by force
qed

lemma (in st_multimagma) Tgt_absorp:
  "X \<star> Tgt X = X"
  by simp

lemma (in st_multimagma) Src_Sup_pres:
  "Src (\<Union>\<X>) = \<Union>{Src X |X. X \<in> \<X>}"
  unfolding Src_exp by auto

lemma (in st_multimagma) Tgt_Sup_pres:
  "Tgt (\<Union>\<X>) = \<Union>{Tgt X |X. X \<in> \<X>}"
  by blast

lemma (in st_multimagma) ST_comm:
  "Src X \<star> Tgt Y = Tgt Y \<star> Src X"
proof-
  {fix a
  have "(a \<in> Src X \<star> Tgt Y) = (\<exists>b \<in> Src X. \<exists>c \<in> Tgt Y. a \<in> b \<odot> c)"
    using local.conv_exp2 by auto
  also have "\<dots> = (\<exists>b \<in> X. \<exists>c \<in> Y. a \<in> \<sigma> b \<odot> \<tau> c)"
    by auto
  also have "\<dots> = (\<exists>b \<in> X. \<exists>c \<in> Y. a \<in> \<tau> c \<odot> \<sigma> b)"
    using local.st_comm by auto
  also have "\<dots> = (a \<in> Tgt Y \<star> Src X)"
    using multimagma.conv_exp2 by fastforce
  finally have "(a \<in> Src X \<star> Tgt Y) = (a \<in> Tgt Y \<star> Src X)".}
  thus ?thesis
    by force
qed

lemma (in st_multimagma) Src_comm:
  "Src X \<star> Src Y = Src Y \<star> Src X"
  by (metis local.ST_comm local.TS_compat)

lemma (in st_multimagma) Tgt_comm:
  "Tgt X \<star> Tgt Y = Tgt Y \<star> Tgt X"
  using local.stopp.Src_comm by presburger

lemma (in st_multimagma) Src_subid:
  "Src X \<subseteq> sfix"
  by force

lemma (in st_multimagma) Tgt_subid:
  "Tgt X \<subseteq> tfix"
  using local.stopp.Src_subid by presburger

lemma (in st_multimagma) Src_export [simp]:
  "Src (Src X \<star> Y) = Src X \<star> Src Y"
proof-
  {fix a
  have "(a \<in> Src (Src X \<star> Y)) = (\<exists>b \<in> Src X \<star> Y. a = \<sigma> b)"
    by (simp add: image_iff)
  also have "\<dots> = (\<exists>b. \<exists>c \<in> Src X. \<exists>d \<in> Y. a = \<sigma> b \<and> b \<in> c \<odot> d)"
    by (meson local.conv_exp2)
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Y. a = \<sigma> b \<and> b \<in> \<sigma> c \<odot> d)"
    by simp
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src (\<sigma> c \<odot> d))"
    by (metis (mono_tags, lifting) image_iff)
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> \<sigma> c \<odot> \<sigma> d)"
    by auto
  also have "\<dots> = (\<exists>c \<in> Src X. \<exists>d \<in> Src Y. a \<in> c \<odot> d)"
    by force
  also have "\<dots> = (a \<in> Src X \<star> Src Y)"
    using local.conv_exp2 by auto
  finally have "(a \<in> Src (Src X \<star> Y)) = (a \<in> Src X \<star> Src Y)".}
  thus ?thesis
    by force
qed

lemma (in st_multimagma) Tgt_export [simp]:
  "Tgt (X \<star> Tgt Y) = Tgt X \<star> Tgt Y"
  by simp

text \<open>Locality implies st-locality, which is the composition pattern of categories.\<close>

lemma (in st_multimagma) locality:
  assumes src_local: "Src (x \<odot> \<sigma> y) \<subseteq> Src (x \<odot> y)"
  and tgt_local: "Tgt (\<tau> x \<odot> y) \<subseteq> Tgt (x \<odot> y)"
  shows "\<Delta> x y  = (\<tau> x = \<sigma> y)"
  using local.Dst tgt_local by auto

subsection \<open>Catoids\<close>

class catoid = st_multimagma + multisemigroup

sublocale catoid \<subseteq> ts_msg: catoid "\<lambda>x y. y \<odot> x"  tgt src
  by (unfold_locales, simp add: local.assoc)

lemma (in catoid) src_comp_aux:
  "v \<in> x \<odot> y \<Longrightarrow> \<sigma> v = \<sigma> x"
  by (metis empty_iff insertI1 local.assoc_exp local.s_absorb local.s_absorb_var)

lemma (in catoid) src_comp:
  "Src (x \<odot> y) \<subseteq> {\<sigma> x}"
proof-
  {fix a
  assume "a \<in> Src (x \<odot> y)"
  hence "\<exists>b \<in> x \<odot> y. a = \<sigma> b"
    by auto
  hence "\<exists>b. \<sigma> b = \<sigma> x \<and> a = \<sigma> b"
    using local.src_comp_aux by blast
  hence "a = \<sigma> x"
    by blast}
  thus ?thesis
    by blast
qed

lemma (in catoid) src_comp_cond:
  "(\<Delta> x y) \<Longrightarrow> Src (x \<odot> y) = {\<sigma> x}"
  by (meson image_is_empty local.src_comp subset_singletonD)

lemma (in catoid) tgt_comp_aux:
  "v \<in> x \<odot> y \<Longrightarrow> \<tau> v = \<tau> y"
  using local.ts_msg.src_comp_aux by fastforce

lemma (in catoid) tgt_comp:
  "Tgt (x \<odot> y) \<subseteq> {\<tau> y}"
  by (simp add: local.ts_msg.src_comp)

lemma (in catoid) tgt_comp_cond:
  "\<Delta> x y \<Longrightarrow> Tgt (x \<odot> y) = {\<tau> y}"
  by (simp add: local.ts_msg.src_comp_cond)

lemma (in catoid) src_weak_local:
  "Src (x \<odot> y) \<subseteq> Src (x \<odot> \<sigma> y)"
proof-
  {fix a
  assume "a \<in> Src (x \<odot> y)"
  hence "\<exists>b \<in> x \<odot> y. a = \<sigma> b"
    by auto
  hence "\<exists>b \<in> x \<odot> y. a = \<sigma> b"
    by blast
  hence "\<exists>b \<in> x \<odot> y. a = \<sigma> b \<and> \<tau> x = \<sigma> y"
    using local.Dst by auto
  hence "\<exists>b \<in> x \<odot> \<sigma> y. a = \<sigma> b"
    by (metis insertI1 local.t_absorb local.ts_msg.tgt_comp_aux)
  hence "a \<in> Src (x \<odot> \<sigma> y)"
    by force}
  thus ?thesis
    by force
qed

lemma (in catoid) src_local_cond:
  "\<Delta> x y \<Longrightarrow> Src (x \<odot> y) = Src (x \<odot> \<sigma> y)"
  by (simp add: local.stopp.Dst local.ts_msg.tgt_comp_cond)

lemma (in catoid) tgt_weak_local:
  "Tgt (x \<odot> y) \<subseteq> Tgt (\<tau> x \<odot> y)"
  by (simp add: local.ts_msg.src_weak_local)

lemma (in catoid) tgt_local_cond:
  "\<Delta> x y \<Longrightarrow> Tgt (x \<odot> y) = Tgt (\<tau> x \<odot> y)"
  using local.ts_msg.src_local_cond by presburger

lemma (in catoid) src_twisted_aux:
  "u \<in> x \<odot> y \<Longrightarrow> (x \<odot> \<sigma> y = \<sigma> u \<odot> x)"
  by (metis local.Dst local.s_absorb local.src_comp_aux local.t_absorb)

lemma (in catoid) src_twisted_cond:
  "\<Delta> x y \<Longrightarrow> x \<odot> \<sigma> y = \<Union>{\<sigma> u \<odot> x |u. u \<in> x \<odot> y}"
   using local.stopp.Dst local.ts_msg.tgt_comp_aux by auto

lemma (in catoid) tgt_twisted_aux:
  "u \<in> x \<odot> y \<Longrightarrow> (\<tau> x \<odot> y = y \<odot> \<tau> u)"
  by (simp add: local.ts_msg.src_twisted_aux)

lemma (in catoid) tgt_twisted_cond:
  "\<Delta> x y  \<Longrightarrow> \<tau> x \<odot> y = \<Union>{y \<odot> \<tau> u |u. u \<in> x \<odot> y}"
  by (simp add: local.ts_msg.src_twisted_cond)

lemma (in catoid) src_funct:
  "x \<in> y \<odot> z \<Longrightarrow> x' \<in> y \<odot> z \<Longrightarrow> \<sigma> x = \<sigma> x'"
  using local.src_comp_aux by force

lemma (in catoid) st_local_iff:
  "(\<forall>x y. \<Delta> x y = (\<tau> x = \<sigma> y)) = (\<forall>v x y z. v \<in> x \<odot> y \<longrightarrow> \<Delta> y z \<longrightarrow> \<Delta> v z)"
  apply safe
    apply (metis local.ts_msg.src_comp_aux)
  using local.Dst apply blast
  by (metis local.s_absorb_var2 local.t_absorb singleton_iff)

text \<open>Again we can lift to properties of modal semirings and quantales.\<close>

lemma (in catoid) Src_weak_local:
  "Src (X \<star> Y) \<subseteq> Src (X \<star> Src Y)"
proof-
  {fix a
  assume "a \<in> Src (X \<star> Y)"
  hence "\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Y. a = \<sigma> b \<and> b \<in> c \<odot> d"
    by (smt (verit) image_iff local.conv_exp2)
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src (c \<odot> d)"
    by auto
  hence "\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src (c \<odot> \<sigma> d)"
    by (metis empty_iff image_empty local.src_local_cond)
  hence "\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Src Y. a = \<sigma> b \<and> b \<in> c \<odot> d"
    by auto
  hence "a \<in> Src (X \<star> Src Y)"
    by (metis image_iff local.conv_exp2)}
  thus ?thesis
    by blast
qed

lemma (in catoid) Tgt_weak_local:
  "Tgt (X \<star> Y) \<subseteq> Tgt (Tgt X \<star> Y)"
  by (metis local.stopp.conv_exp local.ts_msg.Src_weak_local multimagma.conv_exp)

text \<open>st-Locality implies locality.\<close>

lemma (in catoid) st_locality_l_locality:
  assumes "\<Delta> x y = (\<tau> x = \<sigma> y)"
  shows "Src (x \<odot> y) = Src (x \<odot> \<sigma> y)"
proof-
  {fix a
  have "(a \<in> Src (x \<odot> \<sigma> y)) = (\<exists>b \<in> x \<odot> \<sigma> y. a = \<sigma> b)"
    by auto
  also have "\<dots> = (\<exists>b \<in> x \<odot> \<sigma> y. a = \<sigma> b \<and> \<tau> x = \<sigma> y)"
    by (simp add: local.st_prop local.tgt_comp_aux local.tgt_twisted_aux)
  also have "\<dots> = (\<exists>b \<in> x \<odot> y. a = \<sigma> b)"
    by (metis assms equals0D equals0I insertI1 local.t_absorb local.ts_msg.tgt_comp_aux)
  also have "\<dots> = (a \<in> Src (x \<odot> y))"
    by auto
  finally have "(a \<in> Src (x \<odot> \<sigma> y)) = (a \<in> Src (x \<odot> y))".}
  thus ?thesis
    by force
qed

lemma (in catoid) st_locality_r_locality:
  assumes lr_locality: "\<Delta> x y = (\<tau> x = \<sigma> y)"
  shows  "Tgt (x \<odot> y) = Tgt (\<tau> x \<odot> y)"
  by (metis local.ts_msg.st_locality_l_locality lr_locality)

lemma (in catoid) st_locality_locality:
  "(Src (x \<odot> y) = Src (x \<odot> \<sigma> y) \<and> Tgt (x \<odot> y) = Tgt (\<tau> x \<odot> y)) = (\<Delta> x y = (\<tau> x = \<sigma> y))"
  apply standard
   apply (simp add: local.locality)
  by (metis local.st_locality_l_locality local.ts_msg.st_locality_l_locality)

subsection \<open>Locality\<close>

text \<open>For st-multimagmas there are different notions of locality. We do not develop this in detail.\<close>

class local_catoid = catoid +
  assumes src_local: "Src (x \<odot> \<sigma> y) \<subseteq> Src (x \<odot> y)"
  and tgt_local: "Tgt (\<tau> x \<odot> y) \<subseteq> Tgt (x \<odot> y)"

sublocale local_catoid \<subseteq> sts_msg: local_catoid "\<lambda>x y. y \<odot> x" tgt src
  apply unfold_locales using local.tgt_local local.src_local by auto

lemma (in local_catoid) src_local_eq [simp]:
  "Src (x \<odot> \<sigma> y) = Src (x \<odot> y)"
  by (simp add: local.src_local local.src_weak_local order_class.order_eq_iff)

lemma (in local_catoid) tgt_local_eq:
  "Tgt (\<tau> x \<odot> y) = Tgt (x \<odot> y)"
  by simp

lemma (in local_catoid) src_twisted:
  "x \<odot> \<sigma> y = \<Union>{\<sigma> u \<odot> x |u. u \<in> x \<odot> y}"
  by (metis Setcompr_eq_image Sup_empty empty_is_image local.src_twisted_cond local.sts_msg.tgt_local_eq)

lemma (in local_catoid) tgt_twisted:
  "\<tau> x \<odot> y = \<Union>{y \<odot> \<tau> u |u. u \<in> x \<odot> y}"
  using local.sts_msg.src_twisted by auto

lemma (in local_catoid) local_var:
  "\<Delta> x y \<Longrightarrow> \<Delta> (\<tau> x) (\<sigma> y)"
  by (simp add: local.stopp.Dst)

lemma (in local_catoid) local_var_eq [simp]:
  "\<Delta> (\<tau> x) (\<sigma> y) = \<Delta> x y"
  by (simp add: local.locality)

text \<open>We lift locality to powersets.\<close>

lemma (in local_catoid) Src_local [simp]:
  "Src (X \<star> Src Y) = Src (X \<star> Y)"
proof-
  {fix a
  have "(a \<in> Src (X \<star> Src Y)) = (\<exists>b \<in> X \<star> Src Y. a = \<sigma> b)"
    by (simp add: image_iff)
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Src Y. b \<in> c \<odot> d \<and> a = \<sigma> b)"
    by (meson local.conv_exp2)
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Y. b \<in> c \<odot> \<sigma> d \<and> a = \<sigma> b)"
    by simp
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src (c \<odot> \<sigma> d))"
    by blast
  also have "\<dots> = (\<exists>c \<in> X. \<exists>d \<in> Y. a \<in> Src (c \<odot> d))"
    by auto
  also have "\<dots> = (\<exists>b. \<exists>c \<in> X. \<exists>d \<in> Y. b \<in> c \<odot> d \<and> a = \<sigma> b)"
    by auto
  also have "\<dots> = (\<exists>b \<in> X \<star> Y. a = \<sigma> b)"
    by (meson local.conv_exp2)
  also have "\<dots> = (a \<in> Src (X \<star> Y))"
    by (simp add: image_iff)
  finally have "(a \<in> Src (X \<star> Src Y)) = (a \<in> Src (X \<star> Y))".}
  thus ?thesis
    by force
qed

lemma (in local_catoid) Tgt_local [simp]:
  "Tgt (Tgt X \<star> Y) = Tgt (X \<star> Y)"
  by (metis local.stopp.conv_def local.sts_msg.Src_local multimagma.conv_def)

lemma (in local_catoid) st_local: "\<Delta> x y = (\<tau> x = \<sigma> y)"
  using local.stopp.locality by force

subsection \<open>From partial magmas to single-set categories.\<close>

class functional_magma = multimagma +
  assumes functionality: "x \<in> y \<odot> z \<Longrightarrow> x' \<in> y \<odot> z \<Longrightarrow> x = x'"

begin

text \<open>Functional magmas could also be called partial magmas. The multioperation corresponds to a partial operation.\<close>

lemma partial_card: "card (x \<odot> y) \<le> 1"
  by (metis One_nat_def bot_nat_0.extremum card.infinite card_le_Suc0_iff_eq local.functionality)

lemma fun_in_sgl: "(x \<in> y \<odot> z) = ({x} = y \<odot> z)"
  using local.functionality by fastforce

definition pcomp :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70) where
  "x \<otimes> y = (THE z. z \<in> x \<odot> y)"

lemma functionality_var: "\<Delta> x y \<Longrightarrow> (\<exists>!z. z \<in> x \<odot> y)"
  using local.functionality by auto

lemma functionality_lem: "(\<exists>!z. z \<in> x \<odot> y) \<or> (x \<odot> y = {})"
  using functionality_var by blast

lemma pcomp_def_var: "(\<Delta> x y \<and> x \<otimes> y = z) = (z \<in> x \<odot> y)"
  unfolding pcomp_def by (smt (verit, del_insts) all_not_in_conv functionality_lem theI_unique)

lemma pcomp_def_var2: "\<Delta> x y  \<Longrightarrow> ((x \<otimes> y = z) = (z \<in> x \<odot> y))"
  using pcomp_def_var by blast

end

class functional_st_magma = functional_magma + st_multimagma

class functional_semigroup = functional_magma + multisemigroup

begin

lemma pcomp_assoc_defined: "(\<Delta> u v \<and> \<Delta> (u \<otimes> v) w) = (\<Delta> u (v \<otimes> w) \<and> \<Delta> v w)"
proof-
  have "(\<Delta> u v  \<and> \<Delta> (u \<otimes> v) w) = (\<exists>x. \<Delta> u v  \<and> \<Delta> x w  \<and> x = u \<otimes> v)"
    by simp
  also have "... = (\<exists>x. x \<in> u \<odot> v \<and> \<Delta> x w)"
    by (metis local.pcomp_def_var)
  also have "... = (\<exists>x. x \<in> v \<odot> w \<and> \<Delta> u x)"
    using local.assoc_exp by blast
  also have "... = (\<exists>x. \<Delta> v w  \<and> x = v \<otimes> w \<and> \<Delta> u x)"
    by (metis local.pcomp_def_var)
  also have "... = (\<Delta> u (v \<otimes> w) \<and> \<Delta> v w)"
    by auto
  finally show ?thesis.
qed

lemma pcomp_assoc: "\<Delta> x y \<and> \<Delta> (x \<otimes> y) z  \<Longrightarrow> (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
  by (smt (z3) local.assoc_exp local.functionality_lem local.pcomp_def_var2 pcomp_assoc_defined)

end

class functional_catoid = functional_semigroup + catoid

text \<open>Finally, here comes the definition of single-set categories as in Chapter 12 of Mac Lane's book,
but with partiality of arrow composition modelled using a multioperation.\<close>

class single_set_category = functional_catoid + local_catoid

begin

lemma st_assoc: "\<tau> x = \<sigma> y \<Longrightarrow> \<tau> y = \<sigma> z \<Longrightarrow> (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
  by (metis local.st_local local.pcomp_assoc local.pcomp_def_var2 local.tgt_comp_aux)

end

subsection  \<open>Morphisms of multimagmas and lr-multimagmas\<close>

text \<open>In the context of single-set categories, these morphisms are functors. Bounded morphisms
are functional bisimulations. They are known as zig-zag morphisms or p-morphism in modal and
substructural logics.\<close>

definition  mm_morphism :: "('a::multimagma \<Rightarrow> 'b::multimagma) \<Rightarrow> bool" where
  "mm_morphism f = (\<forall>x y. image f (x \<odot> y) \<subseteq> f x \<odot> f y)"

definition bounded_mm_morphism :: "('a::multimagma \<Rightarrow> 'b::multimagma) \<Rightarrow> bool" where
  "bounded_mm_morphism f = (mm_morphism f \<and> (\<forall>x u v. f x \<in> u \<odot> v \<longrightarrow> (\<exists>y z. u = f y \<and> v = f z \<and> x \<in> y \<odot> z)))"

definition st_mm_morphism :: "('a::st_multimagma \<Rightarrow> 'b::st_multimagma) \<Rightarrow> bool" where
  "st_mm_morphism f = (mm_morphism f \<and> f \<circ> \<sigma> = \<sigma> \<circ> f \<and> f \<circ> \<tau> = \<tau> \<circ> f)"

definition bounded_st_mm_morphism :: "('a::st_multimagma \<Rightarrow> 'b::st_multimagma) \<Rightarrow> bool" where
  "bounded_st_mm_morphism f = (bounded_mm_morphism f \<and> st_mm_morphism f)"

subsection \<open>Relationship with categories\<close>

text \<open>Next we add a standard definition of a category following Moerdijk and Mac Lane's book and,
for good measure, show that categories form single set categories and vice versa.\<close>

locale category =
  fixes id :: "'objects \<Rightarrow> 'arrows"
  and dom :: "'arrows \<Rightarrow> 'objects"
  and cod :: "'arrows \<Rightarrow> 'objects"
  and comp :: "'arrows \<Rightarrow> 'arrows \<Rightarrow> 'arrows" (infixl "\<bullet>" 70)
  assumes dom_id [simp]: "dom (id X) = X"
  and cod_id [simp]: "cod (id X) = X"
  and id_dom [simp]: "id (dom f) \<bullet> f = f"
  and id_cod [simp]: "f \<bullet> id (cod f) = f"
  and dom_loc [simp]: "cod f = dom g \<Longrightarrow> dom (f \<bullet> g) = dom f"
  and cod_loc [simp]: "cod f = dom g \<Longrightarrow> cod (f \<bullet> g) = cod g"
  and assoc: "cod f = dom g \<Longrightarrow> cod g = dom h \<Longrightarrow> (f \<bullet> g) \<bullet> h = f \<bullet> (g \<bullet> h)"

begin

lemma "cod f = dom g \<Longrightarrow> dom (f \<bullet> g) = dom (f \<bullet> id (dom g))"
  by simp

abbreviation "LL f \<equiv> id (dom f)"

abbreviation "RR f \<equiv> id (cod f)"

abbreviation "Comp \<equiv> \<lambda>f g. (if RR f = LL g then {f \<bullet> g} else {})"

end

typedef (overloaded) 'a::single_set_category st_objects = "{x::'a::single_set_category. \<sigma> x = x}"
  using stopp.tt_idem by blast

setup_lifting type_definition_st_objects

lemma Sfix_coerce [simp]: "Abs_st_objects (\<sigma> (Rep_st_objects X)) = X"
  by (metis (mono_tags, lifting) CollectD Rep_st_objects Rep_st_objects_inverse)

lemma Rfix_coerce [simp]: "Abs_st_objects (\<tau> (Rep_st_objects X)) = X"
  by (metis (mono_tags, lifting) CollectD Rep_st_objects Rep_st_objects_inverse stopp.st_fix)

sublocale single_set_category \<subseteq> sscatcat: category Rep_st_objects "Abs_st_objects \<circ> \<sigma>" "Abs_st_objects \<circ> \<tau>" "(\<otimes>)"
  apply unfold_locales
        apply simp_all
      apply (metis (mono_tags, lifting) Abs_st_objects_inverse empty_not_insert functional_magma_class.pcomp_def_var2 insertI1 mem_Collect_eq st_multimagma_class.s_absorb st_multimagma_class.ss_idem)
     apply (metis (mono_tags, lifting) Abs_st_objects_inverse functional_magma_class.pcomp_def_var insert_iff mem_Collect_eq st_multimagma_class.stopp.s_absorb st_multimagma_class.stopp.ts_compat)
    apply (metis (mono_tags, lifting) Abs_st_objects_inject catoid_class.ts_msg.tgt_comp_aux functional_magma_class.pcomp_def_var2 local_catoid_class.sts_msg.st_local mem_Collect_eq st_multimagma_class.stopp.ts_compat st_multimagma_class.stopp.tt_idem)
   apply (metis (mono_tags, lifting) Abs_st_objects_inject functional_semigroup_class.pcomp_assoc_defined local_catoid_class.sts_msg.st_local mem_Collect_eq st_multimagma_class.stopp.s_absorb_var st_multimagma_class.stopp.st_compat)
  by (metis (mono_tags, lifting) Abs_st_objects_inverse mem_Collect_eq single_set_category_class.st_assoc st_multimagma_class.stopp.st_compat st_multimagma_class.stopp.ts_compat)

sublocale category \<subseteq> catlrm: st_multimagma Comp  LL RR
  by unfold_locales auto

sublocale category \<subseteq> catsscat: single_set_category Comp LL RR
  apply unfold_locales
     apply simp_all
     apply (metis cod_loc dom_id dom_loc local.assoc)
    apply (metis empty_iff insert_iff)
   apply (metis dom_id dom_loc)
  by (metis cod_loc dom_id)

subsection \<open>A Mac Lane style variant\<close>

text \<open>Next we present an axiomatisation of single-set categories that follows Mac Lane's axioms
more closely, but still uses a multioperation for arrow composition.\<close>

class mlss_cat = functional_magma +
  fixes l0 :: "'a \<Rightarrow>'a"
  fixes r0 :: "'a \<Rightarrow>'a"
  assumes comp0_def: "(x \<odot> y \<noteq> {}) = (r0 x = l0 y)"
  assumes r0l0 [simp]: "r0 (l0 x) = l0 x"
  assumes l0r0 [simp]: "l0 (r0 x) = r0 x"
  assumes l0_absorb [simp]: "l0 x \<otimes> x = x"
  assumes r0_absorb [simp] : "x \<otimes> r0 x = x"
  assumes assoc_defined: "(u \<odot> v \<noteq> {} \<and> (u \<otimes> v) \<odot> w \<noteq> {}) = (u \<odot> (v \<otimes> w) \<noteq> {} \<and> v \<odot> w \<noteq> {})"
  assumes comp0_assoc: "r0 x = l0 y \<Longrightarrow> r0 y = l0 z \<Longrightarrow> x \<otimes> (y \<otimes> z) = (x \<otimes> y) \<otimes> z"
  assumes locall_var: "r0 x = l0 y \<Longrightarrow> l0 (x \<otimes> y) = l0 x"
  assumes localr_var: "r0 x = l0 y \<Longrightarrow> r0 (x \<otimes> y) = r0 y"

begin

lemma ml_locall [simp]: "l0 (x \<otimes> l0 y) = l0 (x \<otimes> y)"
  by (metis local.comp0_def local.l0_absorb local.locall_var local.pcomp_def local.r0l0)

lemma ml_localr [simp]: "r0 (r0 x \<otimes> y) = r0 (x \<otimes> y)"
  by (metis local.comp0_def local.l0r0 local.localr_var local.pcomp_def local.r0l0)

lemma ml_locall_im [simp]: "image l0 (x \<odot> l0 y) = image l0 (x \<odot> y)"
  by (smt (verit, ccfv_SIG) Collect_cong Setcompr_eq_image local.comp0_def local.l0r0 local.pcomp_def_var2 local.r0l0 ml_locall)

lemma ml_localr_im [simp]: "image r0 (r0 x \<odot> y) = image r0 (x \<odot> y)"
  by (smt (verit, ccfv_SIG) Collect_cong Setcompr_eq_image local.comp0_def local.l0r0 local.pcomp_def_var2 local.r0l0 ml_localr)

end

sublocale single_set_category \<subseteq> sscatml: mlss_cat "(\<odot>)" "\<sigma>" "\<tau>"
  apply unfold_locales
          apply (simp_all add: st_local pcomp_def_var2)
  using local.pcomp_assoc_defined local.st_local apply force
  using pcomp_assoc_defined st_assoc local.pcomp_def_var2 local.st_local local.src_comp_aux tgt_comp_aux by fastforce+

sublocale mlss_cat \<subseteq> mlsscat: single_set_category "(\<odot>)" "l0" "r0"
  apply unfold_locales
       apply (simp_all add: comp0_def)
    apply standard
     apply (clarsimp, smt (verit, ccfv_SIG) local.assoc_defined local.comp0_assoc local.comp0_def local.fun_in_sgl local.pcomp_def_var)
    apply (clarsimp, metis local.assoc_defined local.comp0_assoc local.comp0_def local.pcomp_def_var)
   apply (metis local.comp0_def local.fun_in_sgl local.l0_absorb local.pcomp_def_var2 local.r0l0)
  using local.comp0_def local.fun_in_sgl local.l0r0 local.pcomp_def_var2 local.r0_absorb by presburger

subsection \<open>Product of catoids\<close>

instantiation prod :: (catoid, catoid) catoid
begin

definition "src_prod x = (\<sigma> (fst x), \<sigma> (snd x))"
  for x :: "'a \<times> 'b"

definition "tgt_prod x = (\<tau> (fst x), \<tau> (snd x))"
  for x :: "'a \<times> 'b"

definition "mcomp_prod x y = {(u,v) |u v. u \<in> fst x \<odot> fst y \<and> v \<in> snd x \<odot> snd y}"
  for x y :: "'a \<times> 'b"

instance
proof
  fix x y z :: "'a \<times> 'b"
  show "\<Union>{x \<odot> v |v. v \<in> y \<odot> z} = \<Union>{v \<odot> z |v. v \<in> x \<odot> y}"
  proof-
    {fix a b
      have "((a,b) \<in> \<Union>{x \<odot> v |v. v \<in> y \<odot> z}) = (\<exists>v. (a,b) \<in> x \<odot> v \<and> v \<in> y \<odot> z)"
        by blast
      also have "\<dots> = (\<exists>v w. a \<in> fst x \<odot> v \<and> v \<in> fst y \<odot> fst z \<and> b \<in> snd x \<odot> w \<and> w \<in> snd y \<odot> snd z)"
        using mcomp_prod_def by auto
      also have "\<dots> = (\<exists>v w. a \<in> v \<odot> fst z \<and> v \<in> fst x \<odot> fst y \<and> b \<in> w \<odot> snd z \<and> w \<in> snd x \<odot> snd y)"
        by (meson ts_msg.assoc_exp)
      also have "\<dots> = (\<exists>v. (a,b) \<in> v \<odot> z \<and> v \<in> x \<odot> y)"
        using mcomp_prod_def by auto
      also have "\<dots> = ((a,b) \<in> \<Union>{v \<odot> z |v. v \<in> x \<odot> y})"
        by blast
      finally have "((a,b) \<in> \<Union>{x \<odot> v |v. v \<in> y \<odot> z}) = ((a,b) \<in> \<Union>{v \<odot> z |v. v \<in> x \<odot> y})".}
    thus ?thesis
      by (meson pred_equals_eq2)
  qed
  show "x \<odot> y \<noteq> {} \<Longrightarrow> \<tau> x = \<sigma> y"
    by (simp add: Catoid.mcomp_prod_def Dst src_prod_def tgt_prod_def)
  show "\<sigma> x \<odot> x = {x}"
    unfolding src_prod_def mcomp_prod_def by simp
  show "x \<odot> \<tau> x = {x}"
    unfolding tgt_prod_def mcomp_prod_def by simp
qed

end

instantiation prod :: (single_set_category, single_set_category) single_set_category
begin

instance
proof
  fix x y z x' :: "'a \<times> 'b"
  show "x \<in> y \<odot> z \<Longrightarrow> x' \<in> y \<odot> z \<Longrightarrow> x = x'"
    unfolding mcomp_prod_def by (smt (verit, best) functionality mem_Collect_eq)
  show a: "stopp.Tgt (x \<odot> \<sigma> y) \<subseteq> stopp.Tgt (x \<odot> y)"
  proof-
    {fix a b
      have "((a,b) \<in> stopp.Tgt (x \<odot> \<sigma> y)) = ((a,b) \<in> Src {(c,d) |c d. c \<in> fst x \<odot> \<sigma> (fst y) \<and> d \<in> snd x \<odot> \<sigma> (snd y)})"
        by (simp add: mcomp_prod_def src_prod_def)
      also have "\<dots> = (a \<in> Src (fst x \<odot> \<sigma> (fst y)) \<and> b \<in> Src (snd x \<odot> \<sigma> (snd y)))"
        by (smt (z3) Setcompr_eq_image fst_conv mem_Collect_eq snd_conv src_prod_def stopp.tt_idem)
      also have "\<dots> = (a \<in> Src (fst x \<odot> fst y) \<and> b \<in> Src (snd x \<odot> snd y))"
        by simp
      also have "\<dots> = ((a,b) \<in> Src {(c,d) |c d. c \<in> (fst x \<odot> fst y) \<and> d \<in> (snd x \<odot> snd y)})"
        by (smt (z3) Setcompr_eq_image fst_conv mem_Collect_eq snd_conv src_prod_def stopp.tt_idem)
      also have "\<dots> = ((a,b) \<in> stopp.Tgt (x \<odot> y))"
        by (simp add: mcomp_prod_def src_prod_def)
      finally have "((a,b) \<in> stopp.Tgt (x \<odot> \<sigma> y)) = ((a,b) \<in> stopp.Tgt (x \<odot> y))".}
    thus ?thesis
      by auto
  qed
  show "Tgt (\<tau> x \<odot> y) \<subseteq> Tgt (x \<odot> y)"
    by (metis (no_types, lifting) a bot.extremum_uniqueI empty_is_image stopp.s_absorb_var3 tgt_local_cond tgt_weak_local ts_msg.st_locality_l_locality)
qed

end

end


(*  Title:       Computing Square Roots using the Babylonian Method
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2009-2014 René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)
header {* Auxiliary lemmas which might be moved into the Isabelle distribution. *}

theory Sqrt_Babylonian_Auxiliary
imports
  "~~/src/HOL/Transcendental"
begin

lemma mod_div_equality_int: "(n :: int) div x * x = n - n mod x"
  using mod_div_equality[of n x] by arith

lemma log_pow_cancel[simp]: "a > 0 \<Longrightarrow> a \<noteq> 1 \<Longrightarrow> log a (a ^ b) = b"
  by (metis comm_monoid_mult_class.mult.right_neutral log_eq_one log_nat_power)

lemma real_of_rat_floor[simp]: "floor (real_of_rat x) = floor x"
  by (metis Ratreal_def real_floor_code)

lemma abs_of_rat[simp]: "\<bar>real_of_rat x\<bar> = real_of_rat \<bar>x\<bar>"
proof (cases "x \<ge> 0")
  case False
  def y \<equiv> "- x"
  from False have y: "y \<ge> 0" "x = - y" by (auto simp: y_def)
  thus ?thesis by (auto simp: of_rat_minus)
qed auto

lemma real_of_rat_ceiling[simp]: "ceiling (real_of_rat x) = ceiling x"
  unfolding ceiling_def by (metis of_rat_minus real_of_rat_floor)

lemma div_is_floor_divide_rat: "n div y = \<lfloor>rat_of_int n / rat_of_int y\<rfloor>"
  unfolding Fract_of_int_quotient[symmetric] floor_Fract by simp

lemma div_is_floor_divide_real: "n div y = \<lfloor>real_of_int n / of_int y\<rfloor>"
  unfolding div_is_floor_divide_rat[of n y]
  by (metis Ratreal_def of_rat_divide of_rat_of_int_eq real_floor_code)

lemma floor_div_pos_int:
  fixes r :: "'a :: floor_ceiling"
  assumes n: "n > 0"
  shows "\<lfloor>r / of_int n\<rfloor> = \<lfloor>r\<rfloor> div n" (is "?l = ?r")
proof -
  let ?of_int = "of_int :: int \<Rightarrow> 'a"
  def rhs \<equiv> "\<lfloor>r\<rfloor> div n"
  let ?n = "?of_int n"
  def m \<equiv> "\<lfloor>r\<rfloor> mod n"
  let ?m = "?of_int m"
  from mod_div_equality[of "floor r" n] have dm: "rhs * n + m = \<lfloor>r\<rfloor>" unfolding rhs_def m_def by simp
  have mn: "m < n" and m0: "m \<ge> 0" using n m_def by auto
  def e \<equiv> "r - ?of_int \<lfloor>r\<rfloor>"
  have e0: "e \<ge> 0" unfolding e_def
    by (metis diff_self eq_iff floor_diff_of_int zero_le_floor)
  have e1: "e < 1" unfolding e_def
    by (metis diff_self dual_order.refl floor_diff_of_int floor_le_zero)
  have "r = ?of_int \<lfloor>r\<rfloor> + e" unfolding e_def by simp
  also have "\<lfloor>r\<rfloor> = rhs * n + m" using dm by simp
  finally have "r = ?of_int (rhs * n + m) + e" .
  hence "r / ?n = ?of_int (rhs * n) / ?n + (e + ?m) / ?n" using n by (simp add: field_simps)
  also have "?of_int (rhs * n) / ?n = ?of_int rhs" using n by auto
  finally have *: "r / ?of_int n = (e + ?of_int m) / ?of_int n + ?of_int rhs" by simp
  have "?l = rhs + floor ((e + ?m) / ?n)" unfolding * by simp
  also have "floor ((e + ?m) / ?n) = 0"
  proof (rule floor_unique)
    show "?of_int 0 \<le> (e + ?m) / ?n" using e0 m0 n
      by (metis add_increasing2 divide_nonneg_pos of_int_0 of_int_0_le_iff of_int_0_less_iff)
    show "(e + ?m) / ?n < ?of_int 0 + 1"
    proof (rule ccontr)
      from n have n': "?n > 0" "?n \<ge> 0" by simp_all
      assume "\<not> ?thesis"
      hence "(e + ?m) / ?n \<ge> 1" by auto
      from mult_right_mono[OF this n'(2)]
      have "?n \<le> e + ?m" using n'(1) by simp
      also have "?m \<le> ?n - 1" using mn
        by (metis of_int_1 of_int_diff of_int_le_iff zle_diff1_eq)
      finally have "?n \<le> e + ?n - 1" by auto
      with e1 show False by arith
    qed
  qed
  finally show ?thesis unfolding rhs_def by simp
qed

lemma floor_div_neg_int:
  fixes r :: "'a :: floor_ceiling"
  assumes n: "n < 0"
  shows "\<lfloor>r / of_int n\<rfloor> = \<lceil>r\<rceil> div n"
proof -
  from n have n': "- n > 0" by auto
  have "\<lfloor>r / of_int n\<rfloor> = \<lfloor> - r / of_int (- n)\<rfloor>" using n
    by (metis floor_of_int floor_zero less_int_code(1) minus_divide_left minus_minus nonzero_minus_divide_right of_int_minus)
  also have "\<dots> = \<lfloor> - r \<rfloor> div (- n)" by (rule floor_div_pos_int[OF n'])
  also have "\<dots> = \<lceil> r \<rceil> div n" using n
  by (metis ceiling_def div_minus_right)
  finally show ?thesis .
qed

lemma divide_less_floor1: "n / y < of_int (floor (n / y)) + 1"
  by (metis floor_less_iff less_add_one of_int_1 of_int_add)

context linordered_idom
begin
lemma sgn_int_pow[simp]: "sgn ((x :: 'a) ^ p) = sgn x ^ p"
  by (induct p, auto simp: sgn_times)

lemma sgn_int_pow_if[simp]: assumes x: "(x :: 'a) \<noteq> 0"
  shows "sgn x ^ p = (if even p then 1 else sgn x)"
proof (induct p, auto)
  show "sgn x * sgn x = 1" using x
  by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero sgn_pos sgn_times)
qed

lemma compare_pow_le_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p \<le> y ^ p) = (x \<le> y)"
  by (metis eq_iff linear power_eq_imp_eq_base power_mono)

lemma compare_pow_less_iff: "p > 0 \<Longrightarrow> (x :: 'a) \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> (x ^ p < y ^ p) = (x < y)"
  by (metis power_less_imp_less_base power_strict_mono)
end

lemma quotient_of_int[simp]: "quotient_of (of_int i) = (i,1)"
  by (metis Rat.of_int_def quotient_of_int)

lemma quotient_of_nat[simp]: "quotient_of (of_nat i) = (int i,1)"
  by (metis Rat.of_int_def Rat.quotient_of_int of_int_of_nat_eq)

lemma square_lesseq_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x \<le> y * y) = (x \<le> y)"
  by (metis mult_mono mult_strict_mono' not_less)

lemma square_less_square: "\<And> x y. 0 \<le> (x :: 'a :: linordered_field) \<Longrightarrow> 0 \<le> y \<Longrightarrow> (x * x < y * y) = (x < y)"
  by (metis mult_mono mult_strict_mono' not_less)

lemma sqrt_sqrt[simp]: "x \<ge> 0 \<Longrightarrow> sqrt x * sqrt x = x"
  by (metis real_sqrt_pow2 power2_eq_square)

lemma abs_lesseq_square: "abs (x :: real) \<le> abs y \<longleftrightarrow> x * x \<le> y * y"
  using square_lesseq_square[of "abs x" "abs y"] by auto

end


(*<*)
theory sol05
imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Small_Step"
begin
(*>*)
text {* \ExerciseSheet{5}{11.~11.~2014, 11:11am} *}
text {* \Exercise{Program Equivalence}

Prove or disprove (by giving counterexamples) the following program equivalences.
\begin{enumerate}
\item
\mbox{@{term "IF And b1 b2 THEN c1 ELSE c2 \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"}}
\item
@{term "WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c"}
\item
@{term "WHILE And b1 b2 DO c \<sim> WHILE b1 DO c;; WHILE And b1 b2 DO c"}
\item
@{term "WHILE Or b1 b2 DO c \<sim> WHILE Or b1 b2 DO c;; WHILE b1 DO c"}
\end{enumerate}
*}

(*
a) equivalent, see below
b) not equivalent:  {a=2, b=1} while (a < 3 & b < 2) do a := 4
c) not equivalent:  {a=1}      while (a < 2 & a < 1) do a := 4
d) equivalent, see below
*)

text {* Hint: Use the following definition for @{text Or}: *}

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
  "Or b1 b2 = Not (And (Not b1) (Not b2))"

(*<*)
lemma
  "IF And b1 b2 THEN c1 ELSE c2 \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"
  (is "?i \<sim> ?ii")
proof -  (* sledgehammer also proves this, but here is a detailed proof *)
  {
    fix s t
    assume "(?i, s) \<Rightarrow> t"
    moreover
    {
      assume "bval b1 s \<and> bval b2 s"
      hence "bval (And b1 b2) s" by simp
    }
    moreover
    {
      assume "\<not>bval b1 s \<or> \<not>bval b2 s"
      hence "\<not>bval (And b1 b2) s" by simp
    }
    ultimately
    have "(?ii, s) \<Rightarrow> t" by blast
  }
  then show ?thesis by auto (* the other direction is automatic *)
qed

text {* At the end of a loop the condition is always false *}

lemma While_end: "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> \<not>bval b t"
proof(induction "WHILE b DO c" s t rule: big_step_induct)
  case WhileFalse thus ?case .
next
  case WhileTrue show ?case by fact
qed

(** Alternative proof **)
lemma "(WHILE b DO c, s) \<Rightarrow> t \<Longrightarrow> \<not>bval b t"
proof -
  assume "(WHILE b DO c, s) \<Rightarrow> t"
  then obtain c' where "(c', s) \<Rightarrow> t" and "c' = WHILE b DO c" by blast
  then show "\<not>bval b t"
    by (induct c' s t rule: big_step_induct) auto
qed

lemma "WHILE Or b1 b2 DO c \<sim> WHILE Or b1 b2 DO c;; WHILE b1 DO c"
proof -
  {
    fix s
    assume "\<not>bval (Or b1 b2) s"
    hence "\<not>bval b1 s" by (auto simp add: Or_def)
  }
  then show ?thesis by (blast intro!: While_end)
qed
(*>*)

(*<*)
end
(*>*)


(*  Title:      HOL/Library/Disjoint_Sets.thy
    Author:     Johannes Hölzl, TU München
*)

section \<open>Partitions and Disjoint Sets\<close>

theory Disjoint_Sets
  imports Main
begin

lemma range_subsetD: "range f \<subseteq> B \<Longrightarrow> f i \<in> B"
  by blast

lemma Int_Diff_disjoint: "A \<inter> B \<inter> (A - B) = {}"
  by blast

lemma Int_Diff_Un: "A \<inter> B \<union> (A - B) = A"
  by blast

lemma mono_Un: "mono A \<Longrightarrow> (\<Union>i\<le>n. A i) = A n"
  unfolding mono_def by auto

lemma disjnt_equiv_class: "equiv A r \<Longrightarrow> disjnt (r``{a}) (r``{b}) \<longleftrightarrow> (a, b) \<notin> r"
  by (auto dest: equiv_class_self simp: equiv_class_eq_iff disjnt_def)

subsection \<open>Set of Disjoint Sets\<close>

abbreviation disjoint :: "'a set set \<Rightarrow> bool" where "disjoint \<equiv> pairwise disjnt"

lemma disjoint_def: "disjoint A \<longleftrightarrow> (\<forall>a\<in>A. \<forall>b\<in>A. a \<noteq> b \<longrightarrow> a \<inter> b = {})"
  unfolding pairwise_def disjnt_def by auto

lemma disjointI:
  "(\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}) \<Longrightarrow> disjoint A"
  unfolding disjoint_def by auto

lemma disjointD:
  "disjoint A \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> a \<inter> b = {}"
  unfolding disjoint_def by auto

lemma disjoint_image: "inj_on f (\<Union>A) \<Longrightarrow> disjoint A \<Longrightarrow> disjoint ((`) f ` A)"
  unfolding inj_on_def disjoint_def by blast

lemma assumes "disjoint (A \<union> B)"
      shows   disjoint_unionD1: "disjoint A" and disjoint_unionD2: "disjoint B"
  using assms by (simp_all add: disjoint_def)

lemma disjoint_INT:
  assumes *: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)"
  shows "disjoint {\<Inter>i\<in>I. X i | X. \<forall>i\<in>I. X i \<in> F i}"
proof (safe intro!: disjointI del: equalityI)
  fix A B :: "'a \<Rightarrow> 'b set" assume "(\<Inter>i\<in>I. A i) \<noteq> (\<Inter>i\<in>I. B i)"
  then obtain i where "A i \<noteq> B i" "i \<in> I"
    by auto
  moreover assume "\<forall>i\<in>I. A i \<in> F i" "\<forall>i\<in>I. B i \<in> F i"
  ultimately show "(\<Inter>i\<in>I. A i) \<inter> (\<Inter>i\<in>I. B i) = {}"
    using *[OF \<open>i\<in>I\<close>, THEN disjointD, of "A i" "B i"]
    by (auto simp flip: INT_Int_distrib)
qed

lemma diff_Union_pairwise_disjoint:
  assumes "pairwise disjnt \<A>" "\<B> \<subseteq> \<A>"
  shows "\<Union>\<A> - \<Union>\<B> = \<Union>(\<A> - \<B>)"
proof -
  have "False"
    if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
  proof -
    have "A \<inter> B = {}"
      using assms disjointD AB by blast
  with x show ?thesis
    by blast
  qed
  then show ?thesis by auto
qed

lemma Int_Union_pairwise_disjoint:
  assumes "pairwise disjnt (\<A> \<union> \<B>)"
  shows "\<Union>\<A> \<inter> \<Union>\<B> = \<Union>(\<A> \<inter> \<B>)"
proof -
  have "False"
    if x: "x \<in> A" "x \<in> B" and AB: "A \<in> \<A>" "A \<notin> \<B>" "B \<in> \<B>" for x A B
  proof -
    have "A \<inter> B = {}"
      using assms disjointD AB by blast
  with x show ?thesis
    by blast
  qed
  then show ?thesis by auto
qed

lemma psubset_Union_pairwise_disjoint:
  assumes \<B>: "pairwise disjnt \<B>" and "\<A> \<subset> \<B> - {{}}"
  shows "\<Union>\<A> \<subset> \<Union>\<B>"
  unfolding psubset_eq
proof
  show "\<Union>\<A> \<subseteq> \<Union>\<B>"
    using assms by blast
  have "\<A> \<subseteq> \<B>" "\<Union>(\<B> - \<A> \<inter> (\<B> - {{}})) \<noteq> {}"
    using assms by blast+
  then show "\<Union>\<A> \<noteq> \<Union>\<B>"
    using diff_Union_pairwise_disjoint [OF \<B>] by blast
qed

subsubsection "Family of Disjoint Sets"

definition disjoint_family_on :: "('i \<Rightarrow> 'a set) \<Rightarrow> 'i set \<Rightarrow> bool" where
  "disjoint_family_on A S \<longleftrightarrow> (\<forall>m\<in>S. \<forall>n\<in>S. m \<noteq> n \<longrightarrow> A m \<inter> A n = {})"

abbreviation "disjoint_family A \<equiv> disjoint_family_on A UNIV"

lemma disjoint_family_elem_disjnt:
  assumes "infinite A" "finite C"
      and df: "disjoint_family_on B A"
  obtains x where "x \<in> A" "disjnt C (B x)"
proof -
  have "False" if *: "\<forall>x \<in> A. \<exists>y. y \<in> C \<and> y \<in> B x"
  proof -
    obtain g where g: "\<forall>x \<in> A. g x \<in> C \<and> g x \<in> B x"
      using * by metis
    with df have "inj_on g A"
      by (fastforce simp add: inj_on_def disjoint_family_on_def)
    then have "infinite (g ` A)"
      using \<open>infinite A\<close> finite_image_iff by blast
    then show False
      by (meson \<open>finite C\<close> finite_subset g image_subset_iff)
  qed
  then show ?thesis
    by (force simp: disjnt_iff intro: that)
qed

lemma disjoint_family_onD:
  "disjoint_family_on A I \<Longrightarrow> i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> i \<noteq> j \<Longrightarrow> A i \<inter> A j = {}"
  by (auto simp: disjoint_family_on_def)

lemma disjoint_family_subset: "disjoint_family A \<Longrightarrow> (\<And>x. B x \<subseteq> A x) \<Longrightarrow> disjoint_family B"
  by (force simp add: disjoint_family_on_def)

lemma disjoint_family_on_bisimulation:
  assumes "disjoint_family_on f S"
  and "\<And>n m. n \<in> S \<Longrightarrow> m \<in> S \<Longrightarrow> n \<noteq> m \<Longrightarrow> f n \<inter> f m = {} \<Longrightarrow> g n \<inter> g m = {}"
  shows "disjoint_family_on g S"
  using assms unfolding disjoint_family_on_def by auto

lemma disjoint_family_on_mono:
  "A \<subseteq> B \<Longrightarrow> disjoint_family_on f B \<Longrightarrow> disjoint_family_on f A"
  unfolding disjoint_family_on_def by auto

lemma disjoint_family_Suc:
  "(\<And>n. A n \<subseteq> A (Suc n)) \<Longrightarrow> disjoint_family (\<lambda>i. A (Suc i) - A i)"
  using lift_Suc_mono_le[of A]
  by (auto simp add: disjoint_family_on_def)
     (metis insert_absorb insert_subset le_SucE le_antisym not_le_imp_less less_imp_le)

lemma disjoint_family_on_disjoint_image:
  "disjoint_family_on A I \<Longrightarrow> disjoint (A ` I)"
  unfolding disjoint_family_on_def disjoint_def by force

lemma disjoint_family_on_vimageI: "disjoint_family_on F I \<Longrightarrow> disjoint_family_on (\<lambda>i. f -` F i) I"
  by (auto simp: disjoint_family_on_def)

lemma disjoint_image_disjoint_family_on:
  assumes d: "disjoint (A ` I)" and i: "inj_on A I"
  shows "disjoint_family_on A I"
  unfolding disjoint_family_on_def
proof (intro ballI impI)
  fix n m assume nm: "m \<in> I" "n \<in> I" and "n \<noteq> m"
  with i[THEN inj_onD, of n m] show "A n \<inter> A m = {}"
    by (intro disjointD[OF d]) auto
qed

lemma disjoint_UN:
  assumes F: "\<And>i. i \<in> I \<Longrightarrow> disjoint (F i)" and *: "disjoint_family_on (\<lambda>i. \<Union>(F i)) I"
  shows "disjoint (\<Union>i\<in>I. F i)"
proof (safe intro!: disjointI del: equalityI)
  fix A B i j assume "A \<noteq> B" "A \<in> F i" "i \<in> I" "B \<in> F j" "j \<in> I"
  show "A \<inter> B = {}"
  proof cases
    assume "i = j" with F[of i] \<open>i \<in> I\<close> \<open>A \<in> F i\<close> \<open>B \<in> F j\<close> \<open>A \<noteq> B\<close> show "A \<inter> B = {}"
      by (auto dest: disjointD)
  next
    assume "i \<noteq> j"
    with * \<open>i\<in>I\<close> \<open>j\<in>I\<close> have "(\<Union>(F i)) \<inter> (\<Union>(F j)) = {}"
      by (rule disjoint_family_onD)
    with \<open>A\<in>F i\<close> \<open>i\<in>I\<close> \<open>B\<in>F j\<close> \<open>j\<in>I\<close>
    show "A \<inter> B = {}"
      by auto
  qed
qed

lemma distinct_list_bind:
  assumes "distinct xs" "\<And>x. x \<in> set xs \<Longrightarrow> distinct (f x)"
          "disjoint_family_on (set \<circ> f) (set xs)"
  shows   "distinct (List.bind xs f)"
  using assms
  by (induction xs)
     (auto simp: disjoint_family_on_def distinct_map inj_on_def set_list_bind)

lemma bij_betw_UNION_disjoint:
  assumes disj: "disjoint_family_on A' I"
  assumes bij: "\<And>i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
  shows   "bij_betw f (\<Union>i\<in>I. A i) (\<Union>i\<in>I. A' i)"
unfolding bij_betw_def
proof
  from bij show eq: "f ` \<Union>(A ` I) = \<Union>(A' ` I)"
    by (auto simp: bij_betw_def image_UN)
  show "inj_on f (\<Union>(A ` I))"
  proof (rule inj_onI, clarify)
    fix i j x y assume A: "i \<in> I" "j \<in> I" "x \<in> A i" "y \<in> A j" and B: "f x = f y"
    from A bij[of i] bij[of j] have "f x \<in> A' i" "f y \<in> A' j"
      by (auto simp: bij_betw_def)
    with B have "A' i \<inter> A' j \<noteq> {}" by auto
    with disj A have "i = j" unfolding disjoint_family_on_def by blast
    with A B bij[of i] show "x = y" by (auto simp: bij_betw_def dest: inj_onD)
  qed
qed

lemma disjoint_union: "disjoint C \<Longrightarrow> disjoint B \<Longrightarrow> \<Union>C \<inter> \<Union>B = {} \<Longrightarrow> disjoint (C \<union> B)"
  using disjoint_UN[of "{C, B}" "\<lambda>x. x"] by (auto simp add: disjoint_family_on_def)

text \<open>
  The union of an infinite disjoint family of non-empty sets is infinite.
\<close>
lemma infinite_disjoint_family_imp_infinite_UNION:
  assumes "\<not>finite A" "\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> {}" "disjoint_family_on f A"
  shows   "\<not>finite (\<Union>(f ` A))"
proof -
  define g where "g x = (SOME y. y \<in> f x)" for x
  have g: "g x \<in> f x" if "x \<in> A" for x
    unfolding g_def by (rule someI_ex, insert assms(2) that) blast
  have inj_on_g: "inj_on g A"
  proof (rule inj_onI, rule ccontr)
    fix x y assume A: "x \<in> A" "y \<in> A" "g x = g y" "x \<noteq> y"
    with g[of x] g[of y] have "g x \<in> f x" "g x \<in> f y" by auto
    with A \<open>x \<noteq> y\<close> assms show False
      by (auto simp: disjoint_family_on_def inj_on_def)
  qed
  from g have "g ` A \<subseteq> \<Union>(f ` A)" by blast
  moreover from inj_on_g \<open>\<not>finite A\<close> have "\<not>finite (g ` A)"
    using finite_imageD by blast
  ultimately show ?thesis using finite_subset by blast
qed

subsection \<open>Construct Disjoint Sequences\<close>

definition disjointed :: "(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set" where
  "disjointed A n = A n - (\<Union>i\<in>{0..<n}. A i)"

lemma finite_UN_disjointed_eq: "(\<Union>i\<in>{0..<n}. disjointed A i) = (\<Union>i\<in>{0..<n}. A i)"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  thus ?case by (simp add: atLeastLessThanSuc disjointed_def)
qed

lemma UN_disjointed_eq: "(\<Union>i. disjointed A i) = (\<Union>i. A i)"
  by (rule UN_finite2_eq [where k=0])
     (simp add: finite_UN_disjointed_eq)

lemma less_disjoint_disjointed: "m < n \<Longrightarrow> disjointed A m \<inter> disjointed A n = {}"
  by (auto simp add: disjointed_def)

lemma disjoint_family_disjointed: "disjoint_family (disjointed A)"
  by (simp add: disjoint_family_on_def)
     (metis neq_iff Int_commute less_disjoint_disjointed)

lemma disjointed_subset: "disjointed A n \<subseteq> A n"
  by (auto simp add: disjointed_def)

lemma disjointed_0[simp]: "disjointed A 0 = A 0"
  by (simp add: disjointed_def)

lemma disjointed_mono: "mono A \<Longrightarrow> disjointed A (Suc n) = A (Suc n) - A n"
  using mono_Un[of A] by (simp add: disjointed_def atLeastLessThanSuc_atLeastAtMost atLeast0AtMost)

subsection \<open>Partitions\<close>

text \<open>
  Partitions \<^term>\<open>P\<close> of a set \<^term>\<open>A\<close>. We explicitly disallow empty sets.
\<close>

definition partition_on :: "'a set \<Rightarrow> 'a set set \<Rightarrow> bool"
where
  "partition_on A P \<longleftrightarrow> \<Union>P = A \<and> disjoint P \<and> {} \<notin> P"

lemma partition_onI:
  "\<Union>P = A \<Longrightarrow> (\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> p \<noteq> q \<Longrightarrow> disjnt p q) \<Longrightarrow> {} \<notin> P \<Longrightarrow> partition_on A P"
  by (auto simp: partition_on_def pairwise_def)

lemma partition_onD1: "partition_on A P \<Longrightarrow> A = \<Union>P"
  by (auto simp: partition_on_def)

lemma partition_onD2: "partition_on A P \<Longrightarrow> disjoint P"
  by (auto simp: partition_on_def)

lemma partition_onD3: "partition_on A P \<Longrightarrow> {} \<notin> P"
  by (auto simp: partition_on_def)

subsection \<open>Constructions of partitions\<close>

lemma partition_on_empty: "partition_on {} P \<longleftrightarrow> P = {}"
  unfolding partition_on_def by fastforce

lemma partition_on_space: "A \<noteq> {} \<Longrightarrow> partition_on A {A}"
  by (auto simp: partition_on_def disjoint_def)

lemma partition_on_singletons: "partition_on A ((\<lambda>x. {x}) ` A)"
  by (auto simp: partition_on_def disjoint_def)

lemma partition_on_transform:
  assumes P: "partition_on A P"
  assumes F_UN: "\<Union>(F ` P) = F (\<Union>P)" and F_disjnt: "\<And>p q. p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (F p) (F q)"
  shows "partition_on (F A) (F ` P - {{}})"
proof -
  have "\<Union>(F ` P - {{}}) = F A"
    unfolding P[THEN partition_onD1] F_UN[symmetric] by auto
  with P show ?thesis
    by (auto simp add: partition_on_def pairwise_def intro!: F_disjnt)
qed

lemma partition_on_restrict: "partition_on A P \<Longrightarrow> partition_on (B \<inter> A) ((\<inter>) B ` P - {{}})"
  by (intro partition_on_transform) (auto simp: disjnt_def)

lemma partition_on_vimage: "partition_on A P \<Longrightarrow> partition_on (f -` A) ((-`) f ` P - {{}})"
  by (intro partition_on_transform) (auto simp: disjnt_def)

lemma partition_on_inj_image:
  assumes P: "partition_on A P" and f: "inj_on f A"
  shows "partition_on (f ` A) ((`) f ` P - {{}})"
proof (rule partition_on_transform[OF P])
  show "p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> disjnt p q \<Longrightarrow> disjnt (f ` p) (f ` q)" for p q
    using f[THEN inj_onD] P[THEN partition_onD1] by (auto simp: disjnt_def)
qed auto

subsection \<open>Finiteness of partitions\<close>

lemma finitely_many_partition_on:
  assumes "finite A"
  shows "finite {P. partition_on A P}"
proof (rule finite_subset)
  show "{P. partition_on A P} \<subseteq> Pow (Pow A)"
    unfolding partition_on_def by auto
  show "finite (Pow (Pow A))"
    using assms by simp
qed

lemma finite_elements: "finite A \<Longrightarrow> partition_on A P \<Longrightarrow> finite P"
  using partition_onD1[of A P] by (simp add: finite_UnionD)

subsection \<open>Equivalence of partitions and equivalence classes\<close>

lemma partition_on_quotient:
  assumes r: "equiv A r"
  shows "partition_on A (A // r)"
proof (rule partition_onI)
  from r have "refl_on A r"
    by (auto elim: equivE)
  then show "\<Union>(A // r) = A" "{} \<notin> A // r"
    by (auto simp: refl_on_def quotient_def)

  fix p q assume "p \<in> A // r" "q \<in> A // r" "p \<noteq> q"
  then obtain x y where "x \<in> A" "y \<in> A" "p = r `` {x}" "q = r `` {y}"
    by (auto simp: quotient_def)
  with r equiv_class_eq_iff[OF r, of x y] \<open>p \<noteq> q\<close> show "disjnt p q"
    by (auto simp: disjnt_equiv_class)
qed

lemma equiv_partition_on:
  assumes P: "partition_on A P"
  shows "equiv A {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p}"
proof (rule equivI)
  have "A = \<Union>P" "disjoint P" "{} \<notin> P"
    using P by (auto simp: partition_on_def)
  then show "refl_on A {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
    unfolding refl_on_def by auto
  show "trans {(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p}"
    using \<open>disjoint P\<close> by (auto simp: trans_def disjoint_def)
qed (auto simp: sym_def)

lemma partition_on_eq_quotient:
  assumes P: "partition_on A P"
  shows "A // {(x, y). \<exists>p \<in> P. x \<in> p \<and> y \<in> p} = P"
  unfolding quotient_def
proof safe
  fix x assume "x \<in> A"
  then obtain p where "p \<in> P" "x \<in> p" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
    using P by (auto simp: partition_on_def disjoint_def)
  then have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
    by (safe intro!: bexI[of _ p]) simp
  then show "{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x} \<in> P"
    by (simp add: \<open>p \<in> P\<close>)
next
  fix p assume "p \<in> P"
  then have "p \<noteq> {}"
    using P by (auto simp: partition_on_def)
  then obtain x where "x \<in> p"
    by auto
  then have "x \<in> A" "\<And>q. q \<in> P \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
    using P \<open>p \<in> P\<close> by (auto simp: partition_on_def disjoint_def)
  with \<open>p\<in>P\<close> \<open>x \<in> p\<close> have "{y. \<exists>p\<in>P. x \<in> p \<and> y \<in> p} = p"
    by (safe intro!: bexI[of _ p]) simp
  then show "p \<in> (\<Union>x\<in>A. {{(x, y). \<exists>p\<in>P. x \<in> p \<and> y \<in> p} `` {x}})"
    by (auto intro: \<open>x \<in> A\<close>)
qed

lemma partition_on_alt: "partition_on A P \<longleftrightarrow> (\<exists>r. equiv A r \<and> P = A // r)"
  by (auto simp: partition_on_eq_quotient intro!: partition_on_quotient intro: equiv_partition_on)

end


(*  Title:      HOL/Cardinals/Order_Union.thy
    Author:     Andrei Popescu, TU Muenchen

The ordinal-like sum of two orders with disjoint fields
*)

section \<open>Order Union\<close>

theory Order_Union
imports Main
begin

definition Osum :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"  (infix "Osum" 60) where
  "r Osum r' = r \<union> r' \<union> {(a, a'). a \<in> Field r \<and> a' \<in> Field r'}"

notation Osum  (infix "\<union>o" 60)

lemma Field_Osum: "Field (r \<union>o r') = Field r \<union> Field r'"
  unfolding Osum_def Field_def by blast

lemma Osum_wf:
assumes FLD: "Field r Int Field r' = {}" and
        WF: "wf r" and WF': "wf r'"
shows "wf (r Osum r')"
unfolding wf_eq_minimal2 unfolding Field_Osum
proof(intro allI impI, elim conjE)
  fix A assume *: "A \<subseteq> Field r \<union> Field r'" and **: "A \<noteq> {}"
  obtain B where B_def: "B = A Int Field r" by blast
  show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r \<union>o r'"
  proof(cases "B = {}")
    assume Case1: "B \<noteq> {}"
    hence "B \<noteq> {} \<and> B \<le> Field r" using B_def by auto
    then obtain a where 1: "a \<in> B" and 2: "\<forall>a1 \<in> B. (a1,a) \<notin> r"
    using WF unfolding wf_eq_minimal2 by blast
    hence 3: "a \<in> Field r \<and> a \<notin> Field r'" using B_def FLD by auto
    (*  *)
    have "\<forall>a1 \<in> A. (a1,a) \<notin> r Osum r'"
    proof(intro ballI)
      fix a1 assume **: "a1 \<in> A"
      {assume Case11: "a1 \<in> Field r"
       hence "(a1,a) \<notin> r" using B_def ** 2 by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 by (auto simp add: Field_def)
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      moreover
      {assume Case12: "a1 \<notin> Field r"
       hence "(a1,a) \<notin> r" unfolding Field_def by auto
       moreover
       have "(a1,a) \<notin> r'" using 3 unfolding Field_def by auto
       ultimately have "(a1,a) \<notin> r Osum r'"
       using 3 unfolding Osum_def by auto
      }
      ultimately show "(a1,a) \<notin> r Osum r'" by blast
    qed
    thus ?thesis using 1 B_def by auto
  next
    assume Case2: "B = {}"
    hence 1: "A \<noteq> {} \<and> A \<le> Field r'" using * ** B_def by auto
    then obtain a' where 2: "a' \<in> A" and 3: "\<forall>a1' \<in> A. (a1',a') \<notin> r'"
    using WF' unfolding wf_eq_minimal2 by blast
    hence 4: "a' \<in> Field r' \<and> a' \<notin> Field r" using 1 FLD by blast
    (*  *)
    have "\<forall>a1' \<in> A. (a1',a') \<notin> r Osum r'"
    proof(unfold Osum_def, auto simp add: 3)
      fix a1' assume "(a1', a') \<in> r"
      thus False using 4 unfolding Field_def by blast
    next
      fix a1' assume "a1' \<in> A" and "a1' \<in> Field r"
      thus False using Case2 B_def by auto
    qed
    thus ?thesis using 2 by blast
  qed
qed

lemma Osum_Refl:
assumes FLD: "Field r Int Field r' = {}" and
        REFL: "Refl r" and REFL': "Refl r'"
shows "Refl (r Osum r')"
using assms
unfolding refl_on_def Field_Osum unfolding Osum_def by blast

lemma Osum_trans:
assumes FLD: "Field r Int Field r' = {}" and
        TRANS: "trans r" and TRANS': "trans r'"
shows "trans (r Osum r')"
proof(unfold trans_def, auto)
  fix x y z assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, z) \<in> r \<union>o r'"
  show  "(x, z) \<in> r \<union>o r'"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case11: "(y,z) \<in> r"
        hence "(x,z) \<in> r" using Case1 TRANS trans_def[of r] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case12: "(y,z) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       {assume Case13: "z \<in> Field r'"
        hence ?thesis using 1 unfolding Osum_def by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume Case21: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       {assume Case22: "(y,z) \<in> r'"
        hence "(x,z) \<in> r'" using Case2 TRANS' trans_def[of r'] by blast
        hence ?thesis unfolding Osum_def by auto
       }
       moreover
       {assume Case23: "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume Case31: "(y,z) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,z) \<in> r'"
        hence "z \<in> Field r'" unfolding Field_def by blast
        hence ?thesis unfolding Osum_def using Case3 by auto
       }
       moreover
       {assume Case33: "y \<in> Field r"
        hence False using FLD Case3 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Preorder:
"\<lbrakk>Field r Int Field r' = {}; Preorder r; Preorder r'\<rbrakk> \<Longrightarrow> Preorder (r Osum r')"
unfolding preorder_on_def using Osum_Refl Osum_trans by blast

lemma Osum_antisym:
assumes FLD: "Field r Int Field r' = {}" and
        AN: "antisym r" and AN': "antisym r'"
shows "antisym (r Osum r')"
proof(unfold antisym_def, auto)
  fix x y assume *: "(x, y) \<in> r \<union>o r'" and **: "(y, x) \<in> r \<union>o r'"
  show  "x = y"
  proof-
    {assume Case1: "(x,y) \<in> r"
     hence 1: "x \<in> Field r \<and> y \<in> Field r" unfolding Field_def by auto
     have ?thesis
     proof-
       have "(y,x) \<in> r \<Longrightarrow> ?thesis"
       using Case1 AN antisym_def[of r] by blast
       moreover
       {assume "(y,x) \<in> r'"
        hence "y \<in> Field r'" unfolding Field_def by auto
        hence False using FLD 1 by auto
       }
       moreover
       have "x \<in> Field r' \<Longrightarrow> False" using FLD 1 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case2: "(x,y) \<in> r'"
     hence 2: "x \<in> Field r' \<and> y \<in> Field r'" unfolding Field_def by auto
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD 2 by auto
       }
       moreover
       have "(y,x) \<in> r' \<Longrightarrow> ?thesis"
       using Case2 AN' antisym_def[of r'] by blast
       moreover
       {assume "y \<in> Field r"
        hence False using FLD 2 by auto
       }
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    moreover
    {assume Case3: "x \<in> Field r \<and> y \<in> Field r'"
     have ?thesis
     proof-
       {assume "(y,x) \<in> r"
        hence "y \<in> Field r" unfolding Field_def by auto
        hence False using FLD Case3 by auto
       }
       moreover
       {assume Case32: "(y,x) \<in> r'"
        hence "x \<in> Field r'" unfolding Field_def by blast
        hence False using FLD Case3 by auto
       }
       moreover
       have "\<not> y \<in> Field r" using FLD Case3 by auto
       ultimately show ?thesis using ** unfolding Osum_def by blast
     qed
    }
    ultimately show ?thesis using * unfolding Osum_def by blast
  qed
qed

lemma Osum_Partial_order:
"\<lbrakk>Field r Int Field r' = {}; Partial_order r; Partial_order r'\<rbrakk> \<Longrightarrow>
 Partial_order (r Osum r')"
unfolding partial_order_on_def using Osum_Preorder Osum_antisym by blast

lemma Osum_Total:
assumes FLD: "Field r Int Field r' = {}" and
        TOT: "Total r" and TOT': "Total r'"
shows "Total (r Osum r')"
using assms
unfolding total_on_def  Field_Osum unfolding Osum_def by blast

lemma Osum_Linear_order:
"\<lbrakk>Field r Int Field r' = {}; Linear_order r; Linear_order r'\<rbrakk> \<Longrightarrow>
 Linear_order (r Osum r')"
unfolding linear_order_on_def using Osum_Partial_order Osum_Total by blast

lemma Osum_minus_Id1:
assumes "r \<le> Id"
shows "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r' - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r'"
    with * have "(a,b) \<in> r' - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id2:
assumes "r' \<le> Id"
shows "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
proof-
  let ?Left = "(r Osum r') - Id"
  let ?Right = "(r - Id) \<union> (Field r \<times> Field r')"
  {fix a::'a and b assume *: "(a,b) \<notin> Id"
   {assume "(a,b) \<in> r'"
    with * have False using assms by auto
   }
   moreover
   {assume "(a,b) \<in> r"
    with * have "(a,b) \<in> r - Id" by auto
   }
   ultimately
   have "(a,b) \<in> ?Left \<Longrightarrow> (a,b) \<in> ?Right"
   unfolding Osum_def by auto
  }
  thus ?thesis by auto
qed

lemma Osum_minus_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        NID: "\<not> (r \<le> Id)" and NID': "\<not> (r' \<le> Id)"
shows "(r Osum r') - Id \<le> (r - Id) Osum (r' - Id)"
proof-
  {fix a a' assume *: "(a,a') \<in> (r Osum r')" and **: "a \<noteq> a'"
   have "(a,a') \<in> (r - Id) Osum (r' - Id)"
   proof-
     {assume "(a,a') \<in> r \<or> (a,a') \<in> r'"
      with ** have ?thesis unfolding Osum_def by auto
     }
     moreover
     {assume "a \<in> Field r \<and> a' \<in> Field r'"
      hence "a \<in> Field(r - Id) \<and> a' \<in> Field (r' - Id)"
      using assms Total_Id_Field by blast
      hence ?thesis unfolding Osum_def by auto
     }
     ultimately show ?thesis using * unfolding Osum_def by fast
   qed
  }
  thus ?thesis by(auto simp add: Osum_def)
qed

lemma wf_Int_Times:
assumes "A Int B = {}"
shows "wf(A \<times> B)"
unfolding wf_def using assms by blast

lemma Osum_wf_Id:
assumes TOT: "Total r" and TOT': "Total r'" and
        FLD: "Field r Int Field r' = {}" and
        WF: "wf(r - Id)" and WF': "wf(r' - Id)"
shows "wf ((r Osum r') - Id)"
proof(cases "r \<le> Id \<or> r' \<le> Id")
  assume Case1: "\<not>(r \<le> Id \<or> r' \<le> Id)"
  have "Field(r - Id) Int Field(r' - Id) = {}"
  using FLD mono_Field[of "r - Id" r]  mono_Field[of "r' - Id" r']
            Diff_subset[of r Id] Diff_subset[of r' Id] by blast
  thus ?thesis
  using Case1 Osum_minus_Id[of r r'] assms Osum_wf[of "r - Id" "r' - Id"]
        wf_subset[of "(r - Id) \<union>o (r' - Id)" "(r Osum r') - Id"] by auto
next
  have 1: "wf(Field r \<times> Field r')"
  using FLD by (auto simp add: wf_Int_Times)
  assume Case2: "r \<le> Id \<or> r' \<le> Id"
  moreover
  {assume Case21: "r \<le> Id"
   hence "(r Osum r') - Id \<le> (r' - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id1[of r r'] by simp
   moreover
   {have "Domain(Field r \<times> Field r') Int Range(r' - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r' - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF' wf_Un[of "Field r \<times> Field r'" "r' - Id"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  moreover
  {assume Case22: "r' \<le> Id"
   hence "(r Osum r') - Id \<le> (r - Id) \<union> (Field r \<times> Field r')"
   using Osum_minus_Id2[of r' r] by simp
   moreover
   {have "Range(Field r \<times> Field r') Int Domain(r - Id) = {}"
    using FLD unfolding Field_def by blast
    hence "wf((r - Id) \<union> (Field r \<times> Field r'))"
    using 1 WF wf_Un[of "r - Id" "Field r \<times> Field r'"]
    by (auto simp add: Un_commute)
   }
   ultimately have ?thesis using wf_subset by blast
  }
  ultimately show ?thesis by blast
qed

lemma Osum_Well_order:
assumes FLD: "Field r Int Field r' = {}" and
        WELL: "Well_order r" and WELL': "Well_order r'"
shows "Well_order (r Osum r')"
proof-
  have "Total r \<and> Total r'" using WELL WELL'
  by (auto simp add: order_on_defs)
  thus ?thesis using assms unfolding well_order_on_def
  using Osum_Linear_order Osum_wf_Id by blast
qed

end


theory Basics
  imports Main
begin

section {* Basics *}

datatype day = monday | tuesday | wednesday |
  thursday | friday | saturday | sunday

fun next_weekday :: "day \<Rightarrow> day" where
  "next_weekday monday = tuesday"
| "next_weekday tuesday = wednesday"
| "next_weekday wednesday = thursday"
| "next_weekday thursday = friday"
| "next_weekday friday = monday"
| "next_weekday saturday = monday"
| "next_weekday sunday = monday"

value "next_weekday friday" (* "monday" :: "day" *)
value "next_weekday (next_weekday saturday)" (* "tuesday" :: "day" *)

lemma test_next_weekday: "next_weekday (next_weekday saturday) = tuesday" by simp

datatype bool = True | False

fun negb :: "bool \<Rightarrow> bool" where
  "negb True = False"
| "negb False = True"

fun andb :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "&&" 65)
  where
  "andb True b2 = b2"
| "andb False _ = False"

fun orb :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "||" 65)
  where
  "orb True _ = True"
| "orb False b2 = b2"

lemma test_orb1: "orb True False = True" by simp
lemma test_orb2: "orb False False = False" by simp
lemma test_orb3: "orb False True = True" by simp
lemma test_orb4: "orb True True = True" by simp

lemma test_orb5: "False || False || True = True"
  apply (simp)
  done

fun nandb :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "nandb False _ = True"
| "nandb True b2 = negb b2"

lemma test_nandb1: "nandb True False = True" by simp
lemma test_nandb2: "nandb False False = True" by simp
lemma test_nandb3: "nandb False True = True" by simp
lemma test_nandb4: "nandb True True = False" by simp

fun andb3 :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool" where
  "andb3 False _ _ = False"
| "andb3 True False _ = False"
| "andb3 True True b3 = b3"

lemma test_andb31: "andb3 True True True = True" by simp
lemma test_andb32: "andb3 False True True = False" by simp
lemma test_andb33: "andb3 True False True = False" by simp
lemma test_andb34: "andb3 True True False = False" by simp

fun pred :: "nat \<Rightarrow> nat" where
  "pred 0 = 0"
| "pred (Suc n') = n'"

value "Suc (Suc (Suc (Suc 0)))" (* "4" :: "nat" *)

fun minustwo :: "nat \<Rightarrow> nat" where
  "minustwo 0 = 0"
| "minustwo (Suc 0) = 0"
| "minustwo (Suc (Suc n')) = n'"

value "minustwo 4" (* "2" :: "nat" *)

fun evenb :: "nat \<Rightarrow> bool" where
  "evenb 0 = True"
| "evenb (Suc 0) = False"
| "evenb (Suc (Suc n')) = evenb n'"

fun oddb :: "nat \<Rightarrow> bool" where
  "oddb n = negb (evenb n)"

lemma test_oddb1: "oddb 1 = True" by simp
lemma test_oddb2: "oddb (Suc (Suc (Suc 1))) = False" by simp

fun plus :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "plus 0 m = m"
| "plus (Suc n') m = Suc (plus n' m)"

value "plus 3 2" (* "5" :: "nat" *)

fun mult :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "mult 0 _ = 0"
| "mult (Suc n') m = plus m (mult n' m)"

lemma test_plus1: "plus 1 1 = 2" by simp
lemma test_plus2: "plus (Suc (Suc 1)) 3 = 6" by simp
lemma test_mult1: "mult (Suc (Suc 1)) (Suc (Suc 1)) = 9" by simp

fun minus :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "minus 0 _ = 0"
| "minus n 0 = n"
| "minus (Suc n') (Suc m') = minus n' m'"

(*
fun exp :: "nat \<Rightarrow> nat" where
  "exp power 0 = Suc 0"
| "exp base (Suc p) = mult base (exp base p)"
*)

fun factorial :: "nat \<Rightarrow> nat" where
  "factorial 0 = 1"
| "factorial (Suc n') = mult (Suc n') (factorial n')"

(* lemma test_factorial1: "factorial 3 = 6" *)
lemma test_factorial1: "factorial (Suc (Suc 1)) = 6" by simp

(* n = m *)
fun beq_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "beq_nat 0 0 = True"
| "beq_nat 0 (Suc m') = False"
| "beq_nat (Suc n') 0 = False"
| "beq_nat (Suc n') (Suc m') = beq_nat n' m'"

(* n \<le> m *)
fun leb :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "leb 0 _ = True"
| "leb (Suc n') 0 = False"
| "leb (Suc n') (Suc m') = leb n' m'"

(* lemma test_leb1: "leb 2 2 = True" *)
lemma test_leb1: "leb (Suc 1) (Suc 1) = True" by simp

(* n < m \<longrightarrow> !(n \<ge> m) *)
definition blt_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "blt_nat n m = negb (leb m n)"

lemma test_blt_nat1: "blt_nat (Suc 1) (Suc 1) = False"
  unfolding blt_nat_def
  apply (simp)
  done

lemma test_blt_nat2: "blt_nat (Suc 1) (Suc (Suc (Suc 1))) = True"
  unfolding blt_nat_def
  apply (simp)
  done

lemma test_blt_nat3: "blt_nat (Suc (Suc (Suc 1))) (Suc 1) = False"
  unfolding blt_nat_def
  apply (simp)
  done

theorem plus_0_n: "\<forall> n::nat. 0 + n = n" by simp
theorem plus_1_l: "\<forall> n::nat. 1 + n = Suc n" by simp
theorem mult_0_l: "\<forall> n::nat. 0 * n = 0" by simp

theorem plus_id_example: "\<forall> n m::nat. n = m \<longrightarrow> n + n = m + m" by simp
theorem plus_id_exercise: "\<forall> n m p::nat. n = m \<longrightarrow> m = p \<longrightarrow> n + m = m + p"
  apply (simp)
  done

theorem mult_0_plus: "\<forall> n m::nat. (0 + n) * m = n * m" by simp
theorem mult_S_1: "\<forall> n m::nat. m = Suc n \<longrightarrow> m * (1 + n) = m * m"
  apply (simp)
  done

theorem plus_1_neq_0: "\<forall> n::nat. beq_nat (n + 1) 0 = False"
  apply (simp)
  done

(* theorem negb_involutive: "\<forall> b::bool. negb (negb b) = b" *)
theorem negb_involutive: "negb (negb b) = b"
  apply (induction b)
   apply (simp_all)
  done

theorem andb_commutative: "andb b c = andb c b"
  apply (induction b)
   apply (induction c)
    apply (simp_all)
  apply (induction c)
   apply (simp_all)
  done

theorem plus_1_neq_0': "\<forall> n::nat. beq_nat (n + 1) 0 = False"
  apply (simp)
  done

theorem andb_true_elim2: "\<forall> b c::bool. andb b c = True \<longrightarrow> c = True"
  using andb.elims
  apply (auto)
  done

theorem zero_nbeq_plus_1: "\<forall> n::nat. beq_nat 0 (n + 1) = False"
  apply (simp)
  done

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.*)
  theory TIP_prop_76
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun count :: "Nat => Nat list => Nat" where
  "count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

theorem property0 :
  "((~ (x n m)) ==>
      ((count n (y xs (cons2 m (nil2)))) = (count n xs)))"
  oops

end