chapter \<open>Addition, Sequences and their Concatenation\<close>

theory OrdArith imports Rank
begin

section \<open>Generalised Addition --- Also for Ordinals\<close>
text \<open>Source: Laurence Kirby, Addition and multiplication of sets
      Math. Log. Quart. 53, No. 1, 52-65 (2007) / DOI 10.1002/malq.200610026
      @{url "http://faculty.baruch.cuny.edu/lkirby/mlqarticlejan2007.pdf"}\<close>

definition
  hadd      :: "hf \<Rightarrow> hf \<Rightarrow> hf"           (infixl "@+" 65)  where
    "hadd x \<equiv> hmemrec (\<lambda>f z. x \<squnion> RepFun z f)"

lemma hadd: "x @+ y = x \<squnion> RepFun y (\<lambda>z. x @+ z)"
  by (metis def_hmemrec RepFun_ecut hadd_def order_refl)

lemma hmem_hadd_E:
  assumes l: "l \<^bold>\<in> x @+ y"
  obtains "l \<^bold>\<in> x" | z where "z \<^bold>\<in> y" "l = x @+ z"
  using l by (auto simp: hadd [of x y])

lemma hadd_0_right [simp]: "x @+ 0 = x"
  by (subst hadd) simp

lemma hadd_hinsert_right: "x @+ hinsert y z = hinsert (x @+ y) (x @+ z)"
  by (metis hadd hunion_hinsert_right RepFun_hinsert)

lemma hadd_succ_right [simp]: "x @+ succ y = succ (x @+ y)"
  by (metis hadd_hinsert_right succ_def)

lemma not_add_less_right: "\<not> (x @+ y < x)"
proof (induction y)
  case (2 y1 y2)
  then show ?case
    using hadd less_supI1 order_less_le by blast
qed auto

lemma not_add_mem_right: "\<not> (x @+ y \<^bold>\<in> x)"
  by (metis hadd hmem_not_refl hunion_iff)

lemma hadd_0_left [simp]: "0 @+ x = x"
  by (induct x) (auto simp: hadd_hinsert_right)

lemma hadd_succ_left [simp]: "Ord y \<Longrightarrow> succ x @+ y = succ (x @+ y)"
  by (induct y rule: Ord_induct2) auto

lemma hadd_assoc: "(x @+ y) @+ z = x @+ (y @+ z)"
  by (induct z) (auto simp: hadd_hinsert_right)

lemma RepFun_hadd_disjoint: "x \<sqinter> RepFun y ((@+) x) = 0"
  by (metis hf_equalityI RepFun_iff hinter_iff not_add_mem_right hmem_hempty)

subsection \<open>Cancellation laws for addition\<close>

lemma Rep_le_Cancel: "x \<squnion> RepFun y ((@+) x) \<le> x \<squnion> RepFun z ((@+) x)
                      \<Longrightarrow> RepFun y ((@+) x) \<le> RepFun z ((@+) x)"
  by (auto simp add: not_add_mem_right)

lemma hadd_cancel_right [simp]: "x @+ y = x @+ z \<longleftrightarrow> y=z"
proof (induct y arbitrary: z rule: hmem_induct)
  case (step y z) show ?case
  proof auto
    assume eq: "x @+ y = x @+ z"
    hence  "RepFun y ((@+) x) = RepFun z ((@+) x)"
      by (metis hadd Rep_le_Cancel order_antisym order_refl)
    thus  "y = z"
      by (metis hf_equalityI RepFun_iff step)
  qed
qed

lemma RepFun_hadd_cancel: "RepFun y (\<lambda>z. x @+ z) = RepFun z (\<lambda>z. x @+ z) \<longleftrightarrow> y=z"
  by (metis hadd hadd_cancel_right)

lemma hadd_hmem_cancel [simp]: "x @+ y \<^bold>\<in> x @+ z \<longleftrightarrow> y \<^bold>\<in> z"
  by (metis RepFun_iff hadd hadd_cancel_right hunion_iff not_add_mem_right)

lemma ord_of_add: "ord_of (i+j) = ord_of i @+ ord_of j"
  by (induct j) auto

lemma Ord_hadd: "Ord x \<Longrightarrow> Ord y \<Longrightarrow> Ord (x @+ y)"
  by (induct x rule: Ord_induct2) auto

lemma hmem_self_hadd [simp]: "k1 \<^bold>\<in> k1 @+ k2 \<longleftrightarrow> 0 \<^bold>\<in> k2"
  by (metis hadd_0_right hadd_hmem_cancel)

lemma hadd_commute: "Ord x \<Longrightarrow> Ord y \<Longrightarrow> x @+ y = y @+ x"
  by (induct x rule: Ord_induct2) auto

lemma hadd_cancel_left [simp]: "Ord x \<Longrightarrow> y @+ x = z @+ x \<longleftrightarrow> y=z"
  by (induct x rule: Ord_induct2) auto

subsection \<open>The predecessor function\<close>

definition pred :: "hf \<Rightarrow> hf"
  where "pred x \<equiv> (THE y. succ y = x \<or> x=0 \<and> y=0)"

lemma pred_succ [simp]: "pred (succ x) = x"
  by (simp add: pred_def)

lemma pred_0 [simp]: "pred 0 = 0"
  by (simp add: pred_def)

lemma succ_pred [simp]: "Ord x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> succ (pred x) = x"
  by (metis Ord_cases pred_succ)

lemma pred_mem [simp]: "Ord x \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> pred x \<^bold>\<in> x"
  by (metis succ_iff succ_pred)

lemma Ord_pred [simp]: "Ord x \<Longrightarrow> Ord (pred x)"
  by (metis Ord_in_Ord pred_0 pred_mem)

lemma hadd_pred_right: "Ord y \<Longrightarrow> y \<noteq> 0 \<Longrightarrow> x @+ pred y = pred (x @+ y)"
  by (metis hadd_succ_right pred_succ succ_pred)

lemma Ord_pred_HUnion: "Ord(k) \<Longrightarrow> pred k = \<Squnion>k"
  by (metis HUnion_hempty Ordinal.Ord_pred pred_0 pred_succ)

section \<open>A Concatentation Operation for Sequences\<close>

definition shift :: "hf \<Rightarrow> hf \<Rightarrow> hf"
  where "shift f delta = \<lbrace>v . u \<^bold>\<in> f, \<exists>n y. u = \<langle>n, y\<rangle> \<and> v = \<langle>delta @+ n, y\<rangle>\<rbrace>"

lemma shiftD: "x \<^bold>\<in> shift f delta \<Longrightarrow> \<exists>u. u \<^bold>\<in> f \<and> x = \<langle>delta @+ hfst u, hsnd u\<rangle>"
  by (auto simp: shift_def hsplit_def)

lemma hmem_shift_iff: "\<langle>m, y\<rangle> \<^bold>\<in> shift f delta \<longleftrightarrow> (\<exists>n. m = delta @+ n \<and> \<langle>n, y\<rangle> \<^bold>\<in> f)"
  by (auto simp: shift_def hrelation_def is_hpair_def)

lemma hmem_shift_add_iff [simp]: "\<langle>delta @+ n, y\<rangle> \<^bold>\<in> shift f delta \<longleftrightarrow> \<langle>n, y\<rangle> \<^bold>\<in> f"
  by (metis hadd_cancel_right hmem_shift_iff)

lemma hrelation_shift [simp]: "hrelation (shift f delta)"
  by (auto simp: shift_def hrelation_def hsplit_def)

lemma app_shift [simp]: "app (shift f k) (k @+ j) = app f j"
  by (simp add: app_def)

lemma hfunction_shift_iff [simp]: "hfunction (shift f delta) = hfunction f"
  by (auto simp: hfunction_def hmem_shift_iff)

lemma hdomain_shift_add: "hdomain (shift f delta) = \<lbrace>delta @+ n . n \<^bold>\<in> hdomain f\<rbrace>"
  by  (rule hf_equalityI) (force simp add: hdomain_def hmem_shift_iff)

definition seq_append :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf"
  where "seq_append k f g \<equiv> hrestrict f k \<squnion> shift g k"

lemma hrelation_seq_append [simp]: "hrelation (seq_append k f g)"
  by (simp add: seq_append_def)

lemma Seq_append:
  assumes "Seq s1 k1" "Seq s2 k2"
  shows "Seq (seq_append k1 s1 s2) (k1 @+ k2)"
proof -
  have "hfunction (hrestrict s1 k1 \<squnion> shift s2 k1)"
    using assms
    by (simp add: Ordinal.Seq_def hdomain_shift_disjoint hfunction_hunion hfunction_restr inf.absorb2)
  moreover
  have "\<And>x. \<lbrakk>x \<^bold>\<in> k1 @+ k2; x \<^bold>\<notin> hdomain (shift s2 k1)\<rbrakk> \<Longrightarrow> x \<^bold>\<in> hdomain s1 \<and> x \<^bold>\<in> k1"
    by (metis Ordinal.Seq_def RepFun_iff assms hdomain_shift_add hmem_hadd_E hsubsetCE)
  ultimately show ?thesis
    by (auto simp: Seq_def seq_append_def)
qed

lemma app_hunion1: "x \<^bold>\<notin> hdomain g \<Longrightarrow> app (f \<squnion> g) x = app f x"
  by (auto simp: app_def) (metis hdomainI)

lemma app_hunion2: "x \<^bold>\<notin> hdomain f \<Longrightarrow> app (f \<squnion> g) x = app g x"
  by (auto simp: app_def) (metis hdomainI)

lemma Seq_append_app1: "Seq s k \<Longrightarrow> l \<^bold>\<in> k \<Longrightarrow> app (seq_append k s s') l = app s l"
  by (metis app_hrestrict app_hunion1 hdomain_shift_disjoint hemptyE hinter_iff seq_append_def)

lemma Seq_append_app2: "Seq s1 k1 \<Longrightarrow> Seq s2 k2 \<Longrightarrow> l = k1 @+ j \<Longrightarrow> app (seq_append k1 s1 s2) l = app s2 j"
  by (metis seq_append_def app_hunion2 app_shift hdomain_restr hinter_iff not_add_mem_right)

section \<open>Nonempty sequences indexed by ordinals\<close>

definition OrdDom where
 "OrdDom r \<equiv> \<forall>x y. \<langle>x,y\<rangle> \<^bold>\<in> r \<longrightarrow> Ord x"

lemma OrdDom_insf: "\<lbrakk>OrdDom s; Ord k\<rbrakk> \<Longrightarrow> OrdDom (insf s (succ k) y)"
  by (auto simp: insf_def OrdDom_def)

lemma OrdDom_hunion [simp]: "OrdDom (s1 \<squnion> s2) \<longleftrightarrow> OrdDom s1 \<and> OrdDom s2"
  by (auto simp: OrdDom_def)

lemma OrdDom_hrestrict: "OrdDom s \<Longrightarrow> OrdDom (hrestrict s A)"
  by (auto simp: OrdDom_def)

lemma OrdDom_shift: "\<lbrakk>OrdDom s; Ord k\<rbrakk> \<Longrightarrow> OrdDom (shift s k)"
  by (auto simp: OrdDom_def shift_def Ord_hadd)

text \<open>A sequence of positive length ending with @{term y}\<close>
definition LstSeq :: "hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "LstSeq s k y \<equiv> Seq s (succ k) \<and> Ord k \<and> \<langle>k,y\<rangle> \<^bold>\<in> s \<and> OrdDom s"

lemma LstSeq_imp_Seq_same: "LstSeq s k y \<Longrightarrow> Seq s k"
  by (metis LstSeq_imp_Seq_succ Seq_succ_D)

lemma LstSeq_imp_Ord: "LstSeq s k y \<Longrightarrow> Ord k"
  by (metis LstSeq_def)

lemma LstSeq_trunc: "LstSeq s k y \<Longrightarrow> l \<^bold>\<in> k \<Longrightarrow> LstSeq s l (app s l)"
  by (meson LstSeq_def Ord_in_Ord Seq_Ord_D Seq_iff_app Seq_succ_iff)

lemma LstSeq_insf: "LstSeq s k z \<Longrightarrow> LstSeq (insf s (succ k) y) (succ k) y"
  using LstSeq_def OrdDom_insf Seq_insf insf_def by force

lemma app_insf_LstSeq: "LstSeq s k z \<Longrightarrow> app (insf s (succ k) y) (succ k) = y"
  by (metis LstSeq_imp_Seq_succ app_insf_Seq)

lemma app_insf2_LstSeq: "LstSeq s k z \<Longrightarrow> k' \<noteq> succ k \<Longrightarrow> app (insf s (succ k) y) k' = app s k'"
  by (metis LstSeq_imp_Seq_succ app_insf2_Seq)

lemma app_insf_LstSeq_if: "LstSeq s k z \<Longrightarrow> app (insf s (succ k) y) k' = (if k' = succ k then y else app s k')"
  by (metis app_insf2_LstSeq app_insf_LstSeq)

lemma LstSeq_append_app1:
  "LstSeq s k y \<Longrightarrow> l \<^bold>\<in> succ k \<Longrightarrow> app (seq_append (succ k) s s') l = app s l"
  by (metis LstSeq_imp_Seq_succ Seq_append_app1)

lemma LstSeq_append_app2:
  "\<lbrakk>LstSeq s1 k1 y1; LstSeq s2 k2 y2; l = succ k1 @+ j\<rbrakk>
   \<Longrightarrow> app (seq_append (succ k1) s1 s2) l = app s2 j"
   by (metis LstSeq_imp_Seq_succ Seq_append_app2)

lemma Seq_append_pair:
  "\<lbrakk>Seq s1 k1; Seq s2 (succ n);  \<langle>n, y\<rangle> \<^bold>\<in> s2; Ord n\<rbrakk> \<Longrightarrow> \<langle>k1 @+ n, y\<rangle> \<^bold>\<in> (seq_append k1 s1 s2)"
  by (metis hmem_shift_add_iff hunion_iff seq_append_def)

lemma Seq_append_OrdDom: "\<lbrakk>Ord k; OrdDom s1; OrdDom s2\<rbrakk> \<Longrightarrow> OrdDom (seq_append k s1 s2)"
  by (auto simp: seq_append_def OrdDom_hrestrict OrdDom_shift)

lemma LstSeq_append:
  "\<lbrakk>LstSeq s1 k1 y1; LstSeq s2 k2 y2\<rbrakk> \<Longrightarrow> LstSeq (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
  using LstSeq_def Ord_hadd Seq_append Seq_append_OrdDom Seq_append_pair by fastforce

lemma LstSeq_app [simp]: "LstSeq s k y \<Longrightarrow> app s k = y"
  by (metis LstSeq_def Seq_imp_eq_app)

subsection \<open>Sequence-building operators\<close>

definition Builds :: "(hf \<Rightarrow> bool) \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "Builds B C s l \<equiv> B (app s l) \<or> (\<exists>m \<^bold>\<in> l. \<exists>n \<^bold>\<in> l. C (app s l) (app s m) (app s n))"

definition BuildSeq :: "(hf \<Rightarrow> bool) \<Rightarrow> (hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool) \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> hf \<Rightarrow> bool"
  where "BuildSeq B C s k y \<equiv> LstSeq s k y \<and> (\<forall>l \<^bold>\<in> succ k. Builds B C s l)"

lemma BuildSeqI: "LstSeq s k y \<Longrightarrow> (\<And>l. l \<^bold>\<in> succ k \<Longrightarrow> Builds B C s l) \<Longrightarrow> BuildSeq B C s k y"
  by (simp add: BuildSeq_def)

lemma BuildSeq_imp_LstSeq: "BuildSeq B C s k y \<Longrightarrow> LstSeq s k y"
  by (metis BuildSeq_def)

lemma BuildSeq_imp_Seq: "BuildSeq B C s k y \<Longrightarrow> Seq s (succ k)"
  by (metis LstSeq_imp_Seq_succ BuildSeq_imp_LstSeq)

lemma BuildSeq_conj_distrib:
 "BuildSeq (\<lambda>x. B x \<and> P x) (\<lambda>x y z. C x y z \<and> P x) s k y \<longleftrightarrow>
  BuildSeq B C s k y \<and> (\<forall>l \<^bold>\<in> succ k. P (app s l))"
  by (auto simp: BuildSeq_def Builds_def)

lemma BuildSeq_mono:
  assumes y: "BuildSeq B C s k y"
      and B: "\<And>x. B x \<Longrightarrow> B' x" and C: "\<And>x y z. C x y z \<Longrightarrow> C' x y z"
  shows "BuildSeq B' C' s k y"
using y
  by (auto simp: BuildSeq_def Builds_def intro!: B C)

lemma BuildSeq_trunc:
  assumes b: "BuildSeq B C s k y"
      and l: "l \<^bold>\<in> k"
  shows "BuildSeq B C s l (app s l)"
  by (smt (verit) BuildSeqI BuildSeq_def LstSeq_def LstSeq_trunc Ord_trans b hballE l succ_iff)

subsection \<open>Showing that Sequences can be Constructed\<close>

lemma Builds_insf: "Builds B C s l \<Longrightarrow> LstSeq s k z \<Longrightarrow> l \<^bold>\<in> succ k \<Longrightarrow> Builds B C (insf s (succ k) y) l"
by (auto simp: HBall_def hmem_not_refl Builds_def app_insf_LstSeq_if simp del: succ_iff)
   (metis hmem_not_sym)

lemma BuildSeq_insf:
  assumes b: "BuildSeq B C s k z"
      and m: "m \<^bold>\<in> succ k"
      and n: "n \<^bold>\<in> succ k"
      and y: "B y \<or> C y (app s m) (app s n)"
shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
proof (rule BuildSeqI)
  show "LstSeq (insf s (succ k) y) (succ k) y"
  by (metis BuildSeq_imp_LstSeq LstSeq_insf b)
next
  fix l
  assume l: "l \<^bold>\<in> succ (succ k)"
  thus "Builds B C (insf s (succ k) y) l"
  proof
    assume l: "l = succ k"
    have "B (app (insf s l y) l) \<or> C (app (insf s l y) l) (app (insf s l y) m) (app (insf s l y) n)"
      by (metis BuildSeq_imp_Seq app_insf_Seq_if b hmem_not_refl l m n y)
    thus "Builds B C (insf s (succ k) y) l" using m n
      by (auto simp: Builds_def l)
  next
    assume l: "l \<^bold>\<in> succ k"
    thus "Builds B C (insf s (succ k) y) l" using b l
      by (metis hballE Builds_insf BuildSeq_def)
  qed
qed

lemma BuildSeq_insf1:
  assumes b: "BuildSeq B C s k z"
      and y: "B y"
  shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
by (metis BuildSeq_insf b succ_iff y)

lemma BuildSeq_insf2:
  assumes b: "BuildSeq B C s k z"
      and m: "m \<^bold>\<in> k"
      and n: "n \<^bold>\<in> k"
      and y: "C y (app s m) (app s n)"
  shows "BuildSeq B C (insf s (succ k) y) (succ k) y"
  by (metis BuildSeq_insf b m n succ_iff y)

lemma BuildSeq_append:
  assumes s1: "BuildSeq B C s1 k1 y1" and s2: "BuildSeq B C s2 k2 y2"
  shows "BuildSeq B C (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
proof (rule BuildSeqI)
  show "LstSeq (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
    using assms
    by (metis BuildSeq_imp_LstSeq LstSeq_append)
next
  fix l
  have s1L: "LstSeq s1 k1 y1"
   and s1BC: "\<And>l. l \<^bold>\<in> succ k1 \<Longrightarrow> Builds B C s1 l"
   and s2L: "LstSeq s2 k2 y2"
   and s2BC: "\<And>l. l \<^bold>\<in> succ k2 \<Longrightarrow> Builds B C s2 l"
    using s1 s2 by (auto simp: BuildSeq_def)
  assume l: "l \<^bold>\<in> succ (succ (k1 @+ k2))"
  hence  "l \<^bold>\<in> succ k1 @+ succ k2"
    by (metis LstSeq_imp_Ord hadd_succ_left hadd_succ_right s2L)
  thus "Builds B C (seq_append (succ k1) s1 s2) l"
  proof (rule hmem_hadd_E)
    assume l1: "l \<^bold>\<in> succ k1"
    hence "B (app s1 l) \<or> (\<exists>m\<^bold>\<in>l. \<exists>n\<^bold>\<in>l. C (app s1 l) (app s1 m) (app s1 n))" using s1BC
      by (simp add: Builds_def)
    thus ?thesis
    proof
      assume "B (app s1 l)"
      thus ?thesis
        by (metis Builds_def LstSeq_append_app1 l1 s1L)
    next
      assume "\<exists>m\<^bold>\<in>l. \<exists>n\<^bold>\<in>l. C (app s1 l) (app s1 m) (app s1 n)"
      then obtain m n where mn: "m \<^bold>\<in> l" "n \<^bold>\<in> l" and C: "C (app s1 l) (app s1 m) (app s1 n)"
        by blast
      moreover have "m \<^bold>\<in> succ k1" "n \<^bold>\<in> succ k1"
        by (metis LstSeq_def Ord_trans l1 mn s1L succ_iff)+
      ultimately have "C (app (seq_append (succ k1) s1 s2) l)
                         (app (seq_append (succ k1) s1 s2) m)
                         (app (seq_append (succ k1) s1 s2) n)"
        using s1L l1
        by (simp add: LstSeq_append_app1)
      thus "Builds B C (seq_append (succ k1) s1 s2) l" using mn
        by (auto simp: Builds_def)
    qed
  next
    fix z
    assume z: "z \<^bold>\<in> succ k2" and l2: "l = succ k1 @+ z"
    hence "B (app s2 z) \<or> (\<exists>m\<^bold>\<in>z. \<exists>n\<^bold>\<in>z. C (app s2 z) (app s2 m) (app s2 n))" using s2BC
      by (simp add: Builds_def)
    thus ?thesis
    proof
      assume "B (app s2 z)"
      thus ?thesis
        by (metis Builds_def LstSeq_append_app2 l2 s1L s2L)
    next
      assume "\<exists>m\<^bold>\<in>z. \<exists>n\<^bold>\<in>z. C (app s2 z) (app s2 m) (app s2 n)"
      then obtain m n where mn: "m \<^bold>\<in> z" "n \<^bold>\<in> z" and C: "C (app s2 z) (app s2 m) (app s2 n)"
        by blast
      also have "m \<^bold>\<in> succ k2" "n \<^bold>\<in> succ k2" using mn
        by (metis LstSeq_def Ord_trans z s2L succ_iff)+
      ultimately have "C (app (seq_append (succ k1) s1 s2) l)
                         (app (seq_append (succ k1) s1 s2) (succ k1 @+ m))
                         (app (seq_append (succ k1) s1 s2) (succ k1 @+ n))"
        using s1L s2L l2 z
        by (simp add: LstSeq_append_app2)
      thus "Builds B C (seq_append (succ k1) s1 s2) l" using mn l2
        by (auto simp: Builds_def HBall_def)
    qed
  qed
qed

lemma BuildSeq_combine:
  assumes b1: "BuildSeq B C s1 k1 y1" and b2: "BuildSeq B C s2 k2 y2"
      and y: "C y y1 y2"
  shows "BuildSeq B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) y) (succ (succ (k1 @+ k2))) y"
proof -
  have k2: "Ord k2"  using b2
    by (auto simp: BuildSeq_def LstSeq_def)
  show ?thesis
  proof (rule BuildSeq_insf [where m=k1 and n="succ(k1@+k2)"])
    show "BuildSeq B C (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) y2"
      by (rule BuildSeq_append [OF b1 b2])
  next
    show "k1 \<^bold>\<in> succ (succ (k1 @+ k2))" using k2
      by (metis hadd_0_right hmem_0_Ord hmem_self_hadd succ_iff)
  next
    show "succ (k1 @+ k2) \<^bold>\<in> succ (succ (k1 @+ k2))"
      by (metis succ_iff)
  next
    have [simp]: "app (seq_append (succ k1) s1 s2) k1 = y1"
      by (metis b1 BuildSeq_imp_LstSeq LstSeq_app LstSeq_append_app1 succ_iff)
    have [simp]: "app (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)) = y2"
      by (metis b1 b2 k2 BuildSeq_imp_LstSeq LstSeq_app LstSeq_append_app2 hadd_succ_left)
    show "B y \<or>
          C y (app (seq_append (succ k1) s1 s2) k1)
              (app (seq_append (succ k1) s1 s2) (succ (k1 @+ k2)))"
      using y by simp
  qed
qed

lemma LstSeq_1: "LstSeq \<lbrace>\<langle>0, y\<rangle>\<rbrace> 0 y"
 by (auto simp: LstSeq_def One_hf_eq_succ Seq_ins OrdDom_def)

lemma BuildSeq_1: "B y \<Longrightarrow> BuildSeq B C \<lbrace>\<langle>0, y\<rangle>\<rbrace> 0 y"
  by (auto simp: BuildSeq_def Builds_def LstSeq_1)

lemma BuildSeq_exI: "B t \<Longrightarrow> \<exists>s k. BuildSeq B C s k t"
  by (metis BuildSeq_1)

subsection \<open>Proving Properties of Given Sequences\<close>

lemma BuildSeq_induct [consumes 1, case_names B C]:
  assumes major: "BuildSeq B C s k a"
      and B: "\<And>x. B x \<Longrightarrow> P x"
      and C: "\<And>x y z. C x y z \<Longrightarrow> P y \<Longrightarrow> P z \<Longrightarrow> P x"
  shows "P a"
proof -
  have "Ord k" using assms
    by (auto simp: BuildSeq_def LstSeq_def)
  hence "\<And>a s. BuildSeq B C s k a \<Longrightarrow> P a"
    by (induction k rule: Ord_induct) (metis BuildSeq_trunc BuildSeq_succ_E B C)
  thus ?thesis
    by (metis major)
qed

definition BuildSeq2 :: "[[hf,hf] \<Rightarrow> bool, [hf,hf,hf,hf,hf,hf] \<Rightarrow> bool, hf, hf, hf, hf] \<Rightarrow> bool"
  where "BuildSeq2 B C s k y y' \<equiv>
         BuildSeq (\<lambda>p. \<exists>x x'. p = \<langle>x,x'\<rangle> \<and> B x x')
                  (\<lambda>p q r. \<exists>x x' y y' z z'. p = \<langle>x,x'\<rangle> \<and> q = \<langle>y,y'\<rangle> \<and> r = \<langle>z,z'\<rangle> \<and> C x x' y y' z z')
                  s k \<langle>y,y'\<rangle>"

lemma BuildSeq2_combine:
  assumes b1: "BuildSeq2 B C s1 k1 y1 y1'" and b2: "BuildSeq2 B C s2 k2 y2 y2'"
      and y: "C y y' y1 y1' y2 y2'"
  shows "BuildSeq2 B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) \<langle>y, y'\<rangle>)
                       (succ (succ (k1 @+ k2))) y y'"
  using BuildSeq2_def BuildSeq_combine b1 b2 y by force

lemma BuildSeq2_1: "B y y' \<Longrightarrow> BuildSeq2 B C \<lbrace>\<langle>0, y, y'\<rangle>\<rbrace> 0 y y'"
  by (auto simp: BuildSeq2_def BuildSeq_1)

lemma BuildSeq2_induct [consumes 1, case_names B C]:
  assumes "BuildSeq2 B C s k a a'"
    and B: "\<And>x x'. B x x' \<Longrightarrow> P x x'"
    and C: "\<And>x x' y y' z z'. C x x' y y' z z' \<Longrightarrow> P y y' \<Longrightarrow> P z z' \<Longrightarrow> P x x'"
  shows "P a a'"
  using assms BuildSeq_induct [where P = "\<lambda>\<langle>x,x'\<rangle>. P x x'"]
  by (smt (verit, del_insts) BuildSeq2_def hsplit)

definition BuildSeq3
   :: "[[hf,hf,hf] \<Rightarrow> bool, [hf,hf,hf,hf,hf,hf,hf,hf,hf] \<Rightarrow> bool, hf, hf, hf, hf, hf] \<Rightarrow> bool"
  where "BuildSeq3 B C s k y y' y'' \<equiv>
         BuildSeq (\<lambda>p. \<exists>x x' x''. p = \<langle>x,x',x''\<rangle> \<and> B x x' x'')
                  (\<lambda>p q r. \<exists>x x' x'' y y' y'' z z' z''.
                           p = \<langle>x,x',x''\<rangle> \<and> q = \<langle>y,y',y''\<rangle> \<and> r = \<langle>z,z',z''\<rangle> \<and>
                           C x x' x'' y y' y'' z z' z'')
                  s k \<langle>y,y',y''\<rangle>"

lemma BuildSeq3_combine:
  assumes b1: "BuildSeq3 B C s1 k1 y1 y1' y1''" and b2: "BuildSeq3 B C s2 k2 y2 y2' y2''"
      and y: "C y y' y'' y1 y1' y1'' y2 y2' y2''"
  shows "BuildSeq3 B C (insf (seq_append (succ k1) s1 s2) (succ (succ (k1 @+ k2))) \<langle>y, y', y''\<rangle>)
                       (succ (succ (k1 @+ k2))) y y' y''"
  using assms
  unfolding BuildSeq3_def by (blast intro: BuildSeq_combine)

lemma BuildSeq3_1: "B y y' y'' \<Longrightarrow> BuildSeq3 B C \<lbrace>\<langle>0, y, y', y''\<rangle>\<rbrace> 0 y y' y''"
  by (auto simp: BuildSeq3_def BuildSeq_1)

lemma BuildSeq3_exI: "B t t' t'' \<Longrightarrow> \<exists>s k. BuildSeq3 B C s k t t' t''"
  by (metis BuildSeq3_1)

lemma BuildSeq3_induct [consumes 1, case_names B C]:
  assumes "BuildSeq3 B C s k a a' a''"
    and B: "\<And>x x' x''. B x x' x'' \<Longrightarrow> P x x' x''"
    and C: "\<And>x x' x'' y y' y'' z z' z''. C x x' x'' y y' y'' z z' z'' \<Longrightarrow> P y y' y'' \<Longrightarrow> P z z' z'' \<Longrightarrow> P x x' x''"
  shows "P a a' a''"
  using assms BuildSeq_induct [where P = "\<lambda>\<langle>x,x',x''\<rangle>. P x x' x''"]
  by (smt (verit, del_insts) BuildSeq3_def hsplit)

section \<open>A Unique Predecessor for every non-empty set\<close>

lemma Rep_hf_0 [simp]: "Rep_hf 0 = 0"
  by (metis Abs_hf_inverse HF.HF_def UNIV_I Zero_hf_def image_empty set_encode_empty)

lemma hmem_imp_less: "x \<^bold>\<in> y \<Longrightarrow> Rep_hf x < Rep_hf y"
  unfolding hmem_def hfset_def image_iff
  apply (clarsimp simp: hmem_def hfset_def set_decode_def Abs_hf_inverse)
  apply (metis div_less even_zero le_less_trans less_exp not_less)
  done

lemma hsubset_imp_le:
  assumes "x \<le> y" shows "Rep_hf x \<le> Rep_hf y"
proof -
  have "\<And>u v. \<lbrakk>\<forall>x. x \<in> Abs_hf ` set_decode (Rep_hf (Abs_hf u)) \<longrightarrow>
                   x \<in> Abs_hf ` set_decode (Rep_hf (Abs_hf v))\<rbrakk>
              \<Longrightarrow> u \<le> v"
    by (metis Abs_hf_inverse UNIV_I imageE image_eqI subsetI subset_decode_imp_le)
  then show ?thesis
    by (metis Rep_hf_inverse assms hfset_def hmem_def hsubsetCE)
qed

lemma diff_hmem_imp_less: assumes "x \<^bold>\<in> y" shows "Rep_hf (y - \<lbrace>x\<rbrace>) < Rep_hf y"
proof -
  have  "Rep_hf (y - \<lbrace>x\<rbrace>) \<le> Rep_hf y"
    by (metis hdiff_iff hsubsetI hsubset_imp_le)
  moreover
  have "Rep_hf (y - \<lbrace>x\<rbrace>) \<noteq> Rep_hf y" using assms
    by (metis Rep_hf_inject hdiff_iff hinsert_iff)
  ultimately show ?thesis
    by (metis le_neq_implies_less)
qed

definition least :: "hf \<Rightarrow> hf"
  where "least a \<equiv> (THE x. x \<^bold>\<in> a \<and> (\<forall>y. y \<^bold>\<in> a \<longrightarrow> Rep_hf x \<le> Rep_hf y))"

lemma least_equality:
  assumes "x \<^bold>\<in> a" and "\<And>y. y \<^bold>\<in> a \<Longrightarrow> Rep_hf x \<le> Rep_hf y"
  shows "least a = x"
  unfolding least_def
  using Rep_hf_inject assms order_antisym_conv by blast

lemma nonempty_imp_ex_least: "a \<noteq> 0 \<Longrightarrow> \<exists>x. x \<^bold>\<in> a \<and> (\<forall>y. y \<^bold>\<in> a \<longrightarrow> Rep_hf x \<le> Rep_hf y)"
proof (induction a rule: hf_induct)
  case 0 thus ?case by simp
next
  case (hinsert u v)
  show ?case
    proof (cases "v=0")
     case True thus ?thesis
       by (rule_tac x=u in exI, simp)
    next
      case False
      thus ?thesis
        by (metis order.trans hinsert.IH(2) hmem_hinsert linorder_le_cases)
    qed
qed

lemma least_hmem: "a \<noteq> 0 \<Longrightarrow> least a \<^bold>\<in> a"
  by (metis least_equality nonempty_imp_ex_least)

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_41
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map x (nil2) = nil2"
| "map x (cons2 z xs) = cons2 (x z) (map x xs)"

theorem property0 :(*Probably the best proof*)
  "((take n (map f xs)) = (map f (take n xs)))"
  find_proof DInd
    (*specifying "xs" is necessary.*)
  apply (induct xs rule: TIP_prop_41.take.induct)
    (*Why "rule:take.induct" instead of "rule:map.induct"?*)
    (*Because "take"'s pattern-matching is complete on the first parameter and
    both first arguments ("n" and "n") are variables here, while
    "map"'s pattern-matching is complete on the second parameter and
    "map"'s second arguments are "xs" and "take n xs" in this case (?)*)
    apply auto
  done

theorem property0' :
  "((take n (map f xs)) = (map f (take n xs)))"
  apply (induct n xs rule: TIP_prop_41.take.induct)(*equivalent to "(induct xs rule: TIP_prop_41.take.induct)"*)
    apply auto
  done

theorem property0'' :(*sub-optimal proof*)
  "((take n (map f xs)) = (map f (take n xs)))"
  apply (induct n arbitrary: xs) (*This "arbitrary: xs" is necessary.*)
   apply fastforce
  apply(induct_tac xs)
   apply auto
  done

theorem property0''' :(*sub-optimal proof*)
  "((take n (map f xs)) = (map f (take n xs)))"
  (*Why does "induct n arbitrary:xs" lead to a shorter proof.
    Because "induct xs arbitrary:n" cannot process the right-hand side ("map f (take n xs)")
    very well. *)
  apply (induct xs arbitrary: n) (*This "arbitrary: xs" is necessary.*)
   apply(induct_tac n)
    apply fastforce+
  apply(induct_tac n)
   apply auto
  done

theorem property0''' :
  "((take n (map f xs)) = (map f (take n xs)))"
  apply (induct rule: TIP_prop_41.take.induct)
  nitpick
  oops

end


section \<open>Tries via Functions\<close>

theory Trie_Fun
imports
  Set_Specs
begin

text \<open>A trie where each node maps a key to sub-tries via a function.
Nice abstract model. Not efficient because of the function space.\<close>

datatype 'a trie = Nd bool "'a \<Rightarrow> 'a trie option"

definition empty :: "'a trie" where
[simp]: "empty = Nd False (\<lambda>_. None)"

fun isin :: "'a trie \<Rightarrow> 'a list \<Rightarrow> bool" where
"isin (Nd b m) [] = b" |
"isin (Nd b m) (k # xs) = (case m k of None \<Rightarrow> False | Some t \<Rightarrow> isin t xs)"

fun insert :: "('a::linorder) list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
"insert [] (Nd b m) = Nd True m" |
"insert (x#xs) (Nd b m) =
   Nd b (m(x := Some(insert xs (case m x of None \<Rightarrow> empty | Some t \<Rightarrow> t))))"

fun delete :: "('a::linorder) list \<Rightarrow> 'a trie \<Rightarrow> 'a trie" where
"delete [] (Nd b m) = Nd False m" |
"delete (x#xs) (Nd b m) = Nd b
   (case m x of
      None \<Rightarrow> m |
      Some t \<Rightarrow> m(x := Some(delete xs t)))"

text \<open>The actual definition of \<open>set\<close> is a bit cryptic but canonical, to enable
primrec to prove termination:\<close>

primrec set :: "'a trie \<Rightarrow> 'a list set" where
"set (Nd b m) = (if b then {[]} else {}) \<union>
    (\<Union>a. case (map_option set o m) a of None \<Rightarrow> {} | Some t \<Rightarrow> (#) a ` t)"

text \<open>This is the more human-readable version:\<close>

lemma set_Nd:
  "set (Nd b m) =
     (if b then {[]} else {}) \<union>
     (\<Union>a. case m a of None \<Rightarrow> {} | Some t \<Rightarrow> (#) a ` set t)"
by (auto simp: split: option.splits)

lemma isin_set: "isin t xs = (xs \<in> set t)"
apply(induction t xs rule: isin.induct)
apply (auto split: option.split)
done

lemma set_insert: "set (insert xs t) = set t \<union> {xs}"
proof(induction xs t rule: insert.induct)
  case 1 thus ?case by simp
next
  case 2
  thus ?case
    apply(simp)
    apply(subst set_eq_iff)
    apply(auto split!: if_splits option.splits)
     apply fastforce
    by (metis imageI option.sel)
qed

lemma set_delete: "set (delete xs t) = set t - {xs}"
proof(induction xs t rule: delete.induct)
  case 1 thus ?case by (force split: option.splits)
next
  case 2
  thus ?case
    apply (auto simp add: image_iff split!: if_splits option.splits)
       apply blast
      apply (metis insertE insertI2 insert_Diff_single option.inject)
     apply blast
    by (metis insertE insertI2 insert_Diff_single option.inject)
qed

interpretation S: Set
where empty = empty and isin = isin and insert = insert and delete = delete
and set = set and invar = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by (simp)
next
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: set_insert)
next
  case 4 thus ?case by(simp add: set_delete)
qed (rule TrueI)+

end


(* Title:      Boolean Semirings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Boolean Semirings\<close>

theory Boolean_Semirings

imports Stone_Algebras.P_Algebras Lattice_Ordered_Semirings

begin

class complemented_distributive_lattice = bounded_distrib_lattice + uminus +
  assumes inf_complement: "x \<sqinter> (-x) = bot"
  assumes sup_complement: "x \<squnion> (-x) = top"
begin

sublocale boolean_algebra where minus = "\<lambda>x y . x \<sqinter> (-y)" and inf = inf and sup = sup and bot = bot and top = top
  apply unfold_locales
  apply (simp add: inf_complement)
  apply (simp add: sup_complement)
  by simp

end

text \<open>M0-algebra\<close>

context lattice_ordered_pre_left_semiring
begin

text \<open>Section 7\<close>

lemma vector_1:
  "vector x \<longleftrightarrow> x * top \<le> x"
  by (simp add: antisym_conv top_right_mult_increasing)

definition zero_vector :: "'a \<Rightarrow> bool" where "zero_vector x \<equiv> x \<le> x * bot"
definition one_vector :: "'a \<Rightarrow> bool" where "one_vector x \<equiv> x * bot \<le> x"

lemma zero_vector_left_zero:
  assumes "zero_vector x"
    shows "x * y = x * bot"
proof -
  have "x * y \<le> x * bot"
    by (metis assms mult_isotone top.extremum vector_mult_closed zero_vector zero_vector_def)
  thus ?thesis
    by (simp add: order.antisym mult_right_isotone)
qed

lemma zero_vector_1:
  "zero_vector x \<longleftrightarrow> (\<forall>y . x * y = x * bot)"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_2:
  "zero_vector x \<longleftrightarrow> (\<forall>y . x * y \<le> x * bot)"
  by (metis eq_refl order_trans top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_3:
  "zero_vector x \<longleftrightarrow> x * 1 = x * bot"
  by (metis mult_sub_right_one zero_vector_def zero_vector_left_zero)

lemma zero_vector_4:
  "zero_vector x \<longleftrightarrow> x * 1 \<le> x * bot"
  using order.antisym mult_right_isotone zero_vector_3 by auto

lemma zero_vector_5:
  "zero_vector x \<longleftrightarrow> x * top = x * bot"
  by (metis top_right_mult_increasing zero_vector_def zero_vector_left_zero)

lemma zero_vector_6:
  "zero_vector x \<longleftrightarrow> x * top \<le> x * bot"
  by (meson mult_right_isotone order_trans top.extremum zero_vector_2)

lemma zero_vector_7:
  "zero_vector x \<longleftrightarrow> (\<forall>y . x * top = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_8:
  "zero_vector x \<longleftrightarrow> (\<forall>y . x * top \<le> x * y)"
  by (metis zero_vector_6 zero_vector_left_zero)

lemma zero_vector_9:
  "zero_vector x \<longleftrightarrow> (\<forall>y . x * 1 = x * y)"
  by (metis zero_vector_1)

lemma zero_vector_0:
  "zero_vector x \<longleftrightarrow> (\<forall>y z . x * y = x * z)"
  by (metis zero_vector_5 zero_vector_left_zero)

text \<open>Theorem 6 / Figure 2: relations between properties\<close>

lemma co_vector_zero_vector_one_vector:
  "co_vector x \<longleftrightarrow> zero_vector x \<and> one_vector x"
  using co_vector_def one_vector_def zero_vector_def by auto

lemma up_closed_one_vector:
  "up_closed x \<Longrightarrow> one_vector x"
  by (metis bot_least mult_right_isotone up_closed_def one_vector_def)

lemma zero_vector_dense:
  "zero_vector x \<Longrightarrow> dense_rel x"
  by (metis zero_vector_0 zero_vector_def)

lemma zero_vector_sup_distributive:
  "zero_vector x \<Longrightarrow> sup_distributive x"
  by (metis sup_distributive_def sup_idem zero_vector_0)

lemma zero_vector_inf_distributive:
  "zero_vector x \<Longrightarrow> inf_distributive x"
  by (metis inf_idem inf_distributive_def zero_vector_0)

lemma up_closed_zero_vector_vector:
  "up_closed x \<Longrightarrow> zero_vector x \<Longrightarrow> vector x"
  by (metis up_closed_def zero_vector_0)

lemma zero_vector_one_vector_vector:
  "zero_vector x \<Longrightarrow> one_vector x \<Longrightarrow> vector x"
  by (metis one_vector_def vector_1 zero_vector_0)

lemma co_vector_vector:
  "co_vector x \<Longrightarrow> vector x"
  by (simp add: co_vector_zero_vector_one_vector zero_vector_one_vector_vector)

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>zero-vector\<close>

lemma zero_zero_vector:
  "zero_vector bot"
  by (simp add: zero_vector_def)

lemma sup_zero_vector:
  "zero_vector x \<Longrightarrow> zero_vector y \<Longrightarrow> zero_vector (x \<squnion> y)"
  by (simp add: mult_right_dist_sup zero_vector_3)

lemma comp_zero_vector:
  "zero_vector x \<Longrightarrow> zero_vector y \<Longrightarrow> zero_vector (x * y)"
  by (metis mult_one_associative zero_vector_0)

text \<open>one-vector\<close>

lemma zero_one_vector:
  "one_vector bot"
  by (simp add: one_vector_def)

lemma one_one_vector:
  "one_vector 1"
  by (simp add: one_up_closed up_closed_one_vector)

lemma top_one_vector:
  "one_vector top"
  by (simp add: one_vector_def)

lemma sup_one_vector:
  "one_vector x \<Longrightarrow> one_vector y \<Longrightarrow> one_vector (x \<squnion> y)"
  by (simp add: mult_right_dist_sup order_trans one_vector_def)

lemma inf_one_vector:
  "one_vector x \<Longrightarrow> one_vector y \<Longrightarrow> one_vector (x \<sqinter> y)"
  by (meson order.trans inf.boundedI mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right one_vector_def)

lemma comp_one_vector:
  "one_vector x \<Longrightarrow> one_vector y \<Longrightarrow> one_vector (x * y)"
  using mult_isotone mult_semi_associative order_lesseq_imp one_vector_def by blast

end

context multirelation_algebra_1
begin

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>zero-vector\<close>

lemma top_zero_vector:
   "zero_vector top"
  by (simp add: mult_left_top zero_vector_def)

end

text \<open>M1-algebra\<close>

context multirelation_algebra_2
begin

text \<open>Section 7\<close>

lemma zero_vector_10:
  "zero_vector x \<longleftrightarrow> x * top = x * 1"
  by (metis mult_one_associative mult_top_associative zero_vector_7)

lemma zero_vector_11:
  "zero_vector x \<longleftrightarrow> x * top \<le> x * 1"
  using order.antisym mult_right_isotone zero_vector_10 by fastforce

text \<open>Theorem 6 / Figure 2: relations between properties\<close>

lemma vector_zero_vector:
  "vector x \<Longrightarrow> zero_vector x"
  by (simp add: zero_vector_def vector_left_annihilator)

lemma vector_up_closed_zero_vector:
  "vector x \<longleftrightarrow> up_closed x \<and> zero_vector x"
  using up_closed_zero_vector_vector vector_up_closed vector_zero_vector by blast

lemma vector_zero_vector_one_vector:
  "vector x \<longleftrightarrow> zero_vector x \<and> one_vector x"
  by (simp add: co_vector_zero_vector_one_vector vector_co_vector)

proposition "(x * bot \<sqinter> y) * 1 = x * bot \<sqinter> y * 1" nitpick [expect=genuine,card=7] oops

end

text \<open>M3-algebra\<close>

context up_closed_multirelation_algebra
begin

lemma up_closed:
  "up_closed x"
  by (simp add: up_closed_def)

lemma dedekind_1_left:
  "x * 1 \<sqinter> y \<le> (x \<sqinter> y * 1) * 1"
  by simp

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>zero-vector\<close>

lemma zero_vector_dual:
  "zero_vector x \<longleftrightarrow> zero_vector (x\<^sup>d)"
  using up_closed_zero_vector_vector vector_dual vector_zero_vector up_closed by blast

end

text \<open>complemented M0-algebra\<close>

class lattice_ordered_pre_left_semiring_b = lattice_ordered_pre_left_semiring + complemented_distributive_lattice
begin

definition down_closed :: "'a \<Rightarrow> bool" where "down_closed x \<equiv> -x * 1 \<le> -x"

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>down-closed\<close>

lemma zero_down_closed:
  "down_closed bot"
  by (simp add: down_closed_def)

lemma top_down_closed:
  "down_closed top"
  by (simp add: down_closed_def)

lemma complement_down_closed_up_closed:
  "down_closed x \<longleftrightarrow> up_closed (-x)"
  using down_closed_def order.antisym mult_sub_right_one up_closed_def by auto

lemma sup_down_closed:
  "down_closed x \<Longrightarrow> down_closed y \<Longrightarrow> down_closed (x \<squnion> y)"
  by (simp add: complement_down_closed_up_closed inf_up_closed)

lemma inf_down_closed:
  "down_closed x \<Longrightarrow> down_closed y \<Longrightarrow> down_closed (x \<sqinter> y)"
  by (simp add: complement_down_closed_up_closed sup_up_closed)

end

class multirelation_algebra_1b = multirelation_algebra_1 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

text \<open>Theorem 7.1\<close>

lemma complement_mult_zero_sub:
  "-(x * bot) \<le> -x * bot"
proof -
  have "top = -x * bot \<squnion> x * bot"
    by (metis compl_sup_top mult_left_top mult_right_dist_sup)
  thus ?thesis
    by (simp add: heyting.implies_order sup.commute)
qed

text \<open>Theorem 7.2\<close>

lemma transitive_zero_vector_complement:
  "transitive x \<Longrightarrow> zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_mono mult_right_isotone order_trans zero_vector_def bot_least)

lemma transitive_dense_complement:
  "transitive x \<Longrightarrow> dense_rel (-x)"
  by (simp add: zero_vector_dense transitive_zero_vector_complement)

lemma transitive_sup_distributive_complement:
  "transitive x \<Longrightarrow> sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive transitive_zero_vector_complement)

lemma transitive_inf_distributive_complement:
  "transitive x \<Longrightarrow> inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive transitive_zero_vector_complement)

lemma up_closed_zero_vector_complement:
  "up_closed x \<Longrightarrow> zero_vector (-x)"
  by (meson complement_mult_zero_sub compl_le_swap2 one_vector_def order_trans up_closed_one_vector zero_vector_def)

lemma up_closed_dense_complement:
  "up_closed x \<Longrightarrow> dense_rel (-x)"
  by (simp add: zero_vector_dense up_closed_zero_vector_complement)

lemma up_closed_sup_distributive_complement:
  "up_closed x \<Longrightarrow> sup_distributive (-x)"
  by (simp add: zero_vector_sup_distributive up_closed_zero_vector_complement)

lemma up_closed_inf_distributive_complement:
  "up_closed x \<Longrightarrow> inf_distributive (-x)"
  by (simp add: zero_vector_inf_distributive up_closed_zero_vector_complement)

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>closure under complement\<close>

lemma co_total_total:
  "co_total x \<Longrightarrow> total (-x)"
  by (metis complement_mult_zero_sub co_total_def compl_bot_eq mult_left_sub_dist_sup_right sup_bot_right top_le)

lemma complement_one_vector_zero_vector:
  "one_vector x \<Longrightarrow> zero_vector (-x)"
  using compl_mono complement_mult_zero_sub one_vector_def order_trans zero_vector_def by blast

text \<open>Theorem 6 / Figure 2: relations between properties\<close>

lemma down_closed_zero_vector:
  "down_closed x \<Longrightarrow> zero_vector x"
  using complement_down_closed_up_closed up_closed_zero_vector_complement by force

lemma down_closed_one_vector_vector:
  "down_closed x \<Longrightarrow> one_vector x \<Longrightarrow> vector x"
  by (simp add: down_closed_zero_vector zero_vector_one_vector_vector)

proposition complement_vector: "vector x \<longrightarrow> vector (-x)" nitpick [expect=genuine,card=8] oops

end

class multirelation_algebra_1c = multirelation_algebra_1b +
  assumes dedekind_top_left: "x * top \<sqinter> y \<le> (x \<sqinter> y * top) * top"
  assumes comp_zero_inf: "(x * bot \<sqinter> y) * bot \<le> (x \<sqinter> y) * bot"
begin

text \<open>Theorem 7.3\<close>

lemma schroeder_top_sub:
  "-(x * top) * top \<le> -x"
proof -
  have "-(x * top) * top \<sqinter> x \<le> bot"
    by (metis dedekind_top_left p_inf zero_vector)
  thus ?thesis
    by (simp add: shunting_1)
qed

text \<open>Theorem 7.4\<close>

lemma schroeder_top:
  "x * top \<le> y \<longleftrightarrow> -y * top \<le> -x"
  apply (rule iffI)
  using compl_mono inf.order_trans mult_left_isotone schroeder_top_sub apply blast
  by (metis compl_mono double_compl mult_left_isotone order_trans schroeder_top_sub)

text \<open>Theorem 7.5\<close>

lemma schroeder_top_eq:
  "-(x * top) * top = -(x * top)"
  using vector_1 vector_mult_closed vector_top_closed schroeder_top by auto

lemma schroeder_one_eq:
  "-(x * top) * 1 = -(x * top)"
  by (metis top_mult_right_one schroeder_top_eq)

text \<open>Theorem 7.6\<close>

lemma vector_inf_comp:
  "x * top \<sqinter> y * z = (x * top \<sqinter> y) * z"
proof (rule order.antisym)
  have "x * top \<sqinter> y * z = x * top \<sqinter> ((x * top \<sqinter> y) \<squnion> (-(x * top) \<sqinter> y)) * z"
    by (simp add: inf_commute)
  also have "... = x * top \<sqinter> ((x * top \<sqinter> y) * z \<squnion> (-(x * top) \<sqinter> y) * z)"
    by (simp add: inf_sup_distrib2 mult_right_dist_sup)
  also have "... = (x * top \<sqinter> (x * top \<sqinter> y) * z) \<squnion> (x * top \<sqinter> (-(x * top) \<sqinter> y) * z)"
    by (simp add: inf_sup_distrib1)
  also have "... \<le> (x * top \<sqinter> y) * z \<squnion> (x * top \<sqinter> (-(x * top) \<sqinter> y) * z)"
    by (simp add: le_infI2)
  also have "... \<le> (x * top \<sqinter> y) * z \<squnion> (x * top \<sqinter> -(x * top) * z)"
    by (metis inf.sup_left_isotone inf_commute mult_right_sub_dist_inf_left sup_right_isotone)
  also have "... \<le> (x * top \<sqinter> y) * z \<squnion> (x * top \<sqinter> -(x * top) * top)"
    using inf.sup_right_isotone mult_right_isotone sup_right_isotone by auto
  also have "... = (x * top \<sqinter> y) * z"
    by (simp add: schroeder_top_eq)
  finally show "x * top \<sqinter> y * z \<le> (x * top \<sqinter> y) * z"
    .
next
  show "(x * top \<sqinter> y) * z \<le> x * top \<sqinter> y * z"
    by (metis inf.bounded_iff mult_left_top mult_right_sub_dist_inf_left mult_right_sub_dist_inf_right mult_semi_associative order_lesseq_imp)
qed

(* The following proof is based on \<open>vector_inf_comp\<close>, so the latter could serve as axiom instead. *)
lemma dedekind_top_left_var:
  "x * top \<sqinter> y \<le> (x \<sqinter> y * top) * top"
  by (metis inf.commute top_right_mult_increasing vector_inf_comp)

text \<open>Theorem 7.7\<close>

lemma vector_zero_inf_comp:
  "(x * bot \<sqinter> y) * z = x * bot \<sqinter> y * z"
  by (metis vector_inf_comp vector_mult_closed zero_vector)

lemma vector_zero_inf_comp_2:
  "(x * bot \<sqinter> y) * z = (x * bot \<sqinter> y * 1) * z"
  by (simp add: vector_zero_inf_comp)

text \<open>Theorem 7.8\<close>

lemma comp_zero_inf_2:
  "x * bot \<sqinter> y * bot = (x \<sqinter> y) * bot"
  using order.antisym mult_right_sub_dist_inf comp_zero_inf vector_zero_inf_comp by auto

lemma comp_zero_inf_3:
  "x * bot \<sqinter> y * bot = (x * bot \<sqinter> y) * bot"
  by (simp add: vector_zero_inf_comp)

lemma comp_zero_inf_4:
  "x * bot \<sqinter> y * bot = (x * bot \<sqinter> y * bot) * bot"
  by (metis comp_zero_inf_2 inf.commute vector_zero_inf_comp)

lemma comp_zero_inf_5:
  "x * bot \<sqinter> y * bot = (x * 1 \<sqinter> y * 1) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

lemma comp_zero_inf_6:
  "x * bot \<sqinter> y * bot = (x * 1 \<sqinter> y * bot) * bot"
  using inf.sup_monoid.add_commute vector_zero_inf_comp by fastforce

lemma comp_zero_inf_7:
  "x * bot \<sqinter> y * bot = (x * 1 \<sqinter> y) * bot"
  by (metis comp_zero_inf_2 mult_one_associative)

text \<open>Theorem 10 / Figure 3: closure properties\<close>

text \<open>zero-vector\<close>

lemma inf_zero_vector:
  "zero_vector x \<Longrightarrow> zero_vector y \<Longrightarrow> zero_vector (x \<sqinter> y)"
  by (metis comp_zero_inf_2 inf.sup_mono zero_vector_def)

text \<open>down-closed\<close>

lemma comp_down_closed:
  "down_closed x \<Longrightarrow> down_closed y \<Longrightarrow> down_closed (x * y)"
  by (metis complement_down_closed_up_closed down_closed_zero_vector up_closed_def zero_vector_0 schroeder_one_eq)

text \<open>closure under complement\<close>

lemma complement_vector:
  "vector x \<longleftrightarrow> vector (-x)"
  using vector_1 schroeder_top by blast

lemma complement_zero_vector_one_vector:
  "zero_vector x \<Longrightarrow> one_vector (-x)"
  by (metis comp_zero_inf_2 order.antisym complement_mult_zero_sub double_compl inf.sup_monoid.add_commute mult_left_zero one_vector_def order.refl pseudo_complement top_right_mult_increasing zero_vector_0)

lemma complement_zero_vector_one_vector_iff:
  "zero_vector x \<longleftrightarrow> one_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

lemma complement_one_vector_zero_vector_iff:
  "one_vector x \<longleftrightarrow> zero_vector (-x)"
  using complement_zero_vector_one_vector complement_one_vector_zero_vector by force

text \<open>Theorem 6 / Figure 2: relations between properties\<close>

lemma vector_down_closed:
  "vector x \<Longrightarrow> down_closed x"
  using complement_vector complement_down_closed_up_closed vector_up_closed by blast

lemma co_vector_down_closed:
  "co_vector x \<Longrightarrow> down_closed x"
  by (simp add: co_vector_vector vector_down_closed)

lemma vector_down_closed_one_vector:
  "vector x \<longleftrightarrow> down_closed x \<and> one_vector x"
  using down_closed_one_vector_vector up_closed_one_vector vector_up_closed vector_down_closed by blast

lemma vector_up_closed_down_closed:
  "vector x \<longleftrightarrow> up_closed x \<and> down_closed x"
  using down_closed_zero_vector up_closed_zero_vector_vector vector_up_closed vector_down_closed by blast

text \<open>Section 7\<close>

lemma vector_b1:
  "vector x \<longleftrightarrow> -x * top = -x"
  using complement_vector by auto

lemma vector_b2:
  "vector x \<longleftrightarrow> -x * bot = -x"
  by (metis down_closed_zero_vector vector_mult_closed zero_vector zero_vector_left_zero vector_b1 vector_down_closed)

lemma covector_b1:
  "co_vector x \<longleftrightarrow> -x * top = -x"
  using co_vector_def co_vector_vector vector_b1 vector_b2 by force

lemma covector_b2:
  "co_vector x \<longleftrightarrow> -x * bot = -x"
  using covector_b1 vector_b1 vector_b2 by auto

lemma vector_co_vector_iff:
  "vector x \<longleftrightarrow> co_vector x"
  by (simp add: covector_b2 vector_b2)

lemma zero_vector_b:
  "zero_vector x \<longleftrightarrow> -x * bot \<le> -x"
  by (simp add: complement_zero_vector_one_vector_iff one_vector_def)

lemma one_vector_b1:
  "one_vector x \<longleftrightarrow> -x \<le> -x * bot"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_def)

lemma one_vector_b0:
  "one_vector x \<longleftrightarrow> (\<forall>y z . -x * y = -x * z)"
  by (simp add: complement_one_vector_zero_vector_iff zero_vector_0)

proposition schroeder_one: "x * -1 \<le> y \<longleftrightarrow> -y * -1 \<le> -x" nitpick [expect=genuine,card=8] oops

end

class multirelation_algebra_2b = multirelation_algebra_2 + complemented_distributive_lattice
begin

subclass multirelation_algebra_1b ..

proposition "-x * bot \<le> -(x * bot)" nitpick [expect=genuine,card=8] oops

end

text \<open>complemented M1-algebra\<close>

class multirelation_algebra_2c = multirelation_algebra_2b + multirelation_algebra_1c

class multirelation_algebra_3b = multirelation_algebra_3 + complemented_distributive_lattice
begin

subclass lattice_ordered_pre_left_semiring_b ..

lemma dual_complement_commute:
  "-(x\<^sup>d) = (-x)\<^sup>d"
  by (metis compl_unique dual_dist_sup dual_dist_inf dual_top dual_zero inf_complement sup_compl_top)

end

text \<open>complemented M2-algebra\<close>

class multirelation_algebra_5b = multirelation_algebra_5 + complemented_distributive_lattice
begin

subclass multirelation_algebra_2b ..

subclass multirelation_algebra_3b ..

lemma dual_down_closed:
  "down_closed x \<longleftrightarrow> down_closed (x\<^sup>d)"
  using complement_down_closed_up_closed dual_complement_commute dual_up_closed by auto

end

class multirelation_algebra_5c = multirelation_algebra_5b + multirelation_algebra_1c
begin

lemma complement_mult_zero_below:
  "-x * bot \<le> -(x * bot)"
  by (simp add: comp_zero_inf_2 shunting_1)

proposition "x * 1 \<sqinter> y * 1 \<le> (x \<sqinter> y) * 1" nitpick [expect=genuine,card=4] oops
proposition "x * 1 \<sqinter> (y * 1) \<le> (x * 1 \<sqinter> y) * 1" nitpick [expect=genuine,card=4] oops

end

class up_closed_multirelation_algebra_b = up_closed_multirelation_algebra + complemented_distributive_lattice
begin

subclass multirelation_algebra_5c
  apply unfold_locales
  apply (metis inf.sup_monoid.add_commute top_right_mult_increasing vector_inf_comp)
  using mult_right_dist_inf vector_zero_inf_comp by auto

lemma complement_zero_vector:
  "zero_vector x \<longleftrightarrow> zero_vector (-x)"
  by (simp add: zero_right_mult_decreasing zero_vector_b)

lemma down_closed:
  "down_closed x"
  by (simp add: down_closed_def)

lemma vector:
  "vector x"
  by (simp add: down_closed up_closed_def vector_up_closed_down_closed)

end

end


theory Infinite
  imports Main
begin

class infinite =
  assumes infinite_UNIV: "infinite (UNIV :: 'a set)"
begin

lemma arb_element: "finite Y \<Longrightarrow> \<exists>x :: 'a. x \<notin> Y"
  using ex_new_if_finite infinite_UNIV
  by blast

lemma arb_finite_subset: "finite Y \<Longrightarrow> \<exists>X :: 'a set. Y \<inter> X = {} \<and> finite X \<and> n \<le> card X"
proof -
  assume fin: "finite Y"
  then obtain X where "X \<subseteq> UNIV - Y" "finite X" "n \<le> card X"
    using infinite_UNIV
    by (metis Compl_eq_Diff_UNIV finite_compl infinite_arbitrarily_large order_refl)
  then show ?thesis
    by auto
qed

lemma arb_countable_map: "finite Y \<Longrightarrow> \<exists>f :: (nat \<Rightarrow> 'a). inj f \<and> range f \<subseteq> UNIV - Y"
  using infinite_UNIV
  by (auto simp: infinite_countable_subset)

end

instance nat :: infinite
  by standard auto

end


(*  Title:       HOL/Complex.thy
    Author:      Jacques D. Fleuriot
    Copyright:   2001 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2003/4
*)

section {* Complex Numbers: Rectangular and Polar Representations *}

theory Complex
imports Transcendental
begin

text {*
We use the @{text codatatype} command to define the type of complex numbers. This allows us to use
@{text primcorec} to define complex functions by defining their real and imaginary result
separately.
*}

codatatype complex = Complex (Re: real) (Im: real)

lemma complex_surj: "Complex (Re z) (Im z) = z"
  by (rule complex.collapse)

lemma complex_eqI [intro?]: "\<lbrakk>Re x = Re y; Im x = Im y\<rbrakk> \<Longrightarrow> x = y"
  by (rule complex.expand) simp

lemma complex_eq_iff: "x = y \<longleftrightarrow> Re x = Re y \<and> Im x = Im y"
  by (auto intro: complex.expand)

subsection {* Addition and Subtraction *}

instantiation complex :: ab_group_add
begin

primcorec zero_complex where
  "Re 0 = 0"
| "Im 0 = 0"

primcorec plus_complex where
  "Re (x + y) = Re x + Re y"
| "Im (x + y) = Im x + Im y"

primcorec uminus_complex where
  "Re (- x) = - Re x"
| "Im (- x) = - Im x"

primcorec minus_complex where
  "Re (x - y) = Re x - Re y"
| "Im (x - y) = Im x - Im y"

instance
  by intro_classes (simp_all add: complex_eq_iff)

end

subsection {* Multiplication and Division *}

instantiation complex :: field_inverse_zero
begin

primcorec one_complex where
  "Re 1 = 1"
| "Im 1 = 0"

primcorec times_complex where
  "Re (x * y) = Re x * Re y - Im x * Im y"
| "Im (x * y) = Re x * Im y + Im x * Re y"

primcorec inverse_complex where
  "Re (inverse x) = Re x / ((Re x)\<^sup>2 + (Im x)\<^sup>2)"
| "Im (inverse x) = - Im x / ((Re x)\<^sup>2 + (Im x)\<^sup>2)"

definition "x / (y\<Colon>complex) = x * inverse y"

instance
  by intro_classes
     (simp_all add: complex_eq_iff divide_complex_def
      distrib_left distrib_right right_diff_distrib left_diff_distrib
      power2_eq_square add_divide_distrib [symmetric])

end

lemma Re_divide: "Re (x / y) = (Re x * Re y + Im x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2)"
  unfolding divide_complex_def by (simp add: add_divide_distrib)

lemma Im_divide: "Im (x / y) = (Im x * Re y - Re x * Im y) / ((Re y)\<^sup>2 + (Im y)\<^sup>2)"
  unfolding divide_complex_def times_complex.sel inverse_complex.sel
  by (simp_all add: divide_simps)

lemma Re_power2: "Re (x ^ 2) = (Re x)^2 - (Im x)^2"
  by (simp add: power2_eq_square)

lemma Im_power2: "Im (x ^ 2) = 2 * Re x * Im x"
  by (simp add: power2_eq_square)

lemma Re_power_real: "Im x = 0 \<Longrightarrow> Re (x ^ n) = Re x ^ n "
  by (induct n) simp_all

lemma Im_power_real: "Im x = 0 \<Longrightarrow> Im (x ^ n) = 0"
  by (induct n) simp_all

subsection {* Scalar Multiplication *}

instantiation complex :: real_field
begin

primcorec scaleR_complex where
  "Re (scaleR r x) = r * Re x"
| "Im (scaleR r x) = r * Im x"

instance
proof
  fix a b :: real and x y :: complex
  show "scaleR a (x + y) = scaleR a x + scaleR a y"
    by (simp add: complex_eq_iff distrib_left)
  show "scaleR (a + b) x = scaleR a x + scaleR b x"
    by (simp add: complex_eq_iff distrib_right)
  show "scaleR a (scaleR b x) = scaleR (a * b) x"
    by (simp add: complex_eq_iff mult.assoc)
  show "scaleR 1 x = x"
    by (simp add: complex_eq_iff)
  show "scaleR a x * y = scaleR a (x * y)"
    by (simp add: complex_eq_iff algebra_simps)
  show "x * scaleR a y = scaleR a (x * y)"
    by (simp add: complex_eq_iff algebra_simps)
qed

end

subsection {* Numerals, Arithmetic, and Embedding from Reals *}

abbreviation complex_of_real :: "real \<Rightarrow> complex"
  where "complex_of_real \<equiv> of_real"

declare [[coercion "of_real :: real \<Rightarrow> complex"]]
declare [[coercion "of_rat :: rat \<Rightarrow> complex"]]
declare [[coercion "of_int :: int \<Rightarrow> complex"]]
declare [[coercion "of_nat :: nat \<Rightarrow> complex"]]

lemma complex_Re_of_nat [simp]: "Re (of_nat n) = of_nat n"
  by (induct n) simp_all

lemma complex_Im_of_nat [simp]: "Im (of_nat n) = 0"
  by (induct n) simp_all

lemma complex_Re_of_int [simp]: "Re (of_int z) = of_int z"
  by (cases z rule: int_diff_cases) simp

lemma complex_Im_of_int [simp]: "Im (of_int z) = 0"
  by (cases z rule: int_diff_cases) simp

lemma complex_Re_numeral [simp]: "Re (numeral v) = numeral v"
  using complex_Re_of_int [of "numeral v"] by simp

lemma complex_Im_numeral [simp]: "Im (numeral v) = 0"
  using complex_Im_of_int [of "numeral v"] by simp

lemma Re_complex_of_real [simp]: "Re (complex_of_real z) = z"
  by (simp add: of_real_def)

lemma Im_complex_of_real [simp]: "Im (complex_of_real z) = 0"
  by (simp add: of_real_def)

subsection {* The Complex Number $i$ *}

primcorec "ii" :: complex  ("\<i>") where
  "Re ii = 0"
| "Im ii = 1"

lemma Complex_eq[simp]: "Complex a b = a + \<i> * b"
  by (simp add: complex_eq_iff)

lemma complex_eq: "a = Re a + \<i> * Im a"
  by (simp add: complex_eq_iff)

lemma fun_complex_eq: "f = (\<lambda>x. Re (f x) + \<i> * Im (f x))"
  by (simp add: fun_eq_iff complex_eq)

lemma i_squared [simp]: "ii * ii = -1"
  by (simp add: complex_eq_iff)

lemma power2_i [simp]: "ii\<^sup>2 = -1"
  by (simp add: power2_eq_square)

lemma inverse_i [simp]: "inverse ii = - ii"
  by (rule inverse_unique) simp

lemma divide_i [simp]: "x / ii = - ii * x"
  by (simp add: divide_complex_def)

lemma complex_i_mult_minus [simp]: "ii * (ii * x) = - x"
  by (simp add: mult.assoc [symmetric])

lemma complex_i_not_zero [simp]: "ii \<noteq> 0"
  by (simp add: complex_eq_iff)

lemma complex_i_not_one [simp]: "ii \<noteq> 1"
  by (simp add: complex_eq_iff)

lemma complex_i_not_numeral [simp]: "ii \<noteq> numeral w"
  by (simp add: complex_eq_iff)

lemma complex_i_not_neg_numeral [simp]: "ii \<noteq> - numeral w"
  by (simp add: complex_eq_iff)

lemma complex_split_polar: "\<exists>r a. z = complex_of_real r * (cos a + \<i> * sin a)"
  by (simp add: complex_eq_iff polar_Ex)

subsection {* Vector Norm *}

instantiation complex :: real_normed_field
begin

definition "norm z = sqrt ((Re z)\<^sup>2 + (Im z)\<^sup>2)"

abbreviation cmod :: "complex \<Rightarrow> real"
  where "cmod \<equiv> norm"

definition complex_sgn_def:
  "sgn x = x /\<^sub>R cmod x"

definition dist_complex_def:
  "dist x y = cmod (x - y)"

definition open_complex_def:
  "open (S :: complex set) \<longleftrightarrow> (\<forall>x\<in>S. \<exists>e>0. \<forall>y. dist y x < e \<longrightarrow> y \<in> S)"

instance proof
  fix r :: real and x y :: complex and S :: "complex set"
  show "(norm x = 0) = (x = 0)"
    by (simp add: norm_complex_def complex_eq_iff)
  show "norm (x + y) \<le> norm x + norm y"
    by (simp add: norm_complex_def complex_eq_iff real_sqrt_sum_squares_triangle_ineq)
  show "norm (scaleR r x) = \<bar>r\<bar> * norm x"
    by (simp add: norm_complex_def complex_eq_iff power_mult_distrib distrib_left [symmetric] real_sqrt_mult)
  show "norm (x * y) = norm x * norm y"
    by (simp add: norm_complex_def complex_eq_iff real_sqrt_mult [symmetric] power2_eq_square algebra_simps)
qed (rule complex_sgn_def dist_complex_def open_complex_def)+

end

lemma norm_ii [simp]: "norm ii = 1"
  by (simp add: norm_complex_def)

lemma cmod_unit_one: "cmod (cos a + \<i> * sin a) = 1"
  by (simp add: norm_complex_def)

lemma cmod_complex_polar: "cmod (r * (cos a + \<i> * sin a)) = \<bar>r\<bar>"
  by (simp add: norm_mult cmod_unit_one)

lemma complex_Re_le_cmod: "Re x \<le> cmod x"
  unfolding norm_complex_def
  by (rule real_sqrt_sum_squares_ge1)

lemma complex_mod_minus_le_complex_mod: "- cmod x \<le> cmod x"
  by (rule order_trans [OF _ norm_ge_zero]) simp

lemma complex_mod_triangle_ineq2: "cmod (b + a) - cmod b \<le> cmod a"
  by (rule ord_le_eq_trans [OF norm_triangle_ineq2]) simp

lemma abs_Re_le_cmod: "\<bar>Re x\<bar> \<le> cmod x"
  by (simp add: norm_complex_def)

lemma abs_Im_le_cmod: "\<bar>Im x\<bar> \<le> cmod x"
  by (simp add: norm_complex_def)

lemma cmod_le: "cmod z \<le> \<bar>Re z\<bar> + \<bar>Im z\<bar>"
  apply (subst complex_eq)
  apply (rule order_trans)
  apply (rule norm_triangle_ineq)
  apply (simp add: norm_mult)
  done

lemma cmod_eq_Re: "Im z = 0 \<Longrightarrow> cmod z = \<bar>Re z\<bar>"
  by (simp add: norm_complex_def)

lemma cmod_eq_Im: "Re z = 0 \<Longrightarrow> cmod z = \<bar>Im z\<bar>"
  by (simp add: norm_complex_def)

lemma cmod_power2: "cmod z ^ 2 = (Re z)^2 + (Im z)^2"
  by (simp add: norm_complex_def)

lemma cmod_plus_Re_le_0_iff: "cmod z + Re z \<le> 0 \<longleftrightarrow> Re z = - cmod z"
  using abs_Re_le_cmod[of z] by auto

lemma Im_eq_0: "\<bar>Re z\<bar> = cmod z \<Longrightarrow> Im z = 0"
  by (subst (asm) power_eq_iff_eq_base[symmetric, where n=2])
     (auto simp add: norm_complex_def)

lemma abs_sqrt_wlog:
  fixes x::"'a::linordered_idom"
  assumes "\<And>x::'a. x \<ge> 0 \<Longrightarrow> P x (x\<^sup>2)" shows "P \<bar>x\<bar> (x\<^sup>2)"
by (metis abs_ge_zero assms power2_abs)

lemma complex_abs_le_norm: "\<bar>Re z\<bar> + \<bar>Im z\<bar> \<le> sqrt 2 * norm z"
  unfolding norm_complex_def
  apply (rule abs_sqrt_wlog [where x="Re z"])
  apply (rule abs_sqrt_wlog [where x="Im z"])
  apply (rule power2_le_imp_le)
  apply (simp_all add: power2_sum add.commute sum_squares_bound real_sqrt_mult [symmetric])
  done

text {* Properties of complex signum. *}

lemma sgn_eq: "sgn z = z / complex_of_real (cmod z)"
  by (simp add: sgn_div_norm divide_inverse scaleR_conv_of_real mult.commute)

lemma Re_sgn [simp]: "Re(sgn z) = Re(z)/cmod z"
  by (simp add: complex_sgn_def divide_inverse)

lemma Im_sgn [simp]: "Im(sgn z) = Im(z)/cmod z"
  by (simp add: complex_sgn_def divide_inverse)

subsection {* Completeness of the Complexes *}

lemma bounded_linear_Re: "bounded_linear Re"
  by (rule bounded_linear_intro [where K=1], simp_all add: norm_complex_def)

lemma bounded_linear_Im: "bounded_linear Im"
  by (rule bounded_linear_intro [where K=1], simp_all add: norm_complex_def)

lemmas Cauchy_Re = bounded_linear.Cauchy [OF bounded_linear_Re]
lemmas Cauchy_Im = bounded_linear.Cauchy [OF bounded_linear_Im]
lemmas tendsto_Re [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Re]
lemmas tendsto_Im [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_Im]
lemmas isCont_Re [simp] = bounded_linear.isCont [OF bounded_linear_Re]
lemmas isCont_Im [simp] = bounded_linear.isCont [OF bounded_linear_Im]
lemmas continuous_Re [simp] = bounded_linear.continuous [OF bounded_linear_Re]
lemmas continuous_Im [simp] = bounded_linear.continuous [OF bounded_linear_Im]
lemmas continuous_on_Re [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Re]
lemmas continuous_on_Im [continuous_intros] = bounded_linear.continuous_on[OF bounded_linear_Im]
lemmas has_derivative_Re [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Re]
lemmas has_derivative_Im [derivative_intros] = bounded_linear.has_derivative[OF bounded_linear_Im]
lemmas sums_Re = bounded_linear.sums [OF bounded_linear_Re]
lemmas sums_Im = bounded_linear.sums [OF bounded_linear_Im]

lemma tendsto_Complex [tendsto_intros]:
  "(f ---> a) F \<Longrightarrow> (g ---> b) F \<Longrightarrow> ((\<lambda>x. Complex (f x) (g x)) ---> Complex a b) F"
  by (auto intro!: tendsto_intros)

lemma tendsto_complex_iff:
  "(f ---> x) F \<longleftrightarrow> (((\<lambda>x. Re (f x)) ---> Re x) F \<and> ((\<lambda>x. Im (f x)) ---> Im x) F)"
proof safe
  assume "((\<lambda>x. Re (f x)) ---> Re x) F" "((\<lambda>x. Im (f x)) ---> Im x) F"
  from tendsto_Complex[OF this] show "(f ---> x) F"
    unfolding complex.collapse .
qed (auto intro: tendsto_intros)

lemma continuous_complex_iff: "continuous F f \<longleftrightarrow>
    continuous F (\<lambda>x. Re (f x)) \<and> continuous F (\<lambda>x. Im (f x))"
  unfolding continuous_def tendsto_complex_iff ..

lemma has_vector_derivative_complex_iff: "(f has_vector_derivative x) F \<longleftrightarrow>
    ((\<lambda>x. Re (f x)) has_field_derivative (Re x)) F \<and>
    ((\<lambda>x. Im (f x)) has_field_derivative (Im x)) F"
  unfolding has_vector_derivative_def has_field_derivative_def has_derivative_def tendsto_complex_iff
  by (simp add: field_simps bounded_linear_scaleR_left bounded_linear_mult_right)

lemma has_field_derivative_Re[derivative_intros]:
  "(f has_vector_derivative D) F \<Longrightarrow> ((\<lambda>x. Re (f x)) has_field_derivative (Re D)) F"
  unfolding has_vector_derivative_complex_iff by safe

lemma has_field_derivative_Im[derivative_intros]:
  "(f has_vector_derivative D) F \<Longrightarrow> ((\<lambda>x. Im (f x)) has_field_derivative (Im D)) F"
  unfolding has_vector_derivative_complex_iff by safe

instance complex :: banach
proof
  fix X :: "nat \<Rightarrow> complex"
  assume X: "Cauchy X"
  then have "(\<lambda>n. Complex (Re (X n)) (Im (X n))) ----> Complex (lim (\<lambda>n. Re (X n))) (lim (\<lambda>n. Im (X n)))"
    by (intro tendsto_Complex convergent_LIMSEQ_iff[THEN iffD1] Cauchy_convergent_iff[THEN iffD1] Cauchy_Re Cauchy_Im)
  then show "convergent X"
    unfolding complex.collapse by (rule convergentI)
qed

declare
  DERIV_power[where 'a=complex, unfolded of_nat_def[symmetric], derivative_intros]

subsection {* Complex Conjugation *}

primcorec cnj :: "complex \<Rightarrow> complex" where
  "Re (cnj z) = Re z"
| "Im (cnj z) = - Im z"

lemma complex_cnj_cancel_iff [simp]: "(cnj x = cnj y) = (x = y)"
  by (simp add: complex_eq_iff)

lemma complex_cnj_cnj [simp]: "cnj (cnj z) = z"
  by (simp add: complex_eq_iff)

lemma complex_cnj_zero [simp]: "cnj 0 = 0"
  by (simp add: complex_eq_iff)

lemma complex_cnj_zero_iff [iff]: "(cnj z = 0) = (z = 0)"
  by (simp add: complex_eq_iff)

lemma complex_cnj_add [simp]: "cnj (x + y) = cnj x + cnj y"
  by (simp add: complex_eq_iff)

lemma cnj_setsum [simp]: "cnj (setsum f s) = (\<Sum>x\<in>s. cnj (f x))"
  by (induct s rule: infinite_finite_induct) auto

lemma complex_cnj_diff [simp]: "cnj (x - y) = cnj x - cnj y"
  by (simp add: complex_eq_iff)

lemma complex_cnj_minus [simp]: "cnj (- x) = - cnj x"
  by (simp add: complex_eq_iff)

lemma complex_cnj_one [simp]: "cnj 1 = 1"
  by (simp add: complex_eq_iff)

lemma complex_cnj_mult [simp]: "cnj (x * y) = cnj x * cnj y"
  by (simp add: complex_eq_iff)

lemma cnj_setprod [simp]: "cnj (setprod f s) = (\<Prod>x\<in>s. cnj (f x))"
  by (induct s rule: infinite_finite_induct) auto

lemma complex_cnj_inverse [simp]: "cnj (inverse x) = inverse (cnj x)"
  by (simp add: complex_eq_iff)

lemma complex_cnj_divide [simp]: "cnj (x / y) = cnj x / cnj y"
  by (simp add: divide_complex_def)

lemma complex_cnj_power [simp]: "cnj (x ^ n) = cnj x ^ n"
  by (induct n) simp_all

lemma complex_cnj_of_nat [simp]: "cnj (of_nat n) = of_nat n"
  by (simp add: complex_eq_iff)

lemma complex_cnj_of_int [simp]: "cnj (of_int z) = of_int z"
  by (simp add: complex_eq_iff)

lemma complex_cnj_numeral [simp]: "cnj (numeral w) = numeral w"
  by (simp add: complex_eq_iff)

lemma complex_cnj_neg_numeral [simp]: "cnj (- numeral w) = - numeral w"
  by (simp add: complex_eq_iff)

lemma complex_cnj_scaleR [simp]: "cnj (scaleR r x) = scaleR r (cnj x)"
  by (simp add: complex_eq_iff)

lemma complex_mod_cnj [simp]: "cmod (cnj z) = cmod z"
  by (simp add: norm_complex_def)

lemma complex_cnj_complex_of_real [simp]: "cnj (of_real x) = of_real x"
  by (simp add: complex_eq_iff)

lemma complex_cnj_i [simp]: "cnj ii = - ii"
  by (simp add: complex_eq_iff)

lemma complex_add_cnj: "z + cnj z = complex_of_real (2 * Re z)"
  by (simp add: complex_eq_iff)

lemma complex_diff_cnj: "z - cnj z = complex_of_real (2 * Im z) * ii"
  by (simp add: complex_eq_iff)

lemma complex_mult_cnj: "z * cnj z = complex_of_real ((Re z)\<^sup>2 + (Im z)\<^sup>2)"
  by (simp add: complex_eq_iff power2_eq_square)

lemma complex_mod_mult_cnj: "cmod (z * cnj z) = (cmod z)\<^sup>2"
  by (simp add: norm_mult power2_eq_square)

lemma complex_mod_sqrt_Re_mult_cnj: "cmod z = sqrt (Re (z * cnj z))"
  by (simp add: norm_complex_def power2_eq_square)

lemma complex_In_mult_cnj_zero [simp]: "Im (z * cnj z) = 0"
  by simp

lemma bounded_linear_cnj: "bounded_linear cnj"
  using complex_cnj_add complex_cnj_scaleR
  by (rule bounded_linear_intro [where K=1], simp)

lemmas tendsto_cnj [tendsto_intros] = bounded_linear.tendsto [OF bounded_linear_cnj]
lemmas isCont_cnj [simp] = bounded_linear.isCont [OF bounded_linear_cnj]
lemmas continuous_cnj [simp, continuous_intros] = bounded_linear.continuous [OF bounded_linear_cnj]
lemmas continuous_on_cnj [simp, continuous_intros] = bounded_linear.continuous_on [OF bounded_linear_cnj]
lemmas has_derivative_cnj [simp, derivative_intros] = bounded_linear.has_derivative [OF bounded_linear_cnj]

lemma lim_cnj: "((\<lambda>x. cnj(f x)) ---> cnj l) F \<longleftrightarrow> (f ---> l) F"
  by (simp add: tendsto_iff dist_complex_def complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma sums_cnj: "((\<lambda>x. cnj(f x)) sums cnj l) \<longleftrightarrow> (f sums l)"
  by (simp add: sums_def lim_cnj cnj_setsum [symmetric] del: cnj_setsum)

subsection{*Basic Lemmas*}

lemma complex_eq_0: "z=0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 = 0"
  by (metis zero_complex.sel complex_eqI sum_power2_eq_zero_iff)

lemma complex_neq_0: "z\<noteq>0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 > 0"
  by (metis complex_eq_0 less_numeral_extra(3) sum_power2_gt_zero_iff)

lemma complex_norm_square: "of_real ((norm z)\<^sup>2) = z * cnj z"
by (cases z)
   (auto simp: complex_eq_iff norm_complex_def power2_eq_square[symmetric] of_real_power[symmetric]
         simp del: of_real_power)

lemma re_complex_div_eq_0: "Re (a / b) = 0 \<longleftrightarrow> Re (a * cnj b) = 0"
  by (auto simp add: Re_divide)

lemma im_complex_div_eq_0: "Im (a / b) = 0 \<longleftrightarrow> Im (a * cnj b) = 0"
  by (auto simp add: Im_divide)

lemma complex_div_gt_0:
  "(Re (a / b) > 0 \<longleftrightarrow> Re (a * cnj b) > 0) \<and> (Im (a / b) > 0 \<longleftrightarrow> Im (a * cnj b) > 0)"
proof cases
  assume "b = 0" then show ?thesis by auto
next
  assume "b \<noteq> 0"
  then have "0 < (Re b)\<^sup>2 + (Im b)\<^sup>2"
    by (simp add: complex_eq_iff sum_power2_gt_zero_iff)
  then show ?thesis
    by (simp add: Re_divide Im_divide zero_less_divide_iff)
qed

lemma re_complex_div_gt_0: "Re (a / b) > 0 \<longleftrightarrow> Re (a * cnj b) > 0"
  and im_complex_div_gt_0: "Im (a / b) > 0 \<longleftrightarrow> Im (a * cnj b) > 0"
  using complex_div_gt_0 by auto

lemma re_complex_div_ge_0: "Re(a / b) \<ge> 0 \<longleftrightarrow> Re(a * cnj b) \<ge> 0"
  by (metis le_less re_complex_div_eq_0 re_complex_div_gt_0)

lemma im_complex_div_ge_0: "Im(a / b) \<ge> 0 \<longleftrightarrow> Im(a * cnj b) \<ge> 0"
  by (metis im_complex_div_eq_0 im_complex_div_gt_0 le_less)

lemma re_complex_div_lt_0: "Re(a / b) < 0 \<longleftrightarrow> Re(a * cnj b) < 0"
  by (metis less_asym neq_iff re_complex_div_eq_0 re_complex_div_gt_0)

lemma im_complex_div_lt_0: "Im(a / b) < 0 \<longleftrightarrow> Im(a * cnj b) < 0"
  by (metis im_complex_div_eq_0 im_complex_div_gt_0 less_asym neq_iff)

lemma re_complex_div_le_0: "Re(a / b) \<le> 0 \<longleftrightarrow> Re(a * cnj b) \<le> 0"
  by (metis not_le re_complex_div_gt_0)

lemma im_complex_div_le_0: "Im(a / b) \<le> 0 \<longleftrightarrow> Im(a * cnj b) \<le> 0"
  by (metis im_complex_div_gt_0 not_le)

lemma Re_setsum[simp]: "Re (setsum f s) = (\<Sum>x\<in>s. Re (f x))"
  by (induct s rule: infinite_finite_induct) auto

lemma Im_setsum[simp]: "Im (setsum f s) = (\<Sum>x\<in>s. Im(f x))"
  by (induct s rule: infinite_finite_induct) auto

lemma sums_complex_iff: "f sums x \<longleftrightarrow> ((\<lambda>x. Re (f x)) sums Re x) \<and> ((\<lambda>x. Im (f x)) sums Im x)"
  unfolding sums_def tendsto_complex_iff Im_setsum Re_setsum ..

lemma summable_complex_iff: "summable f \<longleftrightarrow> summable (\<lambda>x. Re (f x)) \<and>  summable (\<lambda>x. Im (f x))"
  unfolding summable_def sums_complex_iff[abs_def] by (metis complex.sel)

lemma summable_complex_of_real [simp]: "summable (\<lambda>n. complex_of_real (f n)) \<longleftrightarrow> summable f"
  unfolding summable_complex_iff by simp

lemma summable_Re: "summable f \<Longrightarrow> summable (\<lambda>x. Re (f x))"
  unfolding summable_complex_iff by blast

lemma summable_Im: "summable f \<Longrightarrow> summable (\<lambda>x. Im (f x))"
  unfolding summable_complex_iff by blast

lemma complex_is_Real_iff: "z \<in> \<real> \<longleftrightarrow> Im z = 0"
  by (auto simp: Reals_def complex_eq_iff)

lemma Reals_cnj_iff: "z \<in> \<real> \<longleftrightarrow> cnj z = z"
  by (auto simp: complex_is_Real_iff complex_eq_iff)

lemma in_Reals_norm: "z \<in> \<real> \<Longrightarrow> norm(z) = abs(Re z)"
  by (simp add: complex_is_Real_iff norm_complex_def)

lemma series_comparison_complex:
  fixes f:: "nat \<Rightarrow> 'a::banach"
  assumes sg: "summable g"
     and "\<And>n. g n \<in> \<real>" "\<And>n. Re (g n) \<ge> 0"
     and fg: "\<And>n. n \<ge> N \<Longrightarrow> norm(f n) \<le> norm(g n)"
  shows "summable f"
proof -
  have g: "\<And>n. cmod (g n) = Re (g n)" using assms
    by (metis abs_of_nonneg in_Reals_norm)
  show ?thesis
    apply (rule summable_comparison_test' [where g = "\<lambda>n. norm (g n)" and N=N])
    using sg
    apply (auto simp: summable_def)
    apply (rule_tac x="Re s" in exI)
    apply (auto simp: g sums_Re)
    apply (metis fg g)
    done
qed

subsection{*Finally! Polar Form for Complex Numbers*}

subsubsection {* $\cos \theta + i \sin \theta$ *}

primcorec cis :: "real \<Rightarrow> complex" where
  "Re (cis a) = cos a"
| "Im (cis a) = sin a"

lemma cis_zero [simp]: "cis 0 = 1"
  by (simp add: complex_eq_iff)

lemma norm_cis [simp]: "norm (cis a) = 1"
  by (simp add: norm_complex_def)

lemma sgn_cis [simp]: "sgn (cis a) = cis a"
  by (simp add: sgn_div_norm)

lemma cis_neq_zero [simp]: "cis a \<noteq> 0"
  by (metis norm_cis norm_zero zero_neq_one)

lemma cis_mult: "cis a * cis b = cis (a + b)"
  by (simp add: complex_eq_iff cos_add sin_add)

lemma DeMoivre: "(cis a) ^ n = cis (real n * a)"
  by (induct n, simp_all add: real_of_nat_Suc algebra_simps cis_mult)

lemma cis_inverse [simp]: "inverse(cis a) = cis (-a)"
  by (simp add: complex_eq_iff)

lemma cis_divide: "cis a / cis b = cis (a - b)"
  by (simp add: divide_complex_def cis_mult)

lemma cos_n_Re_cis_pow_n: "cos (real n * a) = Re(cis a ^ n)"
  by (auto simp add: DeMoivre)

lemma sin_n_Im_cis_pow_n: "sin (real n * a) = Im(cis a ^ n)"
  by (auto simp add: DeMoivre)

lemma cis_pi: "cis pi = -1"
  by (simp add: complex_eq_iff)

subsubsection {* $r(\cos \theta + i \sin \theta)$ *}

definition rcis :: "real \<Rightarrow> real \<Rightarrow> complex" where
  "rcis r a = complex_of_real r * cis a"

lemma Re_rcis [simp]: "Re(rcis r a) = r * cos a"
  by (simp add: rcis_def)

lemma Im_rcis [simp]: "Im(rcis r a) = r * sin a"
  by (simp add: rcis_def)

lemma rcis_Ex: "\<exists>r a. z = rcis r a"
  by (simp add: complex_eq_iff polar_Ex)

lemma complex_mod_rcis [simp]: "cmod(rcis r a) = abs r"
  by (simp add: rcis_def norm_mult)

lemma cis_rcis_eq: "cis a = rcis 1 a"
  by (simp add: rcis_def)

lemma rcis_mult: "rcis r1 a * rcis r2 b = rcis (r1*r2) (a + b)"
  by (simp add: rcis_def cis_mult)

lemma rcis_zero_mod [simp]: "rcis 0 a = 0"
  by (simp add: rcis_def)

lemma rcis_zero_arg [simp]: "rcis r 0 = complex_of_real r"
  by (simp add: rcis_def)

lemma rcis_eq_zero_iff [simp]: "rcis r a = 0 \<longleftrightarrow> r = 0"
  by (simp add: rcis_def)

lemma DeMoivre2: "(rcis r a) ^ n = rcis (r ^ n) (real n * a)"
  by (simp add: rcis_def power_mult_distrib DeMoivre)

lemma rcis_inverse: "inverse(rcis r a) = rcis (1/r) (-a)"
  by (simp add: divide_inverse rcis_def)

lemma rcis_divide: "rcis r1 a / rcis r2 b = rcis (r1/r2) (a - b)"
  by (simp add: rcis_def cis_divide [symmetric])

subsubsection {* Complex exponential *}

abbreviation expi :: "complex \<Rightarrow> complex"
  where "expi \<equiv> exp"

lemma cis_conv_exp: "cis b = exp (\<i> * b)"
proof -
  { fix n :: nat
    have "\<i> ^ n = fact n *\<^sub>R (cos_coeff n + \<i> * sin_coeff n)"
      by (induct n)
         (simp_all add: sin_coeff_Suc cos_coeff_Suc complex_eq_iff Re_divide Im_divide field_simps
                        power2_eq_square real_of_nat_Suc add_nonneg_eq_0_iff
                        real_of_nat_def[symmetric])
    then have "(\<i> * complex_of_real b) ^ n /\<^sub>R fact n =
        of_real (cos_coeff n * b^n) + \<i> * of_real (sin_coeff n * b^n)"
      by (simp add: field_simps) }
  then show ?thesis
    by (auto simp add: cis.ctr exp_def simp del: of_real_mult
             intro!: sums_unique sums_add sums_mult sums_of_real sin_converges cos_converges)
qed

lemma expi_def: "expi z = exp (Re z) * cis (Im z)"
  unfolding cis_conv_exp exp_of_real [symmetric] mult_exp_exp by (cases z) simp

lemma Re_exp: "Re (exp z) = exp (Re z) * cos (Im z)"
  unfolding expi_def by simp

lemma Im_exp: "Im (exp z) = exp (Re z) * sin (Im z)"
  unfolding expi_def by simp

lemma complex_expi_Ex: "\<exists>a r. z = complex_of_real r * expi a"
apply (insert rcis_Ex [of z])
apply (auto simp add: expi_def rcis_def mult.assoc [symmetric])
apply (rule_tac x = "ii * complex_of_real a" in exI, auto)
done

lemma expi_two_pi_i [simp]: "expi((2::complex) * complex_of_real pi * ii) = 1"
  by (simp add: expi_def complex_eq_iff)

subsubsection {* Complex argument *}

definition arg :: "complex \<Rightarrow> real" where
  "arg z = (if z = 0 then 0 else (SOME a. sgn z = cis a \<and> -pi < a \<and> a \<le> pi))"

lemma arg_zero: "arg 0 = 0"
  by (simp add: arg_def)

lemma arg_unique:
  assumes "sgn z = cis x" and "-pi < x" and "x \<le> pi"
  shows "arg z = x"
proof -
  from assms have "z \<noteq> 0" by auto
  have "(SOME a. sgn z = cis a \<and> -pi < a \<and> a \<le> pi) = x"
  proof
    fix a def d \<equiv> "a - x"
    assume a: "sgn z = cis a \<and> - pi < a \<and> a \<le> pi"
    from a assms have "- (2*pi) < d \<and> d < 2*pi"
      unfolding d_def by simp
    moreover from a assms have "cos a = cos x" and "sin a = sin x"
      by (simp_all add: complex_eq_iff)
    hence cos: "cos d = 1" unfolding d_def cos_diff by simp
    moreover from cos have "sin d = 0" by (rule cos_one_sin_zero)
    ultimately have "d = 0"
      unfolding sin_zero_iff
      by (auto elim!: evenE dest!: less_2_cases)
    thus "a = x" unfolding d_def by simp
  qed (simp add: assms del: Re_sgn Im_sgn)
  with `z \<noteq> 0` show "arg z = x"
    unfolding arg_def by simp
qed

lemma arg_correct:
  assumes "z \<noteq> 0" shows "sgn z = cis (arg z) \<and> -pi < arg z \<and> arg z \<le> pi"
proof (simp add: arg_def assms, rule someI_ex)
  obtain r a where z: "z = rcis r a" using rcis_Ex by fast
  with assms have "r \<noteq> 0" by auto
  def b \<equiv> "if 0 < r then a else a + pi"
  have b: "sgn z = cis b"
    unfolding z b_def rcis_def using `r \<noteq> 0`
    by (simp add: of_real_def sgn_scaleR sgn_if complex_eq_iff)
  have cis_2pi_nat: "\<And>n. cis (2 * pi * real_of_nat n) = 1"
    by (induct_tac n) (simp_all add: distrib_left cis_mult [symmetric] complex_eq_iff)
  have cis_2pi_int: "\<And>x. cis (2 * pi * real_of_int x) = 1"
    by (case_tac x rule: int_diff_cases)
       (simp add: right_diff_distrib cis_divide [symmetric] cis_2pi_nat)
  def c \<equiv> "b - 2*pi * of_int \<lceil>(b - pi) / (2*pi)\<rceil>"
  have "sgn z = cis c"
    unfolding b c_def
    by (simp add: cis_divide [symmetric] cis_2pi_int)
  moreover have "- pi < c \<and> c \<le> pi"
    using ceiling_correct [of "(b - pi) / (2*pi)"]
    by (simp add: c_def less_divide_eq divide_le_eq algebra_simps)
  ultimately show "\<exists>a. sgn z = cis a \<and> -pi < a \<and> a \<le> pi" by fast
qed

lemma arg_bounded: "- pi < arg z \<and> arg z \<le> pi"
  by (cases "z = 0") (simp_all add: arg_zero arg_correct)

lemma cis_arg: "z \<noteq> 0 \<Longrightarrow> cis (arg z) = sgn z"
  by (simp add: arg_correct)

lemma rcis_cmod_arg: "rcis (cmod z) (arg z) = z"
  by (cases "z = 0") (simp_all add: rcis_def cis_arg sgn_div_norm of_real_def)

lemma cos_arg_i_mult_zero [simp]: "y \<noteq> 0 \<Longrightarrow> Re y = 0 \<Longrightarrow> cos (arg y) = 0"
  using cis_arg [of y] by (simp add: complex_eq_iff)

subsection {* Square root of complex numbers *}

primcorec csqrt :: "complex \<Rightarrow> complex" where
  "Re (csqrt z) = sqrt ((cmod z + Re z) / 2)"
| "Im (csqrt z) = (if Im z = 0 then 1 else sgn (Im z)) * sqrt ((cmod z - Re z) / 2)"

lemma csqrt_of_real_nonneg [simp]: "Im x = 0 \<Longrightarrow> Re x \<ge> 0 \<Longrightarrow> csqrt x = sqrt (Re x)"
  by (simp add: complex_eq_iff norm_complex_def)

lemma csqrt_of_real_nonpos [simp]: "Im x = 0 \<Longrightarrow> Re x \<le> 0 \<Longrightarrow> csqrt x = \<i> * sqrt \<bar>Re x\<bar>"
  by (simp add: complex_eq_iff norm_complex_def)

lemma csqrt_0 [simp]: "csqrt 0 = 0"
  by simp

lemma csqrt_1 [simp]: "csqrt 1 = 1"
  by simp

lemma csqrt_ii [simp]: "csqrt \<i> = (1 + \<i>) / sqrt 2"
  by (simp add: complex_eq_iff Re_divide Im_divide real_sqrt_divide real_div_sqrt)

lemma power2_csqrt[algebra]: "(csqrt z)\<^sup>2 = z"
proof cases
  assume "Im z = 0" then show ?thesis
    using real_sqrt_pow2[of "Re z"] real_sqrt_pow2[of "- Re z"]
    by (cases "0::real" "Re z" rule: linorder_cases)
       (simp_all add: complex_eq_iff Re_power2 Im_power2 power2_eq_square cmod_eq_Re)
next
  assume "Im z \<noteq> 0"
  moreover
  have "cmod z * cmod z - Re z * Re z = Im z * Im z"
    by (simp add: norm_complex_def power2_eq_square)
  moreover
  have "\<bar>Re z\<bar> \<le> cmod z"
    by (simp add: norm_complex_def)
  ultimately show ?thesis
    by (simp add: Re_power2 Im_power2 complex_eq_iff real_sgn_eq
                  field_simps real_sqrt_mult[symmetric] real_sqrt_divide)
qed

lemma csqrt_eq_0 [simp]: "csqrt z = 0 \<longleftrightarrow> z = 0"
  by auto (metis power2_csqrt power_eq_0_iff)

lemma csqrt_eq_1 [simp]: "csqrt z = 1 \<longleftrightarrow> z = 1"
  by auto (metis power2_csqrt power2_eq_1_iff)

lemma csqrt_principal: "0 < Re (csqrt z) \<or> Re (csqrt z) = 0 \<and> 0 \<le> Im (csqrt z)"
  by (auto simp add: not_less cmod_plus_Re_le_0_iff Im_eq_0)

lemma Re_csqrt: "0 \<le> Re (csqrt z)"
  by (metis csqrt_principal le_less)

lemma csqrt_square:
  assumes "0 < Re b \<or> (Re b = 0 \<and> 0 \<le> Im b)"
  shows "csqrt (b^2) = b"
proof -
  have "csqrt (b^2) = b \<or> csqrt (b^2) = - b"
    unfolding power2_eq_iff[symmetric] by (simp add: power2_csqrt)
  moreover have "csqrt (b^2) \<noteq> -b \<or> b = 0"
    using csqrt_principal[of "b ^ 2"] assms by (intro disjCI notI) (auto simp: complex_eq_iff)
  ultimately show ?thesis
    by auto
qed

lemma csqrt_minus [simp]:
  assumes "Im x < 0 \<or> (Im x = 0 \<and> 0 \<le> Re x)"
  shows "csqrt (- x) = \<i> * csqrt x"
proof -
  have "csqrt ((\<i> * csqrt x)^2) = \<i> * csqrt x"
  proof (rule csqrt_square)
    have "Im (csqrt x) \<le> 0"
      using assms by (auto simp add: cmod_eq_Re mult_le_0_iff field_simps complex_Re_le_cmod)
    then show "0 < Re (\<i> * csqrt x) \<or> Re (\<i> * csqrt x) = 0 \<and> 0 \<le> Im (\<i> * csqrt x)"
      by (auto simp add: Re_csqrt simp del: csqrt.simps)
  qed
  also have "(\<i> * csqrt x)^2 = - x"
    by (simp add: power2_csqrt power_mult_distrib)
  finally show ?thesis .
qed

text {* Legacy theorem names *}

lemmas expand_complex_eq = complex_eq_iff
lemmas complex_Re_Im_cancel_iff = complex_eq_iff
lemmas complex_equality = complex_eqI
lemmas cmod_def = norm_complex_def
lemmas complex_norm_def = norm_complex_def
lemmas complex_divide_def = divide_complex_def

lemma legacy_Complex_simps:
  shows Complex_eq_0: "Complex a b = 0 \<longleftrightarrow> a = 0 \<and> b = 0"
    and complex_add: "Complex a b + Complex c d = Complex (a + c) (b + d)"
    and complex_minus: "- (Complex a b) = Complex (- a) (- b)"
    and complex_diff: "Complex a b - Complex c d = Complex (a - c) (b - d)"
    and Complex_eq_1: "Complex a b = 1 \<longleftrightarrow> a = 1 \<and> b = 0"
    and Complex_eq_neg_1: "Complex a b = - 1 \<longleftrightarrow> a = - 1 \<and> b = 0"
    and complex_mult: "Complex a b * Complex c d = Complex (a * c - b * d) (a * d + b * c)"
    and complex_inverse: "inverse (Complex a b) = Complex (a / (a\<^sup>2 + b\<^sup>2)) (- b / (a\<^sup>2 + b\<^sup>2))"
    and Complex_eq_numeral: "Complex a b = numeral w \<longleftrightarrow> a = numeral w \<and> b = 0"
    and Complex_eq_neg_numeral: "Complex a b = - numeral w \<longleftrightarrow> a = - numeral w \<and> b = 0"
    and complex_scaleR: "scaleR r (Complex a b) = Complex (r * a) (r * b)"
    and Complex_eq_i: "(Complex x y = ii) = (x = 0 \<and> y = 1)"
    and i_mult_Complex: "ii * Complex a b = Complex (- b) a"
    and Complex_mult_i: "Complex a b * ii = Complex (- b) a"
    and i_complex_of_real: "ii * complex_of_real r = Complex 0 r"
    and complex_of_real_i: "complex_of_real r * ii = Complex 0 r"
    and Complex_add_complex_of_real: "Complex x y + complex_of_real r = Complex (x+r) y"
    and complex_of_real_add_Complex: "complex_of_real r + Complex x y = Complex (r+x) y"
    and Complex_mult_complex_of_real: "Complex x y * complex_of_real r = Complex (x*r) (y*r)"
    and complex_of_real_mult_Complex: "complex_of_real r * Complex x y = Complex (r*x) (r*y)"
    and complex_eq_cancel_iff2: "(Complex x y = complex_of_real xa) = (x = xa & y = 0)"
    and complex_cn: "cnj (Complex a b) = Complex a (- b)"
    and Complex_setsum': "setsum (%x. Complex (f x) 0) s = Complex (setsum f s) 0"
    and Complex_setsum: "Complex (setsum f s) 0 = setsum (%x. Complex (f x) 0) s"
    and complex_of_real_def: "complex_of_real r = Complex r 0"
    and complex_norm: "cmod (Complex x y) = sqrt (x\<^sup>2 + y\<^sup>2)"
  by (simp_all add: norm_complex_def field_simps complex_eq_iff Re_divide Im_divide del: Complex_eq)

lemma Complex_in_Reals: "Complex x 0 \<in> \<real>"
  by (metis Reals_of_real complex_of_real_def)

end


(*  Title:      HOL/HOLCF/Porder.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section \<open>Partial orders\<close>

theory Porder
imports Main
begin

declare [[typedef_overloaded]]

subsection \<open>Type class for partial orders\<close>

class below =
  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation (ASCII)
  below (infix "<<" 50)

notation
  below (infix "\<sqsubseteq>" 50)

abbreviation
  not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<notsqsubseteq>" 50)
  where "not_below x y \<equiv> \<not> below x y"

notation (ASCII)
  not_below  (infix "~<<" 50)

lemma below_eq_trans: "\<lbrakk>a \<sqsubseteq> b; b = c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  by (rule subst)

lemma eq_below_trans: "\<lbrakk>a = b; b \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> c"
  by (rule ssubst)

end

class po = below +
  assumes below_refl [iff]: "x \<sqsubseteq> x"
  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
begin

lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
  by simp

lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
  by (rule below_trans [OF below_trans])

lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  by (fast intro!: below_antisym)

lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
  by (rule below_trans)

lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
  by auto

end

lemmas HOLCF_trans_rules [trans] =
  below_trans
  below_antisym
  below_eq_trans
  eq_below_trans

context po
begin

subsection \<open>Upper bounds\<close>

definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55) where
  "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"

lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
  by (simp add: is_ub_def)

lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  by (simp add: is_ub_def)

lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
  unfolding is_ub_def by fast

lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
  unfolding is_ub_def by fast

lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
  unfolding is_ub_def by fast

lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
  unfolding is_ub_def by fast

lemma is_ub_empty [simp]: "{} <| u"
  unfolding is_ub_def by fast

lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
  unfolding is_ub_def by fast

lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
  unfolding is_ub_def by (fast intro: below_trans)

subsection \<open>Least upper bounds\<close>

definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55) where
  "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"

definition lub :: "'a set \<Rightarrow> 'a" where
  "lub S = (THE x. S <<| x)"

end

syntax (ASCII)
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)

syntax
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)

translations
  "LUB x:A. t" == "CONST lub ((%x. t) ` A)"

context po
begin

abbreviation
  Lub  (binder "\<Squnion>" 10) where
  "\<Squnion>n. t n == lub (range t)"

notation (ASCII)
  Lub  (binder "LUB " 10)

text \<open>access to some definition as inference rule\<close>

lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
  unfolding is_lub_def by fast

lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  unfolding is_lub_def by fast

lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
  unfolding is_lub_def by fast

lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
  unfolding is_lub_def is_ub_def by (metis below_trans)

text \<open>lubs are unique\<close>

lemma is_lub_unique: "\<lbrakk>S <<| x; S <<| y\<rbrakk> \<Longrightarrow> x = y"
  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)

text \<open>technical lemmas about @{term lub} and @{term is_lub}\<close>

lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
  unfolding lub_def by (rule theI [OF _ is_lub_unique])

lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
  by (rule is_lub_unique [OF is_lub_lub])

lemma is_lub_singleton: "{x} <<| x"
  by (simp add: is_lub_def)

lemma lub_singleton [simp]: "lub {x} = x"
  by (rule is_lub_singleton [THEN lub_eqI])

lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
  by (simp add: is_lub_def)

lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
  by (rule is_lub_bin [THEN lub_eqI])

lemma is_lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> S <<| x"
  by (erule is_lubI, erule (1) is_ubD)

lemma lub_maximal: "\<lbrakk>S <| x; x \<in> S\<rbrakk> \<Longrightarrow> lub S = x"
  by (rule is_lub_maximal [THEN lub_eqI])

subsection \<open>Countable chains\<close>

definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  \<comment> \<open>Here we use countable chains and I prefer to code them as functions!\<close>
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"

lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
  unfolding chain_def by fast

lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
  unfolding chain_def by fast

text \<open>chains are monotone functions\<close>

lemma chain_mono_less: "\<lbrakk>chain Y; i < j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (erule less_Suc_induct, erule chainE, erule below_trans)

lemma chain_mono: "\<lbrakk>chain Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (cases "i = j", simp, simp add: chain_mono_less)

lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
  by (rule chainI, simp, erule chainE)

text \<open>technical lemmas about (least) upper bounds of chains\<close>

lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
  by (rule is_lubD1 [THEN ub_rangeD])

lemma is_ub_range_shift:
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
apply (rule iffI)
apply (rule ub_rangeI)
apply (rule_tac y="S (i + j)" in below_trans)
apply (erule chain_mono)
apply (rule le_add1)
apply (erule ub_rangeD)
apply (rule ub_rangeI)
apply (erule ub_rangeD)
done

lemma is_lub_range_shift:
  "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
  by (simp add: is_lub_def is_ub_range_shift)

text \<open>the lub of a constant chain is the constant\<close>

lemma chain_const [simp]: "chain (\<lambda>i. c)"
  by (simp add: chainI)

lemma is_lub_const: "range (\<lambda>x. c) <<| c"
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)

lemma lub_const [simp]: "(\<Squnion>i. c) = c"
  by (rule is_lub_const [THEN lub_eqI])

subsection \<open>Finite chains\<close>

definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  \<comment> \<open>finite chains, needed for monotony of continuous functions\<close>
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"

definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
  "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"

text \<open>results about finite chains\<close>

lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
  unfolding max_in_chain_def by fast

lemma max_in_chainD: "\<lbrakk>max_in_chain i Y; i \<le> j\<rbrakk> \<Longrightarrow> Y i = Y j"
  unfolding max_in_chain_def by fast

lemma finite_chainI:
  "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> finite_chain C"
  unfolding finite_chain_def by fast

lemma finite_chainE:
  "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding finite_chain_def by fast

lemma lub_finch1: "\<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> range C <<| C i"
apply (rule is_lubI)
apply (rule ub_rangeI, rename_tac j)
apply (rule_tac x=i and y=j in linorder_le_cases)
apply (drule (1) max_in_chainD, simp)
apply (erule (1) chain_mono)
apply (erule ub_rangeD)
done

lemma lub_finch2:
  "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
apply (erule finite_chainE)
apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
apply (erule (1) lub_finch1)
done

lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
 apply (erule finite_chainE)
 apply (rule_tac B="Y ` {..i}" in finite_subset)
  apply (rule subsetI)
  apply (erule rangeE, rename_tac j)
  apply (rule_tac x=i and y=j in linorder_le_cases)
   apply (subgoal_tac "Y j = Y i", simp)
   apply (simp add: max_in_chain_def)
  apply simp
 apply simp
done

lemma finite_range_has_max:
  fixes f :: "nat \<Rightarrow> 'a" and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
  assumes finite_range: "finite (range f)"
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
proof (intro exI allI)
  fix i :: nat
  let ?j = "LEAST k. f k = f i"
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
  have "?j \<le> ?k"
  proof (rule Max_ge)
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
      using finite_range by (rule finite_imageI)
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
      by (intro imageI rangeI)
  qed
  hence "r (f ?j) (f ?k)"
    by (rule mono)
  also have "f ?j = f i"
    by (rule LeastI, rule refl)
  finally show "r (f i) (f ?k)" .
qed

lemma finite_range_imp_finch:
  "\<lbrakk>chain Y; finite (range Y)\<rbrakk> \<Longrightarrow> finite_chain Y"
 apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
  apply (erule exE)
  apply (rule finite_chainI, assumption)
  apply (rule max_in_chainI)
  apply (rule below_antisym)
   apply (erule (1) chain_mono)
  apply (erule spec)
 apply (rule finite_range_has_max)
  apply (erule (1) chain_mono)
 apply assumption
done

lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
  by (rule chainI, simp)

lemma bin_chainmax:
  "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
  unfolding max_in_chain_def by simp

lemma is_lub_bin_chain:
  "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
apply (frule bin_chain)
apply (drule bin_chainmax)
apply (drule (1) lub_finch1)
apply simp
done

text \<open>the maximal element in a chain is its lub\<close>

lemma lub_chain_maxelem: "\<lbrakk>Y i = c; \<forall>i. Y i \<sqsubseteq> c\<rbrakk> \<Longrightarrow> lub (range Y) = c"
  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)

end

end