(*
  File: OrderRel.thy
  Author: Bohua Zhan

  Basics of order relation.
*)

theory OrderRel
  imports Morphism
begin

section \<open>Transitive relations\<close>

definition trans :: "i \<Rightarrow> o" where [rewrite]:
  "trans(R) \<longleftrightarrow> (
    raworder(R) \<and>
    (\<forall>x y z. x \<le>\<^sub>R y \<longrightarrow> y \<le>\<^sub>R z \<longrightarrow> x \<le>\<^sub>R z))"

lemma transD [forward]:
  "trans(R) \<Longrightarrow> raworder(R)"
  "trans(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> y \<le>\<^sub>R z \<Longrightarrow> x \<le>\<^sub>R z" by auto2+
setup {* del_prfstep_thm_eqforward @{thm trans_def} *}

section \<open>Preorder and order relations\<close>  (* Bourbaki III.1.1 -- III.1.2 *)

definition refl_order :: "i \<Rightarrow> o" where [rewrite]:
  "refl_order(R) \<longleftrightarrow> raworder(R) \<and> (\<forall>x\<in>.R. x \<le>\<^sub>R x)"

lemma refl_orderD [forward]:
  "refl_order(R) \<Longrightarrow> raworder(R)" by auto2

lemma refl_orderD2 [backward]:
  "refl_order(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> x \<le>\<^sub>R x" by auto2
setup {* del_prfstep_thm_eqforward @{thm refl_order_def} *}

definition preorder :: "i \<Rightarrow> o" where [rewrite]:
  "preorder(R) \<longleftrightarrow> trans(R) \<and> refl_order(R)"

lemma preorderD [forward]:
  "preorder(R) \<Longrightarrow> trans(R)"
  "preorder(R) \<Longrightarrow> refl_order(R)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm preorder_def} *}

definition order :: "i \<Rightarrow> o" where [rewrite]:
  "order(R) \<longleftrightarrow> (preorder(R) \<and> (\<forall>x y. x \<le>\<^sub>R y \<longrightarrow> y \<le>\<^sub>R x \<longrightarrow> x = y))"

lemma orderD [forward]:
  "order(R) \<Longrightarrow> preorder(R)"
  "order(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> y \<le>\<^sub>R x \<Longrightarrow> x = y" by auto2+
setup {* del_prfstep_thm_eqforward @{thm order_def} *}

(* Small exercise: opposite order *)
definition opp_order :: "i \<Rightarrow> i" where [rewrite]:
  "opp_order(R) = Order(carrier(R), \<lambda>x y. y \<le>\<^sub>R x)"
lemma inv_is_order: "order(R) \<Longrightarrow> order(opp_order(R))" by auto2

(* Subset ordering. *)
definition subset_order :: "i \<Rightarrow> i" where [rewrite]:
  "subset_order(S) = Order(S, \<lambda>x y. x \<subseteq> y)"

lemma subset_order_type [typing]: "subset_order(S) \<in> raworder_space(S)" by auto2
lemma subset_order_is_order [forward]: "order(subset_order(S))" by auto2

lemma subset_order_eval [rewrite]:
  "R = subset_order(S) \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> (x \<in>. R \<and> y \<in>. R \<and> x \<subseteq> y)" by auto2
setup {* del_prfstep_thm @{thm subset_order_def} *}

section \<open>Notations for order relations\<close>  (* Bourbaki III.1.3 *)

definition less :: "[i, i, i] \<Rightarrow> o" where [rewrite]:
  "less(R,x,y) \<longleftrightarrow> (x \<le>\<^sub>R y \<and> x \<noteq> y)"
abbreviation less_notation ("(_/ <\<^sub>_ _)" [51,51,51] 50) where "x <\<^sub>R y \<equiv> less(R,x,y)"
setup {* register_wellform_data ("x <\<^sub>R y", ["x \<in>. R", "y \<in>. R"]) *}

abbreviation (input) greater :: "[i, i, i] \<Rightarrow> o" ("(_/ >\<^sub>_ _)" [51,51,51] 50) where
  "x >\<^sub>R y \<equiv> y <\<^sub>R x"

syntax
  "_Bex_gt" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<exists>_ >\<^sub>_ _./ _)" 10)
  "_Bex_ge" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<exists>_ \<ge>\<^sub>_ _./ _)" 10)
  "_Ball_gt" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<forall>_ >\<^sub>_ _./ _)" 10)
  "_Ball_ge" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<forall>_ \<ge>\<^sub>_ _./ _)" 10)
translations
  "\<exists>x >\<^sub>R a. P" => "\<exists>x. x >\<^sub>R a \<and> P"
  "\<exists>x \<ge>\<^sub>R a. P" => "\<exists>x. x \<ge>\<^sub>R a \<and> P"
  "\<forall>x >\<^sub>R a. P" => "\<forall>x. x >\<^sub>R a \<longrightarrow> P"
  "\<forall>x \<ge>\<^sub>R a. P" => "\<forall>x. x \<ge>\<^sub>R a \<longrightarrow> P"

syntax
  "_Bex_lt" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<exists>_ <\<^sub>_ _./ _)" 10)
  "_Bex_le" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<exists>_ \<le>\<^sub>_ _./ _)" 10)
  "_Ball_lt" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<forall>_ <\<^sub>_ _./ _)" 10)
  "_Ball_le" :: "[pttrn, i, i, o] \<Rightarrow> o"  ("(3\<forall>_ \<le>\<^sub>_ _./ _)" 10)
translations
  "\<exists>x <\<^sub>R a. P" => "\<exists>x. x <\<^sub>R a \<and> P"
  "\<exists>x \<le>\<^sub>R a. P" => "\<exists>x. x \<le>\<^sub>R a \<and> P"
  "\<forall>x <\<^sub>R a. P" => "\<forall>x. x <\<^sub>R a \<longrightarrow> P"
  "\<forall>x \<le>\<^sub>R a. P" => "\<forall>x. x \<le>\<^sub>R a \<longrightarrow> P"

(* Other versions of transitivity *)
lemma order_trans [forward]:
  "order(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> y \<le>\<^sub>R z \<Longrightarrow> x <\<^sub>R z"
  "order(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> y <\<^sub>R z \<Longrightarrow> x <\<^sub>R z" by auto2+

lemma preorder_lessI [forward, backward1, backward2]:
  "raworder(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> x \<noteq> y \<Longrightarrow> x <\<^sub>R y" by auto2

lemma order_lessE [forward]: "raworder(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> x \<le>\<^sub>R y" by auto2
lemma order_less_to_neg [forward]: "order(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> \<not>y \<le>\<^sub>R x" by auto2
lemma order_le_to_neg [forward]: "order(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> \<not>y <\<^sub>R x" by auto2
lemma preorder_less_neq [resolve]: "raworder(R) \<Longrightarrow> \<not>x <\<^sub>R x" by auto2

lemma less_eq_str [rewrite]: "eq_str_order(X,Y) \<Longrightarrow> a <\<^sub>X b \<longleftrightarrow> a <\<^sub>Y b" by auto2

setup {* del_prfstep_thm @{thm less_def} *}

section \<open>Isomorphism between orders\<close>

definition is_ord_mor :: "i \<Rightarrow> o" where [rewrite]:
  "is_ord_mor(f) \<longleftrightarrow> is_morphism(f) \<and> preorder(source_str(f)) \<and> preorder(target_str(f))"

definition ord_isomorphism :: "i \<Rightarrow> o" where [rewrite]:
  "ord_isomorphism(f) \<longleftrightarrow> (let R = source_str(f) in let S = target_str(f) in
                       is_ord_mor(f) \<and> bijective(f) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. f`x \<le>\<^sub>S f`y \<longleftrightarrow> x \<le>\<^sub>R y))"

lemma ord_isomorphismD1 [forward]:
  "ord_isomorphism(f) \<Longrightarrow> is_ord_mor(f)"
  "ord_isomorphism(f) \<Longrightarrow> bijective(f)" by auto2+

lemma ord_isomorphismD2 [rewrite]:
  "ord_isomorphism(f) \<Longrightarrow> R = source_str(f) \<Longrightarrow> S = target_str(f) \<Longrightarrow>
   x \<in> source(f) \<Longrightarrow> y \<in> source(f) \<Longrightarrow> f`x \<le>\<^sub>S f`y \<longleftrightarrow> x \<le>\<^sub>R y" by auto2
setup {* del_prfstep_thm_eqforward @{thm ord_isomorphism_def} *}

definition ord_iso_space :: "i \<Rightarrow> i \<Rightarrow> i"  (infix "\<cong>\<^sub>O" 60) where [rewrite]:
  "ord_iso_space(R,S) = {f \<in> mor_space(R,S). ord_isomorphism(f)}"

lemma ord_iso_spaceD [forward]:
  "f \<in> R \<cong>\<^sub>O S \<Longrightarrow> f \<in> R \<rightharpoonup> S \<and> ord_isomorphism(f)" by auto2

lemma ord_iso_spaceI [typing, backward]:
  "mor_form(f) \<Longrightarrow> ord_isomorphism(f) \<Longrightarrow> f \<in> source_str(f) \<cong>\<^sub>O target_str(f)" by auto2
setup {* del_prfstep_thm @{thm ord_iso_space_def} *}

definition ord_isomorphic :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "ord_isomorphic(R,S) \<longleftrightarrow> (\<exists>f. f \<in> R \<cong>\<^sub>O S)"

lemma ord_isomorphicI [forward]: "f \<in> R \<cong>\<^sub>O S \<Longrightarrow> ord_isomorphic(R,S)" by auto2
lemma ord_isomorphicD [resolve]: "ord_isomorphic(R,S) \<Longrightarrow> \<exists>f. f \<in> R \<cong>\<^sub>O S" by auto2

lemma preorder_iso [forward]: "preorder(R) \<Longrightarrow> ord_isomorphic(R,S) \<Longrightarrow> preorder(S)" by auto2
lemma order_iso [forward]: "order(R) \<Longrightarrow> ord_isomorphic(R,S) \<Longrightarrow> order(S)"
@proof
  @obtain f where "f \<in> R \<cong>\<^sub>O S"
  @have "\<forall>x y. x \<le>\<^sub>S y \<longrightarrow> y \<le>\<^sub>S x \<longrightarrow> x = y" @with
    @obtain "x'\<in>.R" where "f`x' = x"
    @obtain "y'\<in>.R" where "f`y' = y"
  @end
@qed
setup {* del_prfstep_thm @{thm ord_isomorphic_def} *}

section \<open>Ordering on subsets and products\<close>  (* Bourbaki III.1.4 *)

(* Define relation on subsets in general *)
definition suborder :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "suborder(R,A) = Order(A, \<lambda>x y. x \<le>\<^sub>R y)"
setup {* register_wellform_data ("suborder(R,A)", ["A \<subseteq> carrier(R)"]) *}
setup {* add_prfstep_check_req ("suborder(R,A)", "A \<subseteq> carrier(R)") *}

lemma suborder_type [typing]: "suborder(R,A) \<in> raworder_space(A)" by auto2

lemma suborder_is_preorder:
  "preorder(R) \<Longrightarrow> A \<subseteq> carrier(R) \<Longrightarrow> preorder(suborder(R,A))" by auto2
setup {* add_forward_prfstep_cond @{thm suborder_is_preorder} [with_term "suborder(?R,?A)"] *}

lemma suborder_is_order:
  "order(R) \<Longrightarrow> A \<subseteq> carrier(R) \<Longrightarrow> order(suborder(R,A))" by auto2
setup {* add_forward_prfstep_cond @{thm suborder_is_order} [with_term "suborder(?R,?A)"] *}

lemma suborder_eval [rewrite]:
  "S = suborder(R,A) \<Longrightarrow> x \<le>\<^sub>S y \<longleftrightarrow> (x \<in>. S \<and> y \<in>. S \<and> x \<le>\<^sub>R y)" by auto2

lemma suborder_less_eval [rewrite]:
  "preorder(R) \<Longrightarrow> A \<subseteq> carrier(R) \<Longrightarrow> S = suborder(R,A) \<Longrightarrow> x <\<^sub>S y \<longleftrightarrow> (x \<in>. S \<and> y \<in>. S \<and> x <\<^sub>R y)"
@proof @case "x = y" @qed
setup {* del_prfstep_thm @{thm suborder_def} *}

lemma subset_order_suborder [rewrite]:
  "F \<subseteq> carrier(subset_order(E)) \<Longrightarrow> suborder(subset_order(E),F) = subset_order(F)" by auto2

definition mor_restrict_image_ord :: "i \<Rightarrow> i"  where [rewrite]:
  "mor_restrict_image_ord(f) = Mor(source_str(f),suborder(target_str(f),image(f)),\<lambda>x. f`x)"

lemma mor_restrict_ord_is_morphism [typing]:
  "is_morphism(f) \<Longrightarrow> mor_restrict_image_ord(f) \<in> source_str(f) \<rightharpoonup> suborder(target_str(f),image(f))" by auto2

lemma mor_restrict_ord_eval [rewrite]:
  "is_morphism(f) \<Longrightarrow> f' = mor_restrict_image_ord(f) \<Longrightarrow> x \<in> source(f') \<Longrightarrow> f' ` x = f ` x" by auto2
setup {* del_prfstep_thm @{thm mor_restrict_image_ord_def} *}

(* Define relation on products in general. *)
definition prod_src :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "prod_src(I,R) = Pi(I,\<lambda>a. carrier(R`a))"

definition prod_rel :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "prod_rel(I,R) = Order(prod_src(I,R), \<lambda>x y. \<forall>a\<in>I. le(R`a,x`a,y`a))"

lemma prod_rel_type [typing]:
  "prod_rel(I,R) \<in> raworder_space(prod_src(I,R))" by auto2

lemma prod_rel_is_preorder:
  "\<forall>a\<in>I. preorder(R`a) \<Longrightarrow> preorder(prod_rel(I,R))" by auto2
setup {* add_forward_prfstep_cond @{thm prod_rel_is_preorder} [with_term "prod_rel(?I,?R)"] *}

lemma prod_rel_is_order:
  "\<forall>a\<in>I. order(R`a) \<Longrightarrow> order(prod_rel(I,R))" by auto2
setup {* add_forward_prfstep_cond @{thm prod_rel_is_order} [with_term "prod_rel(?I,?R)"] *}

lemma prod_rel_eval [rewrite]:
  "S = prod_rel(I,R) \<Longrightarrow> x \<in>. S \<Longrightarrow> y \<in>. S \<Longrightarrow> x \<le>\<^sub>S y \<longleftrightarrow> (\<forall>a\<in>I. le(R`a,x`a,y`a))" by auto2
setup {* del_prfstep_thm @{thm prod_rel_def} *}

section \<open>Increasing mappings\<close>  (* Bourbaki III.1.5 *)

definition incr :: "i \<Rightarrow> o" where [rewrite]:
  "incr(f) \<longleftrightarrow> (let R = source_str(f) in let S = target_str(f) in
                is_ord_mor(f) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<longrightarrow> f`x \<le>\<^sub>S f`y))"

definition decr :: "i \<Rightarrow> o" where [rewrite]:
  "decr(f) \<longleftrightarrow> (let R = source_str(f) in let S = target_str(f) in
                is_ord_mor(f) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<longrightarrow> f`x \<ge>\<^sub>S f`y))"

definition strict_incr :: "i \<Rightarrow> o" where [rewrite]:
  "strict_incr(f) \<longleftrightarrow> (let R = source_str(f) in let S = target_str(f) in
                       is_ord_mor(f) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x <\<^sub>R y \<longrightarrow> f`x <\<^sub>S f`y))"

definition strict_decr :: "i \<Rightarrow> o" where [rewrite]:
  "strict_decr(f) \<longleftrightarrow> (let R = source_str(f) in let S = target_str(f) in
                       is_ord_mor(f) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x <\<^sub>R y \<longrightarrow> f`x >\<^sub>S f`y))"

(* Examples *)
lemma subset_order_less [rewrite]:
  "R = subset_order(E) \<Longrightarrow> X \<in>. R \<Longrightarrow> Y \<in>. R \<Longrightarrow> X <\<^sub>R Y \<longleftrightarrow> X \<subset> Y" by auto2

lemma compl_strict_decr:
  "R = subset_order(Pow(E)) \<Longrightarrow> strict_decr(Mor(R,R,\<lambda>X. E \<midarrow> X))" by auto2

lemma greater_elts_strict_subset [backward]:
  "order(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> {z\<in>.R. z \<ge>\<^sub>R y} \<subset> {z\<in>.R. z \<ge>\<^sub>R x}"
@proof @have "x\<in>{z\<in>.R. z \<ge>\<^sub>R x}" @qed

lemma greater_elts_strict_decr:
  "order(R) \<Longrightarrow> strict_decr(Mor(R,subset_order(Pow(carrier(R))), \<lambda>x. {y\<in>.R. y \<ge>\<^sub>R x}))" by auto2

lemma inj_to_strict_incr: "incr(f) \<Longrightarrow> injective(f) \<Longrightarrow> strict_incr(f)" by auto2
lemma inj_to_strict_decr: "decr(f) \<Longrightarrow> injective(f) \<Longrightarrow> strict_decr(f)" by auto2

lemma restrict_image_incr [forward]:
  "incr(f) \<Longrightarrow> incr(mor_restrict_image_ord(f))" by auto2

(* Proposition 2 in III.1.5 *)
lemma two_decr_funs_prop:
  "decr(u) \<Longrightarrow> decr(v) \<Longrightarrow> mor_form(u) \<Longrightarrow> mor_form(v) \<Longrightarrow> u \<in> R \<rightharpoonup> S \<Longrightarrow> v \<in> S \<rightharpoonup> R \<Longrightarrow>
   \<forall>x\<in>.R. v`(u`x) = x \<Longrightarrow> \<forall>x\<in>.S. u`(v`x) = x \<Longrightarrow> u \<circ>\<^sub>m v \<circ>\<^sub>m u = u \<and> v \<circ>\<^sub>m u \<circ>\<^sub>m v = v" by auto2

section \<open>Maximal and minimal elements\<close>  (* Bourbaki III.1.6 *)

definition maximal :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "maximal(R,x) \<longleftrightarrow> (x \<in>. R \<and> (\<forall>a\<in>.R. a \<ge>\<^sub>R x \<longrightarrow> a = x))"

definition minimal :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "minimal(R,x) \<longleftrightarrow> (x \<in>. R \<and> (\<forall>a\<in>.R. a \<le>\<^sub>R x \<longrightarrow> a = x))"

(* Examples *)
lemma singleton_minimal:
  "x \<in> S \<Longrightarrow> minimal(subset_order(Pow(S)\<midarrow>{\<emptyset>}),{x})" by auto2

section \<open>Greatest and least elements\<close>  (* Bourbaki III.1.7 *)

(* We define the more general notion of greatest/least element of a subset, to
   prepare for definition of sup and inf later. *)
definition has_greatest :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "has_greatest(R,X) \<longleftrightarrow> (\<exists>x\<in>X. \<forall>a\<in>X. a \<le>\<^sub>R x)"

definition greatest :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "greatest(R,X) = (THE x. x \<in> X \<and> (\<forall>a\<in>X. a \<le>\<^sub>R x))"

(* We always prove has_greatest(R,X) and assign greatest(R,X) at the same time.
   Similarly for least, sup, and inf below *)
lemma greatestI [backward]:
  "order(R) \<Longrightarrow> x \<in> X \<Longrightarrow> \<forall>a\<in>X. a \<le>\<^sub>R x \<Longrightarrow> has_greatest(R,X) \<and> greatest(R,X) = x" by auto2

lemma greatestE:
  "order(R) \<Longrightarrow> has_greatest(R,X) \<Longrightarrow> greatest(R,X) \<in> X"
  "order(R) \<Longrightarrow> a \<in> X \<Longrightarrow> has_greatest(R,X) \<Longrightarrow> a \<le>\<^sub>R greatest(R,X)" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "greatest(?R,?X)"]) @{thms greatestE} *}
setup {* fold del_prfstep_thm [@{thm has_greatest_def}, @{thm greatest_def}] *}

definition has_least :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "has_least(R,X) \<longleftrightarrow> (\<exists>x\<in>X. \<forall>a\<in>X. x \<le>\<^sub>R a)"

definition least :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "least(R,X) = (THE x. x \<in> X \<and> (\<forall>a\<in>X. x \<le>\<^sub>R a))"

lemma leastI [backward]:
  "order(R) \<Longrightarrow> x \<in> X \<Longrightarrow> \<forall>a\<in>X. a \<ge>\<^sub>R x \<Longrightarrow> has_least(R,X) \<and> least(R,X) = x" by auto2

lemma leastE:
  "order(R) \<Longrightarrow> has_least(R,X) \<Longrightarrow> least(R,X) \<in> X"
  "order(R) \<Longrightarrow> a \<in> X \<Longrightarrow> has_least(R,X) \<Longrightarrow> least(R,X) \<le>\<^sub>R a" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "least(?R,?X)"]) @{thms leastE} *}
setup {* fold del_prfstep_thm [@{thm has_least_def}, @{thm least_def}] *}

(* Relation to maximal / minimal *)
lemma greatest_maximal:
  "order(R) \<Longrightarrow> has_greatest(R,X) \<Longrightarrow> maximal(suborder(R,X),greatest(R,X))" by auto2

lemma greatest_maximal_unique:
  "order(R) \<Longrightarrow> has_greatest(R,X) \<Longrightarrow> x \<in> X \<Longrightarrow> maximal(suborder(R,X),x) \<Longrightarrow> greatest(R,X) = x" by auto2

lemma least_minimal:
  "order(R) \<Longrightarrow> has_least(R,X) \<Longrightarrow> minimal(suborder(R,X),least(R,X))" by auto2

lemma least_minimal_unique:
  "order(R) \<Longrightarrow> has_least(R,X) \<Longrightarrow> x \<in> X \<Longrightarrow> minimal(suborder(R,X),x) \<Longrightarrow> least(R,X) = x" by auto2

(* Examples *)
lemma greatest_subset_is_union:
  "has_greatest(subset_order(S),S) \<Longrightarrow> greatest(subset_order(S),S) = \<Union>S" by auto2

lemma greatest_subset_is_union2:
  "\<Union>S \<in> S \<Longrightarrow> has_greatest(subset_order(S),S) \<and> greatest(subset_order(S),S) = \<Union>S" by auto2

lemma least_subset_is_inter:
  "has_least(subset_order(S),S) \<Longrightarrow> least(subset_order(S),S) = \<Inter>S" by auto2

lemma least_subset_is_inter2:
  "\<Inter>S \<in> S \<Longrightarrow> has_least(subset_order(S),S) \<and> least(subset_order(S),S) = \<Inter>S" by auto2

lemma empty_subset_least:
  "least(subset_order(Pow(E)),Pow(E)) = \<emptyset> \<and> has_least(subset_order(Pow(E)),Pow(E))" by auto2

lemma full_subset_greatest:
  "greatest(subset_order(Pow(E)),Pow(E)) = E \<and> has_greatest(subset_order(Pow(E)),Pow(E))" by auto2

lemma has_least_suborder [backward2]:
  "order(R) \<Longrightarrow> X \<subseteq> carrier(R) \<Longrightarrow> has_least(R,A) \<Longrightarrow> A \<subseteq> X \<Longrightarrow>
   has_least(suborder(R,X),A) \<and> least(suborder(R,X),A) = least(R,A)" by auto2
setup {* add_backward2_prfstep (conj_left_th @{thm has_least_suborder}) *}

lemma has_least_suborder_inv [backward2]:
  "order(R) \<Longrightarrow> X \<subseteq> carrier(R) \<Longrightarrow> has_least(suborder(R,X),A) \<Longrightarrow> A \<subseteq> X \<Longrightarrow>
   has_least(R,A) \<and> least(R,A) = least(suborder(R,X),A)" by auto2
setup {* add_backward2_prfstep (conj_left_th @{thm has_least_suborder_inv}) *}

lemma has_least_singleton [backward2]:
  "order(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> has_least(R,{a}) \<and> least(R,{a}) = a" by auto2
setup {* add_backward2_prfstep (conj_left_th @{thm has_least_singleton}) *}

lemma has_least_sub_singleton [backward2]:
  "order(R) \<Longrightarrow> has_least(R,X\<midarrow>{a}) \<Longrightarrow> \<forall>x\<in>X. x \<le>\<^sub>R a \<Longrightarrow>
   has_least(R,X) \<and> least(R,X) = least(R,X\<midarrow>{a})"
@proof @case "a \<in> X" @with @have "X = (X \<midarrow> {a}) \<union> {a}" @end @qed
setup {* add_backward2_prfstep (conj_left_th @{thm has_least_sub_singleton}) *}

(* Cofinal and coinitial subsets *)
definition cofinal :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "cofinal(R,A) \<longleftrightarrow> (A \<subseteq> carrier(R) \<and> (\<forall>x\<in>.R. \<exists>y\<in>A. x \<le>\<^sub>R y))"

lemma cofinalE1 [forward]: "cofinal(R,A) \<Longrightarrow> A \<subseteq> carrier(R)" by auto2
lemma cofinalE2 [backward2]: "cofinal(R,A) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>y\<in>A. x \<le>\<^sub>R y" by auto2
setup {* del_prfstep_thm_eqforward @{thm cofinal_def} *}

definition coinitial :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "coinitial(R,A) \<longleftrightarrow> (A \<subseteq> carrier(R) \<and> (\<forall>x\<in>.R. \<exists>y\<in>A. y \<le>\<^sub>R x))"

lemma coinitialE1 [forward]: "coinitial(R,A) \<Longrightarrow> A \<subseteq> carrier(R)" by auto2
lemma coinitialE2 [backward2]: "coinitial(R,A) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>y\<in>A. y \<le>\<^sub>R x" by auto2
setup {* del_prfstep_thm_eqforward @{thm coinitial_def} *}

lemma greatest_is_cofinal:
  "order(R) \<Longrightarrow> has_greatest(R,carrier(R)) \<Longrightarrow> cofinal(R,{greatest(R,carrier(R))})" by auto2

lemma least_is_coinitial:
  "order(R) \<Longrightarrow> has_least(R,carrier(R)) \<Longrightarrow> coinitial(R,{least(R,carrier(R))})" by auto2

section \<open>Upper and lower bounds\<close>  (* Bourbaki III.1.8 *)

definition upper_bound :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "upper_bound(R,X) = {y\<in>.R. \<forall>x\<in>X. x \<le>\<^sub>R y}"

lemma upper_boundD1 [forward]: "y \<in> upper_bound(R,X) \<Longrightarrow> y \<in>. R" by auto2
lemma upper_boundD2 [forward, backward2]:  "y \<in> upper_bound(R,X) \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le>\<^sub>R y" by auto2
lemma upper_boundI [backward]: "y \<in>. R \<Longrightarrow> \<forall>x\<in>X. x \<le>\<^sub>R y \<Longrightarrow> y \<in> upper_bound(R,X)" by auto2
lemma upper_bound_eq_str [rewrite]: "eq_str_order(R,S) \<Longrightarrow> upper_bound(R,T) = upper_bound(S,T)" by auto2
setup {* del_prfstep_thm @{thm upper_bound_def} *}

definition lower_bound :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "lower_bound(R,X) = {y\<in>.R. \<forall>x\<in>X. y \<le>\<^sub>R x}"

lemma lower_boundD1 [forward]: "y \<in> lower_bound(R,X) \<Longrightarrow> y \<in>. R" by auto2
lemma lower_boundD2 [forward, backward2]:  "y \<in> lower_bound(R,X) \<Longrightarrow> x \<in> X \<Longrightarrow> x \<ge>\<^sub>R y" by auto2
lemma lower_boundI [backward]: "y \<in>. R \<Longrightarrow> \<forall>x\<in>X. x \<ge>\<^sub>R y \<Longrightarrow> y \<in> lower_bound(R,X)" by auto2
setup {* del_prfstep_thm @{thm lower_bound_def} *}

lemma upper_bound_trans [forward]:
  "order(R) \<Longrightarrow> x \<in> upper_bound(R,X) \<Longrightarrow> y \<ge>\<^sub>R x \<Longrightarrow> y \<in> upper_bound(R,X)" by auto2

lemma upper_bound_trans_subset [backward]:
  "X \<subseteq> Y \<Longrightarrow> upper_bound(R,Y) \<subseteq> upper_bound(R,X)" by auto2

lemma upper_bound_greatest:
  "order(R) \<Longrightarrow> has_greatest(R,carrier(R)) \<Longrightarrow> upper_bound(R,carrier(R)) = {greatest(R,carrier(R))}" by auto2

lemma upper_bound_greatest':
  "order(R) \<Longrightarrow> upper_bound(R,carrier(R)) = {a} \<Longrightarrow> greatest(R,carrier(R)) = a \<and> has_greatest(R,carrier(R))" by auto2

lemma lower_bound_trans [forward]:
  "order(R) \<Longrightarrow> x \<in> lower_bound(R,X) \<Longrightarrow> y \<le>\<^sub>R x \<Longrightarrow> y \<in> lower_bound(R,X)" by auto2

lemma lower_bound_trans_subset [backward]:
  "X \<subseteq> Y \<Longrightarrow> lower_bound(R,Y) \<subseteq> lower_bound(R,X)" by auto2

lemma lower_bound_least:
  "order(R) \<Longrightarrow> has_least(R,carrier(R)) \<Longrightarrow> lower_bound(R,carrier(R)) = {least(R,carrier(R))}" by auto2

lemma lower_bound_least':
  "order(R) \<Longrightarrow> lower_bound(R,carrier(R)) = {a} \<Longrightarrow> least(R,carrier(R)) = a \<and> has_least(R,carrier(R))" by auto2

section \<open>Supremum and infimum\<close>  (* Bourbaki III.1.9 *)

(* Definitions of sup and inf *)
definition has_sup :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "has_sup(R,X) \<longleftrightarrow> has_least(R,upper_bound(R,X))"

definition sup :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "sup(R,X) = least(R,upper_bound(R,X))"

definition has_inf :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "has_inf(R,X) \<longleftrightarrow> has_greatest(R,lower_bound(R,X))"

definition inf :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "inf(R,X) = greatest(R,lower_bound(R,X))"

lemma supI [backward]:
  "order(R) \<Longrightarrow> has_least(R,upper_bound(R,X)) \<and> least(R,upper_bound(R,X)) = x \<Longrightarrow>
   has_sup(R,X) \<and> sup(R,X) = x" by auto2

lemma infI [backward]:
  "order(R) \<Longrightarrow> has_greatest(R,lower_bound(R,X)) \<and> greatest(R,lower_bound(R,X)) = x \<Longrightarrow>
   has_inf(R,X) \<and> inf(R,X) = x" by auto2

(* Sup and inf for the image of a mapping *)
definition has_supf :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "has_supf(R,f) \<longleftrightarrow> has_sup(R,image(f))"

definition supf :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "supf(R,f) = sup(R,image(f))"

lemma has_supfI [backward]:
  "order(R) \<Longrightarrow> has_least(R,upper_bound(R,image(f))) \<and> least(R,upper_bound(R,image(f))) = x \<Longrightarrow>
   has_supf(R,f) \<and> supf(R,f) = x" by auto2

(* Examples *)
lemma greatest_elt_is_sup:
  "order(R) \<Longrightarrow> has_greatest(R,X) \<Longrightarrow> sup(R,X) = greatest(R,X) \<and> has_sup(R,X)" by auto2

lemma least_elt_is_inf:
  "order(R) \<Longrightarrow> has_least(R,X) \<Longrightarrow> inf(R,X) = least(R,X) \<and> has_inf(R,X)" by auto2

lemma sup_of_empty:
  "order(R) \<Longrightarrow> has_least(R,carrier(R)) \<Longrightarrow> sup(R,\<emptyset>) = least(R,carrier(R)) \<and> has_sup(R,\<emptyset>)" by auto2

lemma inf_of_empty:
  "order(R) \<Longrightarrow> has_greatest(R,carrier(R)) \<Longrightarrow> inf(R,\<emptyset>) = greatest(R,carrier(R)) \<and> has_inf(R,\<emptyset>)" by auto2

lemma sup_of_subsets:
  "X \<subseteq> Pow(E) \<Longrightarrow> has_sup(subset_order(Pow(E)),X) \<and> sup(subset_order(Pow(E)),X) = \<Union>X" by auto2

lemma inf_of_subsets:
  "X \<noteq> \<emptyset> \<Longrightarrow> X \<subseteq> Pow(E) \<Longrightarrow> has_inf(subset_order(Pow(E)),X) \<and> inf(subset_order(Pow(E)),X) = \<Inter>X" by auto2

lemma inf_le_sup:
  "order(R) \<Longrightarrow> has_sup(R,X) \<Longrightarrow> has_inf(R,X) \<Longrightarrow> X \<noteq> \<emptyset> \<Longrightarrow> inf(R,X) \<le>\<^sub>R sup(R,X)" by auto2

(* For harder results, we use two lemmas *)
lemma sup_mem [typing]: "order(R) \<Longrightarrow> has_sup(R,X) \<Longrightarrow> sup(R,X) \<in>. R" by auto2

lemma sup_le [backward2]:
  "order(R) \<Longrightarrow> has_sup(R,X) \<Longrightarrow> a \<in>. R \<Longrightarrow> \<forall>x\<in>X. x \<le>\<^sub>R a \<Longrightarrow> sup(R,X) \<le>\<^sub>R a"
@proof @have "a \<in> upper_bound(R,X)" @qed

lemma sup_on_subset_le:
  "order(R) \<Longrightarrow> has_sup(R,A) \<Longrightarrow> has_sup(R,B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> sup(R,A) \<le>\<^sub>R sup(R,B)" by auto2

lemma sup_trans:
  "order(R) \<Longrightarrow> f \<in> I \<rightarrow> carrier(R) \<Longrightarrow> g \<in> I \<rightarrow> carrier(R) \<Longrightarrow> \<forall>a\<in>I. f`a \<le>\<^sub>R g`a \<Longrightarrow>
   has_supf(R,f) \<Longrightarrow> has_supf(R,g) \<Longrightarrow> supf(R,f) \<le>\<^sub>R supf(R,g)" by auto2

lemma sup_subset1:
  "order(R) \<Longrightarrow> F \<subseteq> carrier(R) \<Longrightarrow> A \<subseteq> F \<Longrightarrow> has_sup(R,A) \<Longrightarrow> has_sup(suborder(R,F),A) \<Longrightarrow>
   sup(R,A) \<le>\<^sub>R sup(suborder(R,F),A)" by auto2

lemma sup_subset2:
  "order(R) \<Longrightarrow> F \<subseteq> carrier(R) \<Longrightarrow> A \<subseteq> F \<Longrightarrow> has_sup(R,A) \<Longrightarrow> sup(R,A) \<in> F \<Longrightarrow>
   has_sup(suborder(R,F),A) \<and> sup(suborder(R,F),A) = sup(R,A)" by auto2

section \<open>Directed sets\<close>  (* Bourbaki III.1.10 *)

definition right_directed :: "i \<Rightarrow> o" where [rewrite]:
  "right_directed(R) \<longleftrightarrow> order(R) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. \<exists>z\<in>.R. z \<ge>\<^sub>R x \<and> z \<ge>\<^sub>R y)"

lemma right_directedE1 [forward]: "right_directed(R) \<Longrightarrow> order(R)" by auto2
lemma right_directedE2 [backward]: "right_directed(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> \<exists>z\<in>.R. z \<ge>\<^sub>R x \<and> z \<ge>\<^sub>R y" by auto2
setup {* del_prfstep_thm_eqforward @{thm right_directed_def} *}

lemma right_directed_max_is_greatest:
  "right_directed(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> maximal(R,a) \<Longrightarrow> has_greatest(R,carrier(R)) \<and> greatest(R,carrier(R)) = a"
@proof
  @have "\<forall>b\<in>.R. b \<le>\<^sub>R a" @with @obtain "z\<in>.R" where "z \<ge>\<^sub>R a \<and> z \<ge>\<^sub>R b" @end
@qed

lemma right_directed_prod:
  "\<forall>a\<in>I. right_directed(R`a) \<Longrightarrow> S = prod_rel(I,R) \<Longrightarrow> right_directed(S)"
@proof
  @let "E = prod_src(I,R)"
  @have "\<forall>x\<in>E. \<forall>y\<in>E. \<exists>z\<in>E. z \<ge>\<^sub>S x \<and> z \<ge>\<^sub>S y" @with
    @let "z = Tup(I, \<lambda>a. SOME w\<in>.R`a. le(R`a,x`a,w) \<and> le(R`a,y`a,w))"
    @have "z \<in> E" @have "z \<ge>\<^sub>S x"
  @end
@qed

lemma right_directed_cofinal:
  "right_directed(R) \<Longrightarrow> cofinal(R,A) \<Longrightarrow> right_directed(suborder(R,A))"
@proof
  @let "S = suborder(R,A)"
  @have "\<forall>x\<in>A. \<forall>y\<in>A. \<exists>z\<in>A. z \<ge>\<^sub>S x \<and> z \<ge>\<^sub>S y" @with
    @obtain "z'\<in>.R" where "z' \<ge>\<^sub>R x \<and> z' \<ge>\<^sub>R y" @obtain "z\<in>A" where "z' \<le>\<^sub>R z"
  @end
@qed

section \<open>Totally ordered sets\<close>  (* Bourbaki III.1.12 *)

definition linorder :: "i \<Rightarrow> o" where [rewrite]:
  "linorder(R) \<longleftrightarrow> (order(R) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<or> x \<ge>\<^sub>R y))"

lemma linorderD [forward]:
  "linorder(R) \<Longrightarrow> order(R)"
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> \<not>(x \<le>\<^sub>R y) \<Longrightarrow> x >\<^sub>R y"
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> \<not>(x <\<^sub>R y) \<Longrightarrow> x \<ge>\<^sub>R y" by auto2+
setup {* del_prfstep_thm_eqforward @{thm linorder_def} *}

lemma linorder_iso [forward]:
  "linorder(R) \<Longrightarrow> ord_isomorphic(R,S) \<Longrightarrow> linorder(S)"
@proof
  @obtain "f \<in> R \<cong>\<^sub>O S"
  @have "\<forall>x\<in>.S. \<forall>y\<in>.S. x \<le>\<^sub>S y \<or> x \<ge>\<^sub>S y" @with
    @obtain "x'\<in>.R" where "f`x' = x"
    @obtain "y'\<in>.R" where "f`y' = y"
  @end
@qed

lemma linorder_suborder:
  "linorder(R) \<Longrightarrow> A \<subseteq> carrier(R) \<Longrightarrow> linorder(suborder(R,A))" by auto2
setup {* add_forward_prfstep_cond @{thm linorder_suborder} [with_term "suborder(?R,?A)"] *}

lemma linorder_eq_str [forward]:
  "linorder(R) \<Longrightarrow> eq_str_order(R,S) \<Longrightarrow> linorder(S)" by auto2

lemma strict_monotone_to_inj:
  "is_morphism(f) \<Longrightarrow> R = source_str(f) \<Longrightarrow> linorder(R) \<Longrightarrow> order(target_str(f)) \<Longrightarrow>
   strict_incr(f) \<Longrightarrow> injective(f)"
@proof
  @have "\<forall>x\<in>.R. \<forall>y\<in>.R. x \<noteq> y \<longrightarrow> f`x \<noteq> f`y" @with @case "x \<ge>\<^sub>R y" @end
@qed

lemma incr_to_iso [backward]:
  "is_morphism(f) \<Longrightarrow> R = source_str(f) \<Longrightarrow> S = target_str(f) \<Longrightarrow>
   linorder(R) \<Longrightarrow> order(S) \<Longrightarrow> bijective(f) \<Longrightarrow> incr(f) \<Longrightarrow> ord_isomorphism(f)" by auto2

lemma supI_alt [backward1]:
  "linorder(R) \<Longrightarrow> b \<in> upper_bound(R,X) \<Longrightarrow>
   \<forall>c\<in>.R. c <\<^sub>R b \<longrightarrow> (\<exists>x\<in>X. c <\<^sub>R x \<and> x \<le>\<^sub>R b) \<Longrightarrow> has_sup(R,X) \<and> sup(R,X) = b" by auto2

lemma supD_alt [backward1]:
  "linorder(R) \<Longrightarrow> has_sup(R,X) \<Longrightarrow> c \<in>. R \<Longrightarrow> c <\<^sub>R sup(R,X) \<Longrightarrow>
   \<exists>x\<in>X. c <\<^sub>R x \<and> x \<le>\<^sub>R sup(R,X)" by auto2

section \<open>Maximum\<close>

definition max :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where max_def [rewrite]:
  "max(R,x,y) = (if x \<ge>\<^sub>R y then x else y)"
setup {* register_wellform_data ("max(R,x,y)", ["x \<in>. R", "y \<in>. R"]) *}

lemma max_type [typing]: "x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> max(R,x,y) \<in>. R" by auto2

lemma max_type_gen [backward1, backward2]: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> max(R,a,b) \<in> S" by auto2

lemma max_idem [rewrite]: "x \<in>. R \<Longrightarrow> max(R,x,x) = x" by auto2

lemma max_geD:
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<le>\<^sub>R max(R,x,y)"
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> y \<le>\<^sub>R max(R,x,y)" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "max(?R,?x,?y)"]) @{thms max_geD} *}

lemma max_geI [backward1, backward2]:
  "preorder(R) \<Longrightarrow> x \<ge>\<^sub>R y \<Longrightarrow> x \<ge>\<^sub>R z \<Longrightarrow> x \<ge>\<^sub>R max(R,y,z)" by auto2

lemma max_greaterI [backward1, backward2]:
  "preorder(R) \<Longrightarrow> x >\<^sub>R y \<Longrightarrow> x >\<^sub>R z \<Longrightarrow> x >\<^sub>R max(R,y,z)" by auto2

lemma linorder_has_max3:
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow> \<exists>w. w \<ge>\<^sub>R x \<and> w \<ge>\<^sub>R y \<and> w \<ge>\<^sub>R z"
@proof @let "w = max(R,max(R,x,y),z)" @qed
setup {* add_backward_prfstep_cond @{thm linorder_has_max3} [
  with_filt (order_filter "x" "y"), with_filt (order_filter "y" "z")] *}

section \<open>Minimum\<close>

definition min :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where min_def [rewrite]:
  "min(R,x,y) = (if x \<le>\<^sub>R y then x else y)"
setup {* register_wellform_data ("min(R,x,y)", ["x \<in>. R", "y \<in>. R"]) *}

lemma min_type [typing]: "x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> min(R,x,y) \<in>. R" by auto2

lemma min_type_gen [backward1, backward2]: "a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> min(R,a,b) \<in> S" by auto2

lemma min_idem [rewrite]: "x \<in>. R \<Longrightarrow> min(R,x,x) = x" by auto2

lemma min_leD:
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> x \<ge>\<^sub>R min(R,x,y)"
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> y \<ge>\<^sub>R min(R,x,y)" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "min(?R,?x,?y)"]) @{thms min_leD} *}

lemma min_leI [backward1, backward2]:
  "preorder(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> x \<le>\<^sub>R z \<Longrightarrow> x \<le>\<^sub>R min(R,y,z)" by auto2

lemma min_lessI [backward1, backward2]:
  "preorder(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> x <\<^sub>R z \<Longrightarrow> x <\<^sub>R min(R,y,z)" by auto2

setup {* del_prfstep_thm @{thm min_def} *}

lemma linorder_has_min3:
  "linorder(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> z \<in>. R \<Longrightarrow> \<exists>w. w \<le>\<^sub>R x \<and> w \<le>\<^sub>R y \<and> w \<le>\<^sub>R z"
@proof @let "w = min(R,min(R,x,y),z)" @qed
setup {* add_backward_prfstep_cond @{thm linorder_has_min3} [
  with_filt (order_filter "x" "y"), with_filt (order_filter "y" "z")] *}

(* To show equality between a linorder and an order, can also compare <. *)
lemma eq_linorder_order_less [backward1]:
  "ord_form(R) \<Longrightarrow> ord_form(S) \<Longrightarrow> linorder(R) \<Longrightarrow> order(S) \<Longrightarrow> carrier(R) = carrier(S) \<Longrightarrow>
   \<forall>x\<in>.R. \<forall>y\<in>.R. x <\<^sub>R y \<longrightarrow> x <\<^sub>S y \<Longrightarrow> R = S"
@proof
  @have (@rule) "\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<longrightarrow> x \<le>\<^sub>S y" @with @case "x = y" @end
@qed

section \<open>Directed family of ordering\<close>

(* This development is used in Bourbaki III.2.1 *)
definition is_suborder :: "[i, i] \<Rightarrow> o" where [rewrite]:
  "is_suborder(R,S) \<longleftrightarrow> (raworder(R) \<and> carrier(R) \<subseteq> carrier(S) \<and> (\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<longleftrightarrow> x \<le>\<^sub>S y))"

lemma is_suborderD1 [forward]: "is_suborder(R,S) \<Longrightarrow> raworder(R) \<and> carrier(R) \<subseteq> carrier(S)" by auto2
lemma is_suborderD2 [rewrite]:
  "x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_suborder(R,S) \<Longrightarrow> x \<le>\<^sub>R y \<longleftrightarrow> x \<le>\<^sub>S y" by auto2
lemma is_suborder_rewr [rewrite_back]:
  "ord_form(R) \<Longrightarrow> is_suborder(R,S) \<Longrightarrow> R = suborder(S,carrier(R))" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_suborder_def} *}

lemma is_suborder_refl [resolve]: "preorder(R) \<Longrightarrow> is_suborder(R,R)" by auto2

lemma is_suborder_preorder [forward]: "preorder(R) \<Longrightarrow> is_suborder(A,R) \<Longrightarrow> preorder(A)" by auto2
lemma is_suborder_order [forward]: "order(R) \<Longrightarrow> is_suborder(A,R) \<Longrightarrow> order(A)" by auto2
lemma is_suborder_linorder [forward]: "linorder(R) \<Longrightarrow> is_suborder(A,R) \<Longrightarrow> linorder(A)" by auto2

definition directed_rels :: "i \<Rightarrow> o" where [rewrite]:
  "directed_rels(X) \<longleftrightarrow> ((\<forall>R\<in>X. order(R)) \<and>
    (\<forall>R\<in>X. \<forall>S\<in>X. \<exists>T\<in>X. is_suborder(R,T) \<and> is_suborder(S,T)))"

lemma directed_relsD1 [forward]:
  "directed_rels(X) \<Longrightarrow> R \<in> X \<Longrightarrow> order(R)" by auto2
lemma directed_relsD2 [backward]:
  "directed_rels(X) \<Longrightarrow> R \<in> X \<Longrightarrow> S \<in> X \<Longrightarrow> \<exists>T\<in>X. is_suborder(R,T) \<and> is_suborder(S,T)" by auto2
setup {* del_prfstep_thm_eqforward @{thm directed_rels_def} *}

(* Union of a family of ordering. Has good properties when the family is directed. *)
definition union_src :: "i \<Rightarrow> i" where [rewrite]:
  "union_src(X) = (\<Union>R\<in>X. carrier(R))"

definition union_rel :: "i \<Rightarrow> i" where [rewrite]:
  "union_rel(X) = Order(union_src(X), \<lambda>x y. \<exists>R\<in>X. x \<le>\<^sub>R y)"

lemma union_rel_is_raworder [typing]: "union_rel(X) \<in> raworder_space(union_src(X))" by auto2

lemma union_rel_eval [rewrite]:
  "U = union_rel(X) \<Longrightarrow> x \<in>. U \<Longrightarrow> y \<in>. U \<Longrightarrow> x \<le>\<^sub>U y \<longleftrightarrow> (\<exists>R\<in>X. x \<le>\<^sub>R y)" by auto2
setup {* del_prfstep_thm @{thm union_rel_def} *}

lemma directed_elt_in_rel2:
  "directed_rels(X) \<Longrightarrow> x \<in> union_src(X) \<Longrightarrow> y \<in> union_src(X) \<Longrightarrow> \<exists>R\<in>X. x \<in>. R \<and> y \<in>. R"
@proof
  @obtain "R\<in>X" where "x\<in>.R"
  @obtain "S\<in>X" where "y\<in>.S"
  @obtain "T\<in>X" where "is_suborder(R,T)" "is_suborder(S,T)"
@qed
setup {* add_backward_prfstep_cond @{thm directed_elt_in_rel2} [with_filt (order_filter "x" "y")] *}

lemma directed_elt_in_rel3:
  "directed_rels(X) \<Longrightarrow> x \<in> union_src(X) \<Longrightarrow> y \<in> union_src(X) \<Longrightarrow> z \<in> union_src(X) \<Longrightarrow>
   \<exists>R\<in>X. x \<in>. R \<and> y \<in>. R \<and> z \<in>. R"
@proof
  @obtain "R\<in>X" where "x\<in>.R" "y\<in>.R"
  @obtain "S\<in>X" where "z\<in>.S"
  @obtain "T\<in>X" where "is_suborder(R,T)" "is_suborder(S,T)"
@qed
setup {* add_backward_prfstep_cond @{thm directed_elt_in_rel3} [
  with_filt (order_filter "x" "y"), with_filt (order_filter "y" "z")] *}

lemma union_rel_prop:
  "directed_rels(X) \<Longrightarrow> R \<in> X \<Longrightarrow> U = union_rel(X) \<Longrightarrow> is_suborder(R,U)"
@proof
  @have "\<forall>x\<in>.R. \<forall>y\<in>.R. x \<le>\<^sub>R y \<longleftrightarrow> x \<le>\<^sub>U y" @with
    @case "x \<le>\<^sub>U y" @with
      @obtain "S\<in>X" where "x \<le>\<^sub>S y"
      @obtain "T\<in>X" where "is_suborder(R,T)" "is_suborder(S,T)"
    @end
  @end
@qed
setup {* add_forward_prfstep_cond @{thm union_rel_prop} [with_term "union_rel(?X)"] *}

lemma union_rel_unique_prop:
  "directed_rels(X) \<Longrightarrow> ord_form(R) \<Longrightarrow> order(R) \<Longrightarrow> carrier(R) = union_src(X) \<Longrightarrow>
   \<forall>S\<in>X. is_suborder(S,R) \<Longrightarrow> R = union_rel(X)"
@proof
  @have "\<forall>x\<in>union_src(X). \<forall>y\<in>union_src(X). x \<le>\<^sub>R y \<longleftrightarrow> le(union_rel(X),x,y)" @with
    @obtain "S\<in>X" where "x \<in>. S" "y \<in>. S" @end
@qed

lemma union_rel_preorder [forward]:
  "directed_rels(X) \<Longrightarrow> R = union_rel(X) \<Longrightarrow> preorder(R)"
@proof
  @have "\<forall>x y z. x \<le>\<^sub>R y \<longrightarrow> y \<le>\<^sub>R z \<longrightarrow> x \<le>\<^sub>R z" @with
    @obtain "S\<in>X" where "x \<in>. S" "y \<in>. S" "z \<in>. S"
    @have "x \<le>\<^sub>S y" @have "y \<le>\<^sub>S z"
  @end
@qed

lemma union_rel_order [forward]:
  "directed_rels(X) \<Longrightarrow> R = union_rel(X) \<Longrightarrow> order(R)"
@proof
  @have "\<forall>x\<in>union_src(X). \<forall>y\<in>union_src(X). x \<le>\<^sub>R y \<longrightarrow> y \<le>\<^sub>R x \<longrightarrow> x = y" @with
    @obtain "S\<in>X" where "x \<in>. S" "y \<in>. S" @end
@qed

lemma union_rel_linorder [backward]:
  "directed_rels(X) \<Longrightarrow> \<forall>R\<in>X. linorder(R) \<Longrightarrow> R = union_rel(X) \<Longrightarrow> linorder(R)"
@proof
  @have "\<forall>x\<in>union_src(X). \<forall>y\<in>union_src(X). x \<le>\<^sub>R y \<or> x \<ge>\<^sub>R y" @with
    @obtain "S\<in>X" where "x \<in>. S" "y \<in>. S" @end
@qed

section \<open>Linear continuum\<close>

definition order_unbounded :: "i \<Rightarrow> o" where [rewrite]:
  "order_unbounded(R) \<longleftrightarrow> (\<forall>x\<in>.R. (\<exists>y. y <\<^sub>R x) \<and> (\<exists>y. y >\<^sub>R x))"

lemma order_unboundedD [backward]:
  "order_unbounded(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>y. y <\<^sub>R x"
  "order_unbounded(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>y. y >\<^sub>R x" by auto2+
setup {* del_prfstep_thm_eqforward @{thm order_unbounded_def} *}

definition dense_order :: "i \<Rightarrow> o" where [rewrite]:
  "dense_order(R) \<longleftrightarrow> linorder(R) \<and> (\<forall>x y. x <\<^sub>R y \<longrightarrow> (\<exists>z. x <\<^sub>R z \<and> z <\<^sub>R y))"

lemma dense_orderI [forward]:
  "linorder(R) \<Longrightarrow> \<forall>x y. x <\<^sub>R y \<longrightarrow> (\<exists>z. x <\<^sub>R z \<and> z <\<^sub>R y) \<Longrightarrow> dense_order(R)" by auto2

lemma dense_orderE1 [forward]: "dense_order(R) \<Longrightarrow> linorder(R)" by auto2
lemma dense_orderE2 [backward]: "dense_order(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> \<exists>z. x <\<^sub>R z \<and> z <\<^sub>R y" by auto2
setup {* del_prfstep_thm @{thm dense_order_def} *}

definition linear_continuum :: "i \<Rightarrow> o" where [rewrite]:
  "linear_continuum(R) \<longleftrightarrow> dense_order(R) \<and> (\<forall>S. S \<noteq> \<emptyset> \<longrightarrow> upper_bound(R,S) \<noteq> \<emptyset> \<longrightarrow> has_sup(R,S))"

lemma linear_continuumD [forward]: "linear_continuum(R) \<Longrightarrow> dense_order(R)" by auto2+

lemma linear_continuumD2 [backward]:
  "linear_continuum(R) \<Longrightarrow> S \<noteq> \<emptyset> \<Longrightarrow> upper_bound(R,S) \<noteq> \<emptyset> \<Longrightarrow> has_sup(R,S)" by auto2+

lemma linear_continuumI [forward]:
  "dense_order(R) \<Longrightarrow> \<forall>S. S \<noteq> \<emptyset> \<longrightarrow> upper_bound(R,S) \<noteq> \<emptyset> \<longrightarrow> has_sup(R,S) \<Longrightarrow> linear_continuum(R)" by auto2
setup {* del_prfstep_thm @{thm linear_continuum_def} *}

lemma dense_order_eq_str [forward]:
  "dense_order(R) \<Longrightarrow> eq_str_order(R,S) \<Longrightarrow> dense_order(S)"
@proof
  @have "\<forall>x y. x <\<^sub>S y \<longrightarrow> (\<exists>z. x <\<^sub>S z \<and> z <\<^sub>S y)" @with
    @obtain z where "x <\<^sub>R z \<and> z <\<^sub>R y" @end
@qed

lemma linear_continuum_eq_str_ord [forward]:
  "linear_continuum(R) \<Longrightarrow> eq_str_order(R,S) \<Longrightarrow> linear_continuum(S)"
@proof
  @have "\<forall>T. T \<noteq> \<emptyset> \<longrightarrow> upper_bound(S,T) \<noteq> \<emptyset> \<longrightarrow> has_sup(S,T)" @with
    @have "has_sup(R,T)"
    @have "has_sup(S,T) \<and> sup(S,T) = sup(R,T)"
  @end
@qed

end


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

theory Triple_Systems imports Resolvable_Designs
begin

section \<open>Triple Systems \<close>
text \<open>One of the first ever types of designs studied investigated designs with block size of 3.
Ever since, they have remained an important class of designs

Note: Main definitions only. Lemmas out of scope of initial design theory work \<close>

locale triple_system = block_design \<V> \<B> 3 for point_set ("\<V>") and block_collection ("\<B>")

subsection \<open>Steiner Triple Systems \<close>
text \<open>One of the most studied types of BIBD's \<close>

locale STS = bibd \<V> \<B> 3 1 for point_set ("\<V>") and block_collection ("\<B>")

sublocale STS \<subseteq> triple_system
  by (unfold_locales)

text \<open>Partial Steiner Triple systems are those that don't strictly meet the index
requirement of a bibd \<close>
locale PTS = t_packing_design \<V> \<B> 3 2 1 for point_set ("\<V>") and block_collection ("\<B>")

begin

definition block_leave:: "'a set \<Rightarrow> 'a set multiset" where
"block_leave bl \<equiv> mset_set { ps . ps \<subseteq> \<V> \<and> (card ps = 2) \<and> \<not> ps \<subseteq> bl}"

definition leave :: "'a set multiset" where
"leave \<equiv> \<Sum>bl \<in># \<B>. block_leave bl"

lemma pts_leave_count: "count leave ps = 1 - points_index \<B> ps"
  oops

end

sublocale STS \<subseteq> PTS
  by unfold_locales

subsection \<open>Kirkman Designs \<close>
text \<open> The original triple system is a resolvable STS \<close>

locale KTS = STS \<V> \<B> + rbibd \<V> \<B> \<P> 3 1 for point_set ("\<V>") and block_collection ("\<B>") and partition ("\<P>")
begin

corollary kirkman_condition_on_v: "3 dvd \<v>"
  using resolvable_necessary_cond_v by simp

end

(* Requires a group theoretic proof *)
lemma (in STS) kirkman_condition_on_v_sufficient: "\<v> mod 6 \<equiv> 3 \<Longrightarrow> KTS \<V> \<B> \<P>"
  oops
end


theory Exp
imports Main
begin

fun option_bind :: "'a option \<Rightarrow> ( 'a \<Rightarrow> 'b option ) \<Rightarrow> 'b option" where
  "option_bind None _ = None" |
  "option_bind ( Some a ) f = f a"

definition option_sum :: "int option \<Rightarrow> int option \<Rightarrow> int option" where
  "(option_sum Mx My) = option_bind Mx (\<lambda>x . option_bind My (\<lambda> y . Some (x+y) ))"

definition option_mul :: "int option \<Rightarrow> int option \<Rightarrow> int option" where
  "(option_mul Mx My) = option_bind Mx (\<lambda>x . option_bind My (\<lambda> y . Some (x*y) ))"

lemma [simp]: "option_mul (Some x) (Some y) = Some (x * y)"
  apply ( simp add: option_mul_def )
done

datatype 'a exp =
  Var 'a |
  Cst int |
  Add "'a exp" "'a exp" |
  Mul "'a exp" "'a exp"

fun eval :: "'a exp \<Rightarrow> ('a \<Rightarrow> int option) \<Rightarrow> int option" where
  "eval ( Var i ) v = ( v i )" |
  "eval ( Cst x ) v = Some x" |
  "eval ( Add e0 e1 ) v = option_sum ( eval e0 v ) ( eval e1 v )" |
  "eval ( Mul e0 e1 ) v = option_mul ( eval e0 v ) ( eval e1 v )"

value "( Mult ( Add ( Var 0 ) ( Cst 0 ) ) Cst 3 )"

value "\<lambda> x. ( if x=0 then Some 2 else None )"

value "(eval
        ( Mult ( Add ( Var 0 ) ( Cst 0 ) ) Cst 3 )
        (\<lambda> x. ( if x=0 then Some 3 else None )))"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
  "evalp [] _ = 0" |
  "evalp (c0 # cs) x = c0 + x * ( evalp cs x )"

fun sump :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "sump [] l1 = l1" |
  "sump l0 [] = l0" |
  "sump (x#xs) (y#ys) = (x+y) # ( sump xs ys )"

lemma [simp]: "evalp (sump xs ys ) n = evalp xs n + evalp ys n"
  apply ( induction xs ys rule: sump.induct )
  apply ( auto simp add: algebra_simps)
done

fun cmulp :: "int \<Rightarrow> int list \<Rightarrow> int list" where
  "cmulp c [] = []" |
  "cmulp c (p # ps) = (c*p) # (cmulp c ps)"

lemma [simp]: "evalp ( cmulp c ps ) n = c * evalp ps n"
  apply ( induction ps )
  apply ( auto simp add: algebra_simps )
done

fun mulp :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
  "mulp [] p = []" |
  "mulp (a # as) p = sump (cmulp a p) (0 # (mulp as p))"

lemma [simp]: "evalp ( mulp xs ys ) n = evalp xs n * evalp ys n"
  apply ( induction xs )
  apply ( auto simp add: algebra_simps)
done

fun coeffs :: "unit exp \<Rightarrow> int list" where
  "coeffs (Var ()) = [0, 1]" |
  "coeffs (Cst c ) = [c]" |
  "coeffs (Add e0 e1) = sump (coeffs e0) (coeffs e1)" |
  "coeffs (Mul e0 e1) = mulp (coeffs e0) (coeffs e1)"

theorem "eval e (\<lambda> x . (Some n)) = Some ( evalp ( coeffs e ) n)"
  apply ( induction e arbitrary:n )
  apply ( auto simp add: algebra_simps )
done

end


(*
  File:     Lambert_W_MacLaurin_Series
  Author:   Manuel Eberl, TU München

  The MacLaurin series of the Lambert W function at x = 0
  This file is kept separate from the main Lambert_W file because it requires significantly
  more library material, including HOL-Analysis.
*)
theory Lambert_W_MacLaurin_Series
imports
  "HOL-Computational_Algebra.Formal_Power_Series"
  "Bernoulli.Bernoulli_FPS" (* TODO only for Stirling number identities; should be moved! *)
  "Stirling_Formula.Stirling_Formula"
  Lambert_W
begin

subsection \<open>The MacLaurin series of $W_0(x)$ at $x = 0$\<close>

text \<open>
  In this section, we derive the MacLaurin series of $W_0(x)$ as a formal power series
  at $x = 0$ and prove that its radius of convergenge is $e^{-1}$.

  We do not actually show that this series evaluates to 1 since Isabelle's library does not
  contain the required theorems about convergence of the composition of two power series yet.
  If it did, however, this last remaining step would be trivial since we did all the real work
  here.
\<close>

(* TODO Move *)
lemma Stirling_Suc_n_n: "Stirling (Suc n) n = (Suc n choose 2)"
  by (induction n) (auto simp: choose_two)

lemma Stirling_n_n_minus_1: "n > 0 \<Longrightarrow> Stirling n (n - 1) = (n choose 2)"
  using Stirling_Suc_n_n[of "n - 1"] by (cases n) auto

text \<open>
  The following defines the power series $W(X)$ as the formal inverse of the
  formal power series $X e^X$:
\<close>
definition fps_Lambert_W :: "real fps" where
  "fps_Lambert_W = fps_inv (fps_X * fps_exp 1)"

text \<open>
  The formal composition of $W(X)$ and $X e^X$ is, in fact, the identity (in both directions).
\<close>
lemma fps_compose_Lambert_W: "fps_compose fps_Lambert_W (fps_X * fps_exp 1) = fps_X"
  unfolding fps_Lambert_W_def by (rule fps_inv) auto

lemma fps_compose_Lambert_W': "fps_compose (fps_X * fps_exp 1) fps_Lambert_W  = fps_X"
  unfolding fps_Lambert_W_def by (rule fps_inv_right) auto

text \<open>
  We have $W(0) = 0$, which shows that $W(X)$ indeed represents the branch $W_0$.
\<close>
lemma fps_nth_Lambert_W_0 [simp]: "fps_nth fps_Lambert_W 0 = 0"
  by (simp add: fps_Lambert_W_def fps_inv_def)

lemma fps_nth_Lambert_W_1 [simp]: "fps_nth fps_Lambert_W 1 = 1"
  by (simp add: fps_Lambert_W_def fps_inv_def)

text \<open>
  All the equalities that hold for the analytic Lambert $W$ function in a neighbourhood of 0
  also hold formally for the formal power series, e.g. $W(X) = X e^{-W(X)}$:
\<close>
lemma fps_Lambert_W_over_X:
  "fps_Lambert_W = fps_X * fps_compose (fps_exp (-1)) fps_Lambert_W"
proof -
  have "fps_nth (fps_exp 1 oo fps_Lambert_W) 0 = 1"
    by simp
  hence nz: "fps_exp 1 oo fps_Lambert_W \<noteq> 0"
    by force
  have "fps_Lambert_W * fps_compose (fps_exp 1) fps_Lambert_W =
          fps_compose (fps_X * fps_exp 1) fps_Lambert_W"
    by (simp add: fps_compose_mult_distrib)
  also have "\<dots> = fps_X * fps_compose 1 fps_Lambert_W"
    by (simp add: fps_compose_Lambert_W')
  also have "1 = fps_exp (-1) * fps_exp (1 :: real)"
    by (simp flip: fps_exp_add_mult)
  also have "fps_X * fps_compose \<dots> fps_Lambert_W =
               fps_X * fps_compose (fps_exp (-1)) fps_Lambert_W *
                 fps_compose (fps_exp 1) fps_Lambert_W"
    by (simp add: fps_compose_mult_distrib mult_ac)
  finally show ?thesis
    using nz by simp
qed

text \<open>
  We now derive the closed-form expression
  \[W(X) = \sum_{n=1}^\infty \frac{(-n)^{n-1}}{n!} X^n\ .\]
\<close>
lemma fps_nth_Lambert_W: "fps_nth fps_Lambert_W n = (if n = 0 then 0 else ((-n)^(n-1) / fact n))"
proof -
  define F :: "real fps" where "F = fps_X * fps_exp 1"
  have fps_nth_eq: "fps_nth F n = 1 / fact (n - 1)" if "n > 0" for n
    using that unfolding F_def by simp
  have F_power: "F ^ n = fps_X ^ n * fps_exp (of_nat n)" for n
    by (simp add: F_def power_mult_distrib fps_exp_power_mult)

  have "fps_nth (fps_inv F) n = (if n = 0 then 0 else ((-n)^(n-1) / fact n))" for n
  proof (induction n rule: less_induct)
    case (less n)
    consider "n = 0" | "n = 1" | "n > 1" by force
    thus ?case
    proof cases
      case 3
      hence "fps_nth (fps_inv F) n = -(\<Sum>i=0..n-1. fps_nth (fps_inv F) i * fps_nth (F ^ i) n)"
        (is "_ = -?S") by (cases n) (auto simp: fps_inv_def F_def)
      also have "?S = (\<Sum>i=1..<n. fps_nth (fps_inv F) i * fps_nth (F ^ i) n)"
        using less[of 1] 3 by (intro sum.mono_neutral_right) (auto simp: not_le)
      also have "\<dots> = (-1) ^ (n+1) / fact n *
                        (\<Sum>i=1..<n. ((-1)^(n - i) * real (n choose i) * real i ^ (n - 1)))"
        unfolding sum_divide_distrib sum_distrib_left
      proof (intro sum.cong, goal_cases)
        case (2 i)
        hence "fps_nth (fps_inv F) i * fps_nth (F ^ i) n =
                 (-1) ^ (i - 1) * real (i ^ (i - 1) * i ^ (n - i)) *
                 (fact n / (fact i * fact (n - i)) / fact n)"
          using less.IH[of i] by (simp add: F_power less fps_X_power_mult_nth power_minus')
        also have "(fact n / (fact i * fact (n - i))) = real (n choose i)"
          using 2 by (subst binomial_fact) auto
        also have "i ^ (i - 1) * i ^ (n - i) = i ^ (n - 1)"
          using 2 by (subst power_add [symmetric]) auto
        also have "(-1) ^ (i - 1) = ((-1) ^ (n+1) * (-1)^(n-i) :: real)"
          using 2 by (subst power_add [symmetric]) (auto simp: minus_one_power_iff)
        finally show ?case by simp
      qed auto
      also have "(\<Sum>i=1..<n. ((-1)^(n - i) * real (n choose i) * real i ^ (n - 1))) =
                 (\<Sum>i\<in>{..n}-{n}. ((-1)^(n - i) * real (n choose i) * real i ^ (n - 1)))"
        using 3 by (intro sum.mono_neutral_left) auto
      also have "\<dots> = (\<Sum>i\<le>n. ((-1)^(n - i) * real (n choose i) * real i ^ (n - 1))) -
                      real n ^ (n - 1)"
        by (subst (2) sum.remove[of _ n]) auto
      also have "(\<Sum>i\<le>n. ((-1)^(n - i) * real (n choose i) * real i ^ (n - 1))) =
                   real (Stirling (n - 1) n) * fact n"
        by (subst Stirling_closed_form) auto
      also have "Stirling (n - 1) n = 0"
        using 3 by (subst Stirling_less) auto
      finally have "fps_nth (fps_inv F) n = -((-1) ^ n * real n ^ (n - 1) / fact n)"
        by simp
      also have "\<dots> = (-real n) ^ (n - 1) / fact n"
        using 3 by (subst power_minus) (auto simp: minus_one_power_iff)
      finally show ?thesis
        using 3 by simp
    qed (auto simp: fps_inv_def F_def)
  qed
  thus ?thesis by (simp add: F_def fps_Lambert_W_def)
qed

(* TODO: Move *)
text \<open>
  Next, we need a few auxiliary lemmas about summability and convergence radii that should
  go into Isabelle's standard library at some point:
\<close>
lemma summable_comparison_test_bigo:
  fixes f :: "nat \<Rightarrow> real"
  assumes "summable (\<lambda>n. norm (g n))" "f \<in> O(g)"
  shows   "summable f"
proof -
  from \<open>f \<in> O(g)\<close> obtain C where C: "eventually (\<lambda>x. norm (f x) \<le> C * norm (g x)) at_top"
    by (auto elim: landau_o.bigE)
  thus ?thesis
    by (rule summable_comparison_test_ev) (insert assms, auto intro: summable_mult)
qed

lemma summable_comparison_test_bigo':
  assumes "summable (\<lambda>n. norm (g n))"
  assumes "(\<lambda>n. norm (f n :: 'a :: banach)) \<in> O(\<lambda>n. norm (g n))"
  shows   "summable f"
proof (rule summable_norm_cancel, rule summable_comparison_test_bigo)
  show "summable (\<lambda>n. norm (norm (g n)))"
    using assms by simp
qed fact+

lemma conv_radius_conv_Sup':
  fixes f :: "nat \<Rightarrow> 'a :: {banach, real_normed_div_algebra}"
  shows "conv_radius f = Sup {r. \<forall>z. ereal (norm z) < r \<longrightarrow> summable (\<lambda>n. norm (f n * z ^ n))}"
proof (rule Sup_eqI [symmetric], goal_cases)
  case (1 r)
  show ?case
  proof (rule conv_radius_geI_ex')
    fix r' :: real assume r': "r' > 0" "ereal r' < r"
    show "summable (\<lambda>n. f n * of_real r' ^ n)"
      by (rule summable_norm_cancel) (use 1 r' in auto)
  qed
next
  case (2 r)
  from 2[of 0] have r: "r \<ge> 0" by auto
  show ?case
  proof (intro conv_radius_leI_ex' r)
    fix R assume R: "R > 0" "ereal R > r"
    with r obtain r' where [simp]: "r = ereal r'" by (cases r) auto
    show "\<not>summable (\<lambda>n. f n * of_real R ^ n)"
    proof
      assume *: "summable (\<lambda>n. f n * of_real R ^ n)"
      define R' where "R' = (R + r') / 2"
      from R have R': "R' > r'" "R' < R" by (simp_all add: R'_def)
      hence "\<forall>z. norm z < R' \<longrightarrow> summable (\<lambda>n. norm (f n * z ^ n))"
        using powser_insidea[OF *] by auto
      from 2[of R'] and this have "R' \<le> r'" by auto
      with \<open>R' > r'\<close> show False by simp
    qed
  qed
qed

lemma bigo_imp_conv_radius_ge:
  fixes f g :: "nat \<Rightarrow> 'a :: {banach, real_normed_field}"
  assumes "f \<in> O(g)"
  shows   "conv_radius f \<ge> conv_radius g"
proof -
  have "conv_radius g = Sup {r. \<forall>z. ereal (norm z) < r \<longrightarrow> summable (\<lambda>n. norm (g n * z ^ n))}"
    by (simp add: conv_radius_conv_Sup')
  also have "\<dots> \<le> Sup {r. \<forall>z. ereal (norm z) < r \<longrightarrow> summable (\<lambda>n. f n * z ^ n)}"
  proof (rule Sup_subset_mono, safe)
    fix r :: ereal and z :: 'a
    assume g: "\<forall>z. ereal (norm z) < r \<longrightarrow> summable (\<lambda>n. norm (g n * z ^ n))"
    assume z: "ereal (norm z) < r"
    from g z have "summable (\<lambda>n. norm (g n * z ^ n))"
      by blast
    moreover have "(\<lambda>n. norm (f n * z ^ n)) \<in> O(\<lambda>n. norm (g n * z ^ n))"
      unfolding landau_o.big.norm_iff by (intro landau_o.big.mult assms) auto
    ultimately show "summable (\<lambda>n. f n * z ^ n)"
      by (rule summable_comparison_test_bigo')
  qed
  also have "\<dots> = conv_radius f"
    by (simp add: conv_radius_conv_Sup)
  finally show ?thesis .
qed

lemma conv_radius_cong_bigtheta:
  assumes "f \<in> \<Theta>(g)"
  shows   "conv_radius f = conv_radius g"
  using assms
  by (intro antisym bigo_imp_conv_radius_ge) (auto simp: bigtheta_def bigomega_iff_bigo)

lemma conv_radius_eqI_smallomega_smallo:
  fixes f :: "nat \<Rightarrow> 'a :: {real_normed_div_algebra, banach}"
  assumes "\<And>\<epsilon>. \<epsilon> > l \<Longrightarrow> \<epsilon> < inverse C \<Longrightarrow> (\<lambda>n. norm (f n)) \<in> \<omega>(\<lambda>n. \<epsilon> ^ n)"
  assumes "\<And>\<epsilon>. \<epsilon> < u \<Longrightarrow> \<epsilon> > inverse C \<Longrightarrow> (\<lambda>n. norm (f n)) \<in> o(\<lambda>n. \<epsilon> ^ n)"
  assumes C: "C > 0" and lu: "l > 0" "l < inverse C" "u > inverse C"
  shows   "conv_radius f = ereal C"
proof (intro antisym)
  have "0 < inverse C"
    using assms by (auto simp: field_simps)
  also have "\<dots> < u"
    by fact
  finally have "u > 0" by simp
  show "conv_radius f \<ge> C"
    unfolding conv_radius_altdef le_Liminf_iff
  proof safe
    fix c :: ereal assume c: "c < C"
    hence "max c (inverse u) < ereal C"
      using lu C \<open>u > 0\<close> by (auto simp: field_simps)
    from ereal_dense2[OF this] obtain c' where c': "c < ereal c'" "inverse u < c'" "c' < C"
      by auto
    have "inverse u > 0"
      using \<open>u > 0\<close> by simp
    also have "\<dots> < c'" by fact
    finally have "c' > 0" .

    have "\<forall>\<^sub>F x in sequentially. norm (norm (f x)) \<le> 1/2 * norm (inverse c' ^ x)"
      using landau_o.smallD[OF assms(2)[of "inverse c'"], of "1/2"] c' C lu \<open>c' > 0\<close> c
      by (simp add: field_simps)
    thus "\<forall>\<^sub>F n in sequentially. c < inverse (ereal (root n (norm (f n))))"
      using eventually_gt_at_top[of 0]
    proof eventually_elim
      case (elim n)
      have "norm (f n) \<le> 1/2 * norm (inverse c' ^ n)"
        using c' using elim by (simp add: field_simps)
      also have "\<dots> < norm (inverse c' ^ n)"
        using \<open>c' > 0\<close> by simp
      finally have "root n (norm (f n)) < root n (norm (inverse c' ^ n))"
        using \<open>n > 0\<close> c' by (intro real_root_less_mono) auto
      also have "root n (norm (inverse c' ^ n)) = inverse c'"
        using \<open>n > 0\<close> \<open>c' > 0\<close> by (simp add: norm_power real_root_power)
      finally have "ereal (root n (norm (f n))) < ereal (inverse c')"
        by simp
      also have "\<dots> = inverse (ereal c')"
        using \<open>c' > 0\<close> by auto
      finally have "inverse (inverse (ereal c')) < inverse (ereal (root n (norm (f n))))"
        using c' \<open>n > 0\<close> by (intro ereal_inverse_antimono_strict) auto
      also have "inverse (inverse (ereal c')) = ereal c'"
        using c' by simp
      finally show ?case
        using \<open>c < c'\<close> by simp
    qed
  qed
next
  show "conv_radius f \<le> C"
  proof (rule ccontr)
    assume "\<not>(conv_radius f \<le> C)"
    hence "conv_radius f > C" by auto
    hence "min (conv_radius f) (inverse l) > ereal C"
      using lu C \<open>l > 0\<close> by (auto simp: field_simps)
    from ereal_dense2[OF this] obtain c where c: "C < ereal c" "inverse l > c" "c < conv_radius f"
      by auto
    hence "c > 0" using lu C
      by (simp add: field_simps)

    have "\<forall>\<^sub>F n in sequentially. ereal c < inverse (ereal (root n (norm (f n))))"
      using less_LiminfD[OF c(3)[unfolded conv_radius_altdef]] by simp
    moreover have "\<forall>\<^sub>F n in sequentially. norm (f n) \<ge> 2 * norm (inverse c ^ n)"
      using landau_omega.smallD[OF assms(1)[of "inverse c"], of 2] c C \<open>c > 0\<close> lu
      by (simp add: field_simps)
    ultimately have "eventually (\<lambda>n. False) sequentially"
      using eventually_gt_at_top[of 0]
    proof eventually_elim
      case (elim n)
      have "norm (inverse c ^ n) < 2 * norm (inverse c ^ n)"
        using c \<open>n > 0\<close> C by simp
      also have "\<dots> \<le> norm (f n)"
        using elim by simp
      finally have "root n (inverse c ^ n) < root n (norm (f n))"
        using \<open>n > 0\<close> by (intro real_root_less_mono) auto
      also have "root n (inverse c ^ n) = inverse c"
        using \<open>n > 0\<close> c C by (subst real_root_power) auto
      finally have "ereal (inverse c) < ereal (root n (norm (f n)))"
        by simp
      also have "ereal (inverse c) = inverse (ereal c)"
        using c C by auto
      finally have "inverse (ereal (root n (norm (f n)))) < inverse (inverse (ereal c))"
        using c C
        by (intro ereal_inverse_antimono_strict) auto
      also have "\<dots> = ereal c"
        using c C by auto
      also have "\<dots> < inverse (ereal (root n (norm (f n))))"
        using elim by simp
      finally show False .
    qed
    thus False by simp
  qed
qed

text \<open>
  Finally, we show that the radius of convergence of $W(X)$ is $e^{-1}$ by directly computing
  \[\lim\limits_{n\to\infty} \sqrt[n]{|[X^n]\,W(X)|} = e\]
  using Stirling's formula for $n!$:
\<close>
lemma fps_conv_radius_Lambert_W: "fps_conv_radius fps_Lambert_W = exp (-1)"
proof -
  have "conv_radius (fps_nth fps_Lambert_W) = conv_radius (\<lambda>n. exp 1 ^ n * n powr (-3/2) :: real)"
  proof (rule conv_radius_cong_bigtheta)
    have "fps_nth fps_Lambert_W \<in> \<Theta>(\<lambda>n. (-real n) ^ (n - 1) / fact n)"
      by (intro bigthetaI_cong eventually_mono[OF eventually_gt_at_top[of 0]])
         (auto simp: fps_nth_Lambert_W)
    also have "(\<lambda>n. (-real n) ^ (n - 1) / fact n) \<in> \<Theta>(\<lambda>n. real n ^ (n - 1) / fact n)"
      by (subst landau_theta.norm_iff [symmetric], subst norm_divide) auto
    also have "(\<lambda>n. (real n) ^ (n - 1) / fact n) \<in>
                 \<Theta>(\<lambda>n. (real n) ^ (n - 1) / (sqrt (2 * pi * real n) * (real n / exp 1) ^ n))"
      by (intro asymp_equiv_imp_bigtheta asymp_equiv_intros fact_asymp_equiv)
    also have "(\<lambda>n. (real n) ^ (n - 1) / (sqrt (2 * pi * real n) * (real n / exp 1) ^ n)) \<in>
                 \<Theta>(\<lambda>n. exp 1 ^ n * n powr (-3/2))"
      by (real_asymp simp: ln_inverse)
    finally show "fps_nth fps_Lambert_W \<in> \<Theta>(\<lambda>n. exp 1 ^ n * n powr (-3/2) :: real)" .
  qed
  also have "\<dots> = inverse (limsup (\<lambda>n. ereal (root n (exp 1 ^ n * real n powr - (3 / 2)))))"
    by (simp add: conv_radius_def)
  also have "limsup (\<lambda>n. ereal (root n (exp 1 ^ n * real n powr - (3 / 2)))) = exp 1"
  proof (intro lim_imp_Limsup tendsto_intros)
    \<comment> \<open>real\_asymp does not support \<^const>\<open>root\<close> for a variable basis natively, so
        we need to convert it to \<^const>\<open>powr\<close> first.\<close>
    (* TODO add better "root" support to real_asymp *)
    have "(\<lambda>n. (exp 1 ^ n * real n powr -(3/2)) powr (1 / real n)) \<longlonglongrightarrow> exp 1"
      by real_asymp
    also have "?this \<longleftrightarrow> (\<lambda>x. root x (exp 1 ^ x * real x powr - (3 / 2))) \<longlonglongrightarrow> exp 1"
      by (intro filterlim_cong eventually_mono[OF eventually_gt_at_top[of 0]])
         (auto simp: root_powr_inverse)
    finally show \<dots> .
  qed auto
  finally show ?thesis
    by (simp add: fps_conv_radius_def exp_minus)
qed

end


(*
    Title:      Hermite_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Hermite Normal Form refined to immutable arrays\<close>

theory Hermite_IArrays
imports
  Hermite
  Echelon_Form.Echelon_Form_IArrays
begin

subsection\<open>Definition of the algorithm over immutable arrays\<close>

primrec Hermite_reduce_above_iarrays :: "'a::unique_euclidean_ring iarray iarray \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a\<Rightarrow>'a\<Rightarrow>'a) \<Rightarrow> 'a iarray iarray"
where "Hermite_reduce_above_iarrays A 0 i j res  = A"
    | "Hermite_reduce_above_iarrays A (Suc n) i j res  = (let i'=n;
    Aij = A !! i !! j;
    Ai'j = A !! i' !! j
    in
    Hermite_reduce_above_iarrays (row_add_iarray A  i' i (((res Aij (Ai'j)) - (Ai'j)) div Aij)) n i j res)"

definition "Hermite_of_row_i_iarray ass res A i = (
  if is_zero_iarray (A !! i)
     then A
  else
    let j = least_non_zero_position_of_vector (A !! i); Aij= (A !! i !! j);
    A' = mult_row_iarray A i ((ass Aij) div Aij)
    in Hermite_reduce_above_iarrays A' i i j res)"

definition "Hermite_of_upt_row_i_iarrays A i ass res  = foldl (Hermite_of_row_i_iarray ass res) A [0..<i]"

definition "Hermite_of_iarrays A ass res bezout =
  (let A'= echelon_form_of_iarrays A bezout
  in Hermite_of_upt_row_i_iarrays A' (nrows_iarray A) ass res)"

subsection\<open>Proving the equivalence between definitions of both representations\<close>

lemma matrix_to_iarray_Hermite_reduce_above:
  fixes A::"'a::{unique_euclidean_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes "n<nrows A"
  shows "matrix_to_iarray (Hermite_reduce_above A n i j res)
  = Hermite_reduce_above_iarrays (matrix_to_iarray A) n (to_nat i) (to_nat j) res"
  using assms
proof (induct n arbitrary: A)
  case 0 thus ?case by auto
next
  case (Suc n)
  have n: "n<nrows A"
    using Suc.prems unfolding nrows_def by simp
  obtain a::'rows where n_tna: "n = to_nat a"
    by (metis Suc.prems Suc_lessD nrows_def to_nat_from_nat_id)
  show ?case
    unfolding Hermite_reduce_above.simps
    unfolding Hermite_reduce_above_iarrays.simps
    unfolding Let_def sub_def[symmetric]
    unfolding n_tna
    unfolding matrix_to_iarray_row_add[symmetric] from_nat_to_nat_id
    unfolding matrix_to_iarray_nth
    unfolding n_tna[symmetric]
    by (rule Suc.hyps, auto simp add: nrows_def n[unfolded nrows_def])
qed

lemma matrix_to_iarray_Hermite_of_row_i[code_unfold]:
  fixes A::"'a::{unique_euclidean_ring}^'cols::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (Hermite_of_row_i ass res A i)
  = Hermite_of_row_i_iarray ass res (matrix_to_iarray A) (to_nat i)"
proof -
  have zero_rw: "is_zero_iarray (matrix_to_iarray A !! to_nat i) = is_zero_row i A"
    by (simp add: is_zero_iarray_eq_iff is_zero_row_eq_row_zero vec_to_iarray_row')
  show ?thesis
  proof (cases "is_zero_row i A")
    case True thus ?thesis
      unfolding Hermite_of_row_i_def Hermite_of_row_i_iarray_def Let_def zero_rw by auto
  next
    case False
    have Ain: "A $ i $ (LEAST n. A $ i $ n \<noteq> 0) \<noteq> 0"
      using False
      by (metis (mono_tags, lifting) LeastI is_zero_row_def')
    have l: "least_non_zero_position_of_vector (matrix_to_iarray A !! to_nat i) = to_nat (LEAST n. A $ i $ n \<noteq> 0)"
    proof -
      have least_rw: " (LEAST n. A $ i $ n \<noteq> 0 \<and> 0 \<le> n) =  (LEAST n. A $ i $ n \<noteq> 0)"
        by (rule Least_equality, auto simp add: least_mod_type Ain Least_le)
      have v_rw: "\<not> vector_all_zero_from_index (to_nat (0::'cols), vec_to_iarray (A $ i))"
        using False least_mod_type
        unfolding vector_all_zero_from_index_eq[of 0 "A$i", symmetric] is_zero_row_def' by auto
      show ?thesis using vec_to_iarray_least_non_zero_position_of_vector_from_index[OF v_rw]
        unfolding least_rw least_non_zero_position_of_vector_def to_nat_0 vec_matrix .
    qed
    show ?thesis
      unfolding Hermite_of_row_i_def Hermite_of_row_i_iarray_def Let_def
      unfolding zero_rw[symmetric]
      unfolding matrix_to_iarray_mult_row[symmetric]
      unfolding l
      unfolding matrix_to_iarray_nth
      by (auto, rule matrix_to_iarray_Hermite_reduce_above, simp add: nrows_def to_nat_less_card)
  qed
qed

lemma matrix_to_iarray_Hermite_of_upt_row_i:
  fixes A::"'a::{unique_euclidean_ring}^'cols::{mod_type}^'rows::{mod_type}"
  assumes i: "i\<le>nrows A"
  shows "matrix_to_iarray (Hermite_of_upt_row_i A i ass res)
  = Hermite_of_upt_row_i_iarrays (matrix_to_iarray A) i ass res"
  using i
proof (induct i arbitrary: A)
  case 0
  thus ?case by (simp add: Hermite_of_upt_row_i_def Hermite_of_upt_row_i_iarrays_def)
next
  case (Suc i)
  have i: "i<nrows A" using Suc.prems unfolding nrows_def by simp
  have "matrix_to_iarray (Hermite_of_upt_row_i A (Suc i) ass res)
    = matrix_to_iarray (Hermite_of_row_i ass res (Hermite_of_upt_row_i A i ass res) (from_nat i))"
    unfolding Hermite_of_upt_row_i_def by auto
  also have "... = (Hermite_of_row_i_iarray ass res
    (matrix_to_iarray (Hermite_of_upt_row_i A i ass res)) (to_nat (from_nat i::'rows)))"
    unfolding matrix_to_iarray_Hermite_of_row_i ..
  also have "... = (Hermite_of_row_i_iarray ass res (matrix_to_iarray (Hermite_of_upt_row_i A i ass res)) i)"
    using to_nat_from_nat_id[OF i[unfolded nrows_def]] by simp
  also have "... = (Hermite_of_row_i_iarray ass res
    (Hermite_of_upt_row_i_iarrays (matrix_to_iarray A) i ass res) i)"
    using Suc.hyps i unfolding nrows_def by simp
  also have "... =  Hermite_of_upt_row_i_iarrays (matrix_to_iarray A) (Suc i) ass res"
    unfolding Hermite_of_upt_row_i_iarrays_def by simp
  finally show ?case .
qed

lemma matrix_to_iarray_Hermite_of[code_unfold]:
  shows "matrix_to_iarray (Hermite_of A ass res bezout)
  = Hermite_of_iarrays (matrix_to_iarray A) ass res bezout"
proof -
  have n: "nrows A \<le> nrows (echelon_form_of A bezout)" unfolding nrows_def by simp
  show ?thesis
    unfolding Hermite_of_def Hermite_of_iarrays_def Let_def
    unfolding matrix_to_iarray_Hermite_of_upt_row_i[OF n]
    unfolding matrix_to_iarray_echelon_form_of
    unfolding matrix_to_iarray_nrows ..
qed

subsection\<open>Examples of execution using immutable arrays\<close>

value[code] "let A = list_of_list_to_matrix ([[37,8,6],[5,4,-8],[3,24,-7]])::int^3^3
  in matrix_to_iarray (Hermite_of A ass_function_euclidean res_function_euclidean euclid_ext2)"

value[code] "let A = IArray[IArray[37,8,6::int],IArray[5,4,-8],IArray[3,24,-7]]
  in (Hermite_of_iarrays A ass_function_euclidean res_function_euclidean euclid_ext2)"

value[code] "let A = list_of_list_to_matrix ([[[:3,4,5:],[:-2,1:]],[[:-1,0,2:],[:0,1,4,1:]]])::real poly^2^2
  in matrix_to_iarray (Hermite_of A ass_function_euclidean res_function_euclidean euclid_ext2)"

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_40
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun z :: "bool => bool => bool" where
  "z True y2 = y2"
| "z False y2 = False"

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

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

fun subset :: "Nat list => Nat list => bool" where
  "subset (nil2) y2 = True"
| "subset (cons2 z2 xs) y2 = z (elem z2 y2) (subset xs y2)"

fun union :: "Nat list => Nat list => Nat list" where
  "union (nil2) y2 = y2"
| "union (cons2 z2 xs) y2 =
     (if elem z2 y2 then union xs y2 else cons2 z2 (union xs y2))"

theorem property0 :
  "((subset x2 y2) ==> ((union x2 y2) = y2))"
  oops

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Strassen's Algorithm as Code Equation\<close>

text \<open>We replace the code-equations for matrix-multiplication
  by Strassen's algorithm. Note that this will strengthen the class-constraint
  for matrix multiplication from semirings to rings!\<close>

theory Strassen_Algorithm_Code
imports
  Strassen_Algorithm
begin

text \<open>The aim is to replace the implementation of @{thm times_mat_def} by @{const strassen_mat_mult}.\<close>

text \<open>We first need a copy of standard matrix multiplication to execute the base case.\<close>

definition "basic_mat_mult = (*)"
lemma basic_mat_mult_code[code]: "basic_mat_mult A B = mat (dim_row A) (dim_col B) (\<lambda> (i,j). row A i \<bullet> col B j)"
  unfolding basic_mat_mult_def by auto

text \<open>Next use this new matrix multiplication code within Strassen's algorithm.\<close>
lemmas strassen_mat_mult_code[code] = strassen_mat_mult.simps[folded basic_mat_mult_def]

text \<open>And finally use Strassen's algorithm for implementing matrix-multiplication.\<close>

lemma mat_mult_code[code]: "A * B = (if dim_col A = dim_row B then strassen_mat_mult A B else basic_mat_mult A B)"
  using strassen_mat_mult[of A B] unfolding basic_mat_mult_def by auto

end


section \<open>Algorithms to compute all complex and real roots of a quartic polynomial\<close>

theory Quartic_Polynomials
  imports
    Ferraris_Formula
    Cubic_Polynomials
begin

text \<open>The complex case is straight-forward\<close>

definition solve_depressed_quartic_complex :: "complex \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> complex list" where
  "solve_depressed_quartic_complex p q r = remdups (if q = 0 then
     (concat (map (\<lambda> z. let y = csqrt z in [y,-y]) (croots2 [:r,p,1:]))) else
     let cubics = croots3 [: - (q^2), 2 * p^2 - 8 * r, 8 * p, 8:];
         m = hd cubics; \<comment> \<open>select any root of the cubic polynomial\<close>
         a = csqrt (2 * m);
         p2m = p / 2 + m;
         q2a = q / (2 * a);
         b1 = p2m - q2a;
         b2 = p2m + q2a
       in (croots2 [:b1,a,1:] @ croots2 [:b2,-a,1:]))"

lemma solve_depressed_quartic_complex: "x \<in> set (solve_depressed_quartic_complex p q r)
  \<longleftrightarrow> (x^4 + p * x^2 + q * x + r = 0)"
proof -
  note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
  show ?thesis
  proof (cases "q = 0")
    case True
    have csqrt: "z = x^2 \<longleftrightarrow> (x = csqrt z \<or> x = - csqrt z)" for z
      by (metis power2_csqrt power2_eq_iff)
    have "(x ^ 4 + p * x\<^sup>2 + q * x + r = 0) \<longleftrightarrow> (x ^ 4 + p * x\<^sup>2 + r = 0)"
      unfolding True by simp
    also have "\<dots> \<longleftrightarrow> (\<exists>z. z\<^sup>2 + p * z + r = 0 \<and> z = x\<^sup>2)" unfolding biquadratic_solution by simp
    also have "\<dots> \<longleftrightarrow> (\<exists> z. poly [:r,p,1:] z = 0 \<and> z = x^2)"
      by (simp add: powers)
    also have "\<dots> \<longleftrightarrow> (\<exists> z \<in> set (croots2 [:r,p,1:]). z = x^2)"
      by (subst croots2[symmetric], auto)
    also have "\<dots> \<longleftrightarrow> (\<exists> z \<in> set (croots2 [:r,p,1:]). x = csqrt z \<or> x = - csqrt z)"
      unfolding csqrt ..
    also have "\<dots> \<longleftrightarrow> (x \<in> set (solve_depressed_quartic_complex p q r))"
      unfolding solve_depressed_quartic_complex_def id unfolding True Let_def by auto
    finally show ?thesis ..
  next
    case q0: False
    hence id: "(if q = 0 then x else y) = y" for x y :: "complex list" by auto
    note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
    let ?poly = "[:- q\<^sup>2, 2 * p\<^sup>2 - 8 * r, 8 * p, 8:]"
    from croots3[of ?poly] have croots: "set (croots3 ?poly) = {x. poly ?poly x = 0}" by auto
    from fundamental_theorem_of_algebra_alt[of ?poly]
    have "{x. poly ?poly x = 0} \<noteq> {}" by auto
    with croots have "croots3 ?poly \<noteq> []" by auto
    then obtain m rest where rts: "croots3 ?poly = m # rest" by (cases "croots3 ?poly", auto)
    hence hd: "hd (croots3 ?poly) = m" by auto
    from croots[unfolded rts] have "poly ?poly m = 0" by auto
    hence mrt: "8*m^3 + (8 * p) * m^2 + (2 * p^2 - 8 * r) * m - q^2 = 0"
      and m0: "m \<noteq> 0" using q0
      by (auto simp: powers)
    define b1 where "b1 = p / 2 + m - q / (2 * csqrt (2 * m))"
    define b2 where "b2 = p / 2 + m + q / (2 * csqrt (2 * m))"
    have csqrt: "csqrt x * csqrt x = x" for x by (metis power2_csqrt power2_eq_square)
    show ?thesis unfolding solve_depressed_quartic_complex_def id Let_def set_remdups set_append hd
      unfolding b1_def[symmetric] b2_def[symmetric]
      apply (subst depressed_quartic_Ferrari[OF mrt q0 csqrt b1_def b2_def])
      apply (subst (1 2) croots2[symmetric], auto)
      done
  qed
qed

text \<open>The main difference in the real case is that a specific cubic root has to be used, namely
  a positive one. In the soundness proof we show that such a cubic root always exists.\<close>

definition solve_depressed_quartic_real :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real list" where
  "solve_depressed_quartic_real p q r = remdups (if q = 0 then
     (concat (map (\<lambda> z. rroots2 [:-z,0,1:]) (rroots2 [:r,p,1:]))) else
     let cubics = rroots3 [: - (q^2), 2 * p^2 - 8 * r, 8 * p, 8:];
         m = the (find (\<lambda> m. m > 0) cubics);  \<comment> \<open>select any positive root of the cubic polynomial\<close>
         a = sqrt (2 * m);
         p2m = p / 2 + m;
         q2a = q / (2 * a);
         b1 = p2m - q2a;
         b2 = p2m + q2a
       in (rroots2 [:b1,a,1:] @ rroots2 [:b2,-a,1:]))"

lemma solve_depressed_quartic_real: "x \<in> set (solve_depressed_quartic_real p q r)
  \<longleftrightarrow> (x^4 + p * x^2 + q * x + r = 0)"
proof -
  note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
  show ?thesis
  proof (cases "q = 0")
    case True
    have sqrt: "z = x^2 \<longleftrightarrow> (x \<in> set (rroots2 [:-z,0,1:]))" for z
      by (subst rroots2[symmetric], auto simp: powers)
    have "(x ^ 4 + p * x\<^sup>2 + q * x + r = 0) \<longleftrightarrow> (x ^ 4 + p * x\<^sup>2 + r = 0)"
      unfolding True by simp
    also have "\<dots> \<longleftrightarrow> (\<exists>z. z\<^sup>2 + p * z + r = 0 \<and> z = x\<^sup>2)" unfolding biquadratic_solution by simp
    also have "\<dots> \<longleftrightarrow> (\<exists> z. poly [:r,p,1:] z = 0 \<and> z = x^2)"
      by (simp add: powers)
    also have "\<dots> \<longleftrightarrow> (\<exists> z \<in> set (rroots2 [:r,p,1:]). z = x^2)"
      by (subst rroots2[symmetric], auto)
    also have "\<dots> \<longleftrightarrow> (\<exists> z \<in> set (rroots2 [:r,p,1:]). x \<in> set (rroots2 [:-z,0,1:]))"
      unfolding sqrt ..
    also have "\<dots> \<longleftrightarrow> (x \<in> set (solve_depressed_quartic_real p q r))"
      unfolding solve_depressed_quartic_real_def id unfolding True Let_def by auto
    finally show ?thesis ..
  next
    case q0: False
    hence id: "(if q = 0 then x else y) = y" for x y :: "real list" by auto
    note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
    let ?poly = "[:- q\<^sup>2, 2 * p\<^sup>2 - 8 * r, 8 * p, 8:]"

    define cubics where "cubics = rroots3 ?poly"
    from rroots3[of ?poly, folded cubics_def]
    have rroots: "set cubics = {x. poly ?poly x = 0}" by auto
    from odd_degree_imp_real_root[of ?poly]
    have "{x. poly ?poly x = 0} \<noteq> {}" by auto
    with rroots have "cubics \<noteq> []" by auto
    have "\<exists> m. m \<in> set cubics \<and> m > 0"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      from this[unfolded rroots] have rt: "poly ?poly m = 0 \<Longrightarrow> m \<le> 0" for m by auto
      have "poly ?poly 0 = - (q^2)" by simp
      also have "\<dots> < 0" using q0 by auto
      finally have lt: "poly ?poly 0 \<le> 0" by simp
      from poly_pinfty_gt_lc[of ?poly] obtain n0 where "\<And> n. n \<ge> n0 \<Longrightarrow> 8 \<le> poly ?poly n" by auto
      from this[of "max n0 0"] have "poly ?poly (max n0 0) \<ge> 0" by auto
      from IVT[of "poly ?poly", OF lt this] obtain m where "m \<ge> 0" and poly: "poly ?poly m = 0" by auto
      from rt[OF this(2)] this(1) have "m = 0" by auto
      thus False using poly q0 by simp
    qed
    hence "find (\<lambda> m. m > 0) cubics \<noteq> None" unfolding find_None_iff by auto
    then obtain m where find: "find (\<lambda> m. m > 0) cubics = Some m" by auto
    from find_Some_D[OF this] have m: "m \<in> set cubics" and m_0: "m > 0" by auto
    with rroots have "poly ?poly m = 0" by auto
    hence mrt: "8*m^3 + (8 * p) * m^2 + (2 * p^2 - 8 * r) * m - q^2 = 0"
      by (auto simp: powers)
    from m_0 have sqrt: "sqrt (2 * m) * sqrt (2 * m) = 2 * m" by simp
    define b1 where "b1 = p / 2 + m - q / (2 * sqrt (2 * m))"
    define b2 where "b2 = p / 2 + m + q / (2 * sqrt (2 * m))"
    show ?thesis unfolding solve_depressed_quartic_real_def id Let_def set_remdups set_append
        cubics_def[symmetric] find option.sel
      unfolding b1_def[symmetric] b2_def[symmetric]
      apply (subst depressed_quartic_Ferrari[OF mrt q0 sqrt b1_def b2_def])
      apply (subst (1 2) rroots2[symmetric], auto)
      done
  qed
qed

text \<open>Combining the various algorithms\<close>

lemma numeral_4_eq_4: "4 = Suc (Suc (Suc (Suc 0)))"
  by (simp add: eval_nat_numeral)

lemma degree4_coeffs: "degree p = 4 \<Longrightarrow>
  \<exists> a b c d e. p = [: e, d, c, b, a :] \<and> a \<noteq> 0"
  using degree3_coeffs degree_pCons_eq_if nat.inject numeral_3_eq_3 numeral_4_eq_4 pCons_cases zero_neq_numeral
  by metis

definition roots4_generic :: "('a :: field_char_0 \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list) \<Rightarrow> 'a poly \<Rightarrow> 'a list" where
  "roots4_generic depressed_solver p = (let
     cs = coeffs p;
     cs = coeffs p;
     a4 = cs ! 4; a3 = cs ! 3; a2 = cs ! 2; a1 = cs ! 1; a0 = cs ! 0;
     b = a3 / a4;
     c = a2 / a4;
     d = a1 / a4;
     e = a0 / a4;
     b2 = b * b;
     b3 = b2 * b;
     b4 = b3 * b;
     b4' = b / 4;
     p = c - 3/8 * b2;
     q = (b3 - 4*b*c + 8 * d) / 8;
     r = ( -3 * b4 + 256 * e - 64 * b * d + 16 * b2 * c) / 256;
     roots = depressed_solver p q r
     in map (\<lambda> y. y - b4') roots)"

lemma roots4_generic: assumes deg: "degree p = 4"
  and solver: "\<And> p q r y. y \<in> set (depressed_solver p q r) \<longleftrightarrow> y^4 + p * y^2 + q * y + r = 0"
  shows "set (roots4_generic depressed_solver p) = {x. poly p x = 0}"
proof -
  note powers = field_simps power4_eq_xxxx power3_eq_cube power2_eq_square
  from degree4_coeffs[OF deg] obtain a4 a3 a2 a1 a0 where
    p: "p = [:a0,a1,a2,a3,a4:]" and a4: "a4 \<noteq> 0" by auto
  have coeffs: "coeffs p ! 4 = a4" "coeffs p ! 3 = a3" "coeffs p ! 2 = a2" "coeffs p ! 1 = a1" "coeffs p ! 0 = a0"
    unfolding p using a4 by auto
  define b where "b = a3 / a4"
  define c where "c = a2 / a4"
  define d where "d = a1 / a4"
  define e where "e = a0 / a4"
  note def = roots4_generic_def[of depressed_solver p, unfolded Let_def coeffs, folded b_def c_def d_def e_def,
      folded power4_eq_xxxx, folded power3_eq_cube, folded power2_eq_square]
  let ?p = p
  {
    fix x
    define y where "y = x + b / 4"
    define p where "p = c - (3/8) * b^2"
    define q where "q = (b^3 - 4*b*c + 8 * d) / 8"
    define r where "r = ( -3 * b^4 + 256 * e - 64 * b * d + 16 * b^2 * c) / 256"
    note def = def[folded p_def q_def r_def]
    have xy: "x = y - b / 4" unfolding y_def by auto
    have "poly ?p x = 0 \<longleftrightarrow> a4 * x^4 + a3 * x^3 + a2 * x^2 + a1 * x + a0 = 0" unfolding p
      by (simp add: powers)
    also have "\<dots> \<longleftrightarrow> (y ^ 4 + p * y\<^sup>2 + q * y + r = 0)"
      unfolding to_depressed_quartic[OF a4 b_def c_def d_def e_def p_def q_def r_def xy] ..
    also have "\<dots> \<longleftrightarrow> y \<in> set (depressed_solver p q r)"
      unfolding solver ..
    also have "\<dots> \<longleftrightarrow> x \<in> set (roots4_generic depressed_solver ?p)" unfolding xy def by auto
    finally have "poly ?p x = 0 \<longleftrightarrow> x \<in> set (roots4_generic depressed_solver ?p)" by auto
  }
  thus ?thesis by simp
qed

definition croots4 :: "complex poly \<Rightarrow> complex list" where
  "croots4 = roots4_generic solve_depressed_quartic_complex"

lemma croots4: assumes deg: "degree p = 4"
  shows "set (croots4 p) = { x. poly p x = 0}"
  unfolding croots4_def by (rule roots4_generic[OF deg solve_depressed_quartic_complex])

definition rroots4 :: "real poly \<Rightarrow> real list" where
  "rroots4 = roots4_generic solve_depressed_quartic_real"

lemma rroots4: assumes deg: "degree p = 4"
  shows "set (rroots4 p) = { x. poly p x = 0}"
  unfolding rroots4_def by (rule roots4_generic[OF deg solve_depressed_quartic_real])

end