(*  Title:      HOL/BNF_Cardinal_Arithmetic.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Copyright   2012

Cardinal arithmetic as needed by bounded natural functors.
*)

section {* Cardinal Arithmetic as Needed by Bounded Natural Functors *}

theory BNF_Cardinal_Arithmetic
imports BNF_Cardinal_Order_Relation
begin

lemma dir_image: "\<lbrakk>\<And>x y. (f x = f y) = (x = y); Card_order r\<rbrakk> \<Longrightarrow> r =o dir_image r f"
by (rule dir_image_ordIso) (auto simp add: inj_on_def card_order_on_def)

lemma card_order_dir_image:
  assumes bij: "bij f" and co: "card_order r"
  shows "card_order (dir_image r f)"
proof -
  from assms have "Field (dir_image r f) = UNIV"
    using card_order_on_Card_order[of UNIV r] unfolding bij_def dir_image_Field by auto
  moreover from bij have "\<And>x y. (f x = f y) = (x = y)" unfolding bij_def inj_on_def by auto
  with co have "Card_order (dir_image r f)"
    using card_order_on_Card_order[of UNIV r] Card_order_ordIso2[OF _ dir_image] by blast
  ultimately show ?thesis by auto
qed

lemma ordIso_refl: "Card_order r \<Longrightarrow> r =o r"
by (rule card_order_on_ordIso)

lemma ordLeq_refl: "Card_order r \<Longrightarrow> r \<le>o r"
by (rule ordIso_imp_ordLeq, rule card_order_on_ordIso)

lemma card_of_ordIso_subst: "A = B \<Longrightarrow> |A| =o |B|"
by (simp only: ordIso_refl card_of_Card_order)

lemma Field_card_order: "card_order r \<Longrightarrow> Field r = UNIV"
using card_order_on_Card_order[of UNIV r] by simp

subsection {* Zero *}

definition czero where
  "czero = card_of {}"

lemma czero_ordIso:
  "czero =o czero"
using card_of_empty_ordIso by (simp add: czero_def)

lemma card_of_ordIso_czero_iff_empty:
  "|A| =o (czero :: 'b rel) \<longleftrightarrow> A = ({} :: 'a set)"
unfolding czero_def by (rule iffI[OF card_of_empty2]) (auto simp: card_of_refl card_of_empty_ordIso)

(* A "not czero" Cardinal predicate *)
abbreviation Cnotzero where
  "Cnotzero (r :: 'a rel) \<equiv> \<not>(r =o (czero :: 'a rel)) \<and> Card_order r"

(*helper*)
lemma Cnotzero_imp_not_empty: "Cnotzero r \<Longrightarrow> Field r \<noteq> {}"
  unfolding Card_order_iff_ordIso_card_of czero_def by force

lemma czeroI:
  "\<lbrakk>Card_order r; Field r = {}\<rbrakk> \<Longrightarrow> r =o czero"
using Cnotzero_imp_not_empty ordIso_transitive[OF _ czero_ordIso] by blast

lemma czeroE:
  "r =o czero \<Longrightarrow> Field r = {}"
unfolding czero_def
by (drule card_of_cong) (simp only: Field_card_of card_of_empty2)

lemma Cnotzero_mono:
  "\<lbrakk>Cnotzero r; Card_order q; r \<le>o q\<rbrakk> \<Longrightarrow> Cnotzero q"
apply (rule ccontr)
apply auto
apply (drule czeroE)
apply (erule notE)
apply (erule czeroI)
apply (drule card_of_mono2)
apply (simp only: card_of_empty3)
done

subsection {* (In)finite cardinals *}

definition cinfinite where
  "cinfinite r = (\<not> finite (Field r))"

abbreviation Cinfinite where
  "Cinfinite r \<equiv> cinfinite r \<and> Card_order r"

definition cfinite where
  "cfinite r = finite (Field r)"

abbreviation Cfinite where
  "Cfinite r \<equiv> cfinite r \<and> Card_order r"

lemma Cfinite_ordLess_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r <o s"
  unfolding cfinite_def cinfinite_def
  by (blast intro: finite_ordLess_infinite card_order_on_well_order_on)

lemmas natLeq_card_order = natLeq_Card_order[unfolded Field_natLeq]

lemma natLeq_cinfinite: "cinfinite natLeq"
unfolding cinfinite_def Field_natLeq by (rule infinite_UNIV_nat)

lemma natLeq_ordLeq_cinfinite:
  assumes inf: "Cinfinite r"
  shows "natLeq \<le>o r"
proof -
  from inf have "natLeq \<le>o |Field r|" unfolding cinfinite_def
    using infinite_iff_natLeq_ordLeq by blast
  also from inf have "|Field r| =o r" by (simp add: card_of_unique ordIso_symmetric)
  finally show ?thesis .
qed

lemma cinfinite_not_czero: "cinfinite r \<Longrightarrow> \<not> (r =o (czero :: 'a rel))"
unfolding cinfinite_def by (cases "Field r = {}") (auto dest: czeroE)

lemma Cinfinite_Cnotzero: "Cinfinite r \<Longrightarrow> Cnotzero r"
by (rule conjI[OF cinfinite_not_czero]) simp_all

lemma Cinfinite_cong: "\<lbrakk>r1 =o r2; Cinfinite r1\<rbrakk> \<Longrightarrow> Cinfinite r2"
using Card_order_ordIso2[of r1 r2] unfolding cinfinite_def ordIso_iff_ordLeq
by (auto dest: card_of_ordLeq_infinite[OF card_of_mono2])

lemma cinfinite_mono: "\<lbrakk>r1 \<le>o r2; cinfinite r1\<rbrakk> \<Longrightarrow> cinfinite r2"
unfolding cinfinite_def by (auto dest: card_of_ordLeq_infinite[OF card_of_mono2])

subsection {* Binary sum *}

definition csum (infixr "+c" 65) where
  "r1 +c r2 \<equiv> |Field r1 <+> Field r2|"

lemma Field_csum: "Field (r +c s) = Inl ` Field r \<union> Inr ` Field s"
  unfolding csum_def Field_card_of by auto

lemma Card_order_csum:
  "Card_order (r1 +c r2)"
unfolding csum_def by (simp add: card_of_Card_order)

lemma csum_Cnotzero1:
  "Cnotzero r1 \<Longrightarrow> Cnotzero (r1 +c r2)"
unfolding csum_def using Cnotzero_imp_not_empty[of r1] Plus_eq_empty_conv[of "Field r1" "Field r2"]
   card_of_ordIso_czero_iff_empty[of "Field r1 <+> Field r2"] by (auto intro: card_of_Card_order)

lemma card_order_csum:
  assumes "card_order r1" "card_order r2"
  shows "card_order (r1 +c r2)"
proof -
  have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
  thus ?thesis unfolding csum_def by (auto simp: card_of_card_order_on)
qed

lemma cinfinite_csum:
  "cinfinite r1 \<or> cinfinite r2 \<Longrightarrow> cinfinite (r1 +c r2)"
unfolding cinfinite_def csum_def by (auto simp: Field_card_of)

lemma Cinfinite_csum1:
  "Cinfinite r1 \<Longrightarrow> Cinfinite (r1 +c r2)"
unfolding cinfinite_def csum_def by (rule conjI[OF _ card_of_Card_order]) (auto simp: Field_card_of)

lemma Cinfinite_csum:
  "Cinfinite r1 \<or> Cinfinite r2 \<Longrightarrow> Cinfinite (r1 +c r2)"
unfolding cinfinite_def csum_def by (rule conjI[OF _ card_of_Card_order]) (auto simp: Field_card_of)

lemma Cinfinite_csum_weak:
  "\<lbrakk>Cinfinite r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 +c r2)"
by (erule Cinfinite_csum1)

lemma csum_cong: "\<lbrakk>p1 =o r1; p2 =o r2\<rbrakk> \<Longrightarrow> p1 +c p2 =o r1 +c r2"
by (simp only: csum_def ordIso_Plus_cong)

lemma csum_cong1: "p1 =o r1 \<Longrightarrow> p1 +c q =o r1 +c q"
by (simp only: csum_def ordIso_Plus_cong1)

lemma csum_cong2: "p2 =o r2 \<Longrightarrow> q +c p2 =o q +c r2"
by (simp only: csum_def ordIso_Plus_cong2)

lemma csum_mono: "\<lbrakk>p1 \<le>o r1; p2 \<le>o r2\<rbrakk> \<Longrightarrow> p1 +c p2 \<le>o r1 +c r2"
by (simp only: csum_def ordLeq_Plus_mono)

lemma csum_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 +c q \<le>o r1 +c q"
by (simp only: csum_def ordLeq_Plus_mono1)

lemma csum_mono2: "p2 \<le>o r2 \<Longrightarrow> q +c p2 \<le>o q +c r2"
by (simp only: csum_def ordLeq_Plus_mono2)

lemma ordLeq_csum1: "Card_order p1 \<Longrightarrow> p1 \<le>o p1 +c p2"
by (simp only: csum_def Card_order_Plus1)

lemma ordLeq_csum2: "Card_order p2 \<Longrightarrow> p2 \<le>o p1 +c p2"
by (simp only: csum_def Card_order_Plus2)

lemma csum_com: "p1 +c p2 =o p2 +c p1"
by (simp only: csum_def card_of_Plus_commute)

lemma csum_assoc: "(p1 +c p2) +c p3 =o p1 +c p2 +c p3"
by (simp only: csum_def Field_card_of card_of_Plus_assoc)

lemma Cfinite_csum: "\<lbrakk>Cfinite r; Cfinite s\<rbrakk> \<Longrightarrow> Cfinite (r +c s)"
  unfolding cfinite_def csum_def Field_card_of using card_of_card_order_on by simp

lemma csum_csum: "(r1 +c r2) +c (r3 +c r4) =o (r1 +c r3) +c (r2 +c r4)"
proof -
  have "(r1 +c r2) +c (r3 +c r4) =o r1 +c r2 +c (r3 +c r4)"
    by (rule csum_assoc)
  also have "r1 +c r2 +c (r3 +c r4) =o r1 +c (r2 +c r3) +c r4"
    by (intro csum_assoc csum_cong2 ordIso_symmetric)
  also have "r1 +c (r2 +c r3) +c r4 =o r1 +c (r3 +c r2) +c r4"
    by (intro csum_com csum_cong1 csum_cong2)
  also have "r1 +c (r3 +c r2) +c r4 =o r1 +c r3 +c r2 +c r4"
    by (intro csum_assoc csum_cong2 ordIso_symmetric)
  also have "r1 +c r3 +c r2 +c r4 =o (r1 +c r3) +c (r2 +c r4)"
    by (intro csum_assoc ordIso_symmetric)
  finally show ?thesis .
qed

lemma Plus_csum: "|A <+> B| =o |A| +c |B|"
by (simp only: csum_def Field_card_of card_of_refl)

lemma Un_csum: "|A \<union> B| \<le>o |A| +c |B|"
using ordLeq_ordIso_trans[OF card_of_Un_Plus_ordLeq Plus_csum] by blast

subsection {* One *}

definition cone where
  "cone = card_of {()}"

lemma Card_order_cone: "Card_order cone"
unfolding cone_def by (rule card_of_Card_order)

lemma Cfinite_cone: "Cfinite cone"
  unfolding cfinite_def by (simp add: Card_order_cone)

lemma cone_not_czero: "\<not> (cone =o czero)"
unfolding czero_def cone_def ordIso_iff_ordLeq using card_of_empty3 empty_not_insert by blast

lemma cone_ordLeq_Cnotzero: "Cnotzero r \<Longrightarrow> cone \<le>o r"
unfolding cone_def by (rule Card_order_singl_ordLeq) (auto intro: czeroI)

subsection {* Two *}

definition ctwo where
  "ctwo = |UNIV :: bool set|"

lemma Card_order_ctwo: "Card_order ctwo"
unfolding ctwo_def by (rule card_of_Card_order)

lemma ctwo_not_czero: "\<not> (ctwo =o czero)"
using card_of_empty3[of "UNIV :: bool set"] ordIso_iff_ordLeq
unfolding czero_def ctwo_def using UNIV_not_empty by auto

lemma ctwo_Cnotzero: "Cnotzero ctwo"
by (simp add: ctwo_not_czero Card_order_ctwo)

subsection {* Family sum *}

definition Csum where
  "Csum r rs \<equiv> |SIGMA i : Field r. Field (rs i)|"

(* Similar setup to the one for SIGMA from theory Big_Operators: *)
syntax "_Csum" ::
  "pttrn => ('a * 'a) set => 'b * 'b set => (('a * 'b) * ('a * 'b)) set"
  ("(3CSUM _:_. _)" [0, 51, 10] 10)

translations
  "CSUM i:r. rs" == "CONST Csum r (%i. rs)"

lemma SIGMA_CSUM: "|SIGMA i : I. As i| = (CSUM i : |I|. |As i| )"
by (auto simp: Csum_def Field_card_of)

(* NB: Always, under the cardinal operator,
operations on sets are reduced automatically to operations on cardinals.
This should make cardinal reasoning more direct and natural.  *)

subsection {* Product *}

definition cprod (infixr "*c" 80) where
  "r1 *c r2 = |Field r1 <*> Field r2|"

lemma card_order_cprod:
  assumes "card_order r1" "card_order r2"
  shows "card_order (r1 *c r2)"
proof -
  have "Field r1 = UNIV" "Field r2 = UNIV" using assms card_order_on_Card_order by auto
  thus ?thesis by (auto simp: cprod_def card_of_card_order_on)
qed

lemma Card_order_cprod: "Card_order (r1 *c r2)"
by (simp only: cprod_def Field_card_of card_of_card_order_on)

lemma cprod_mono1: "p1 \<le>o r1 \<Longrightarrow> p1 *c q \<le>o r1 *c q"
by (simp only: cprod_def ordLeq_Times_mono1)

lemma cprod_mono2: "p2 \<le>o r2 \<Longrightarrow> q *c p2 \<le>o q *c r2"
by (simp only: cprod_def ordLeq_Times_mono2)

lemma cprod_mono: "\<lbrakk>p1 \<le>o r1; p2 \<le>o r2\<rbrakk> \<Longrightarrow> p1 *c p2 \<le>o r1 *c r2"
by (rule ordLeq_transitive[OF cprod_mono1 cprod_mono2])

lemma ordLeq_cprod2: "\<lbrakk>Cnotzero p1; Card_order p2\<rbrakk> \<Longrightarrow> p2 \<le>o p1 *c p2"
unfolding cprod_def by (rule Card_order_Times2) (auto intro: czeroI)

lemma cinfinite_cprod: "\<lbrakk>cinfinite r1; cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
by (simp add: cinfinite_def cprod_def Field_card_of infinite_cartesian_product)

lemma cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> cinfinite (r1 *c r2)"
by (rule cinfinite_mono) (auto intro: ordLeq_cprod2)

lemma Cinfinite_cprod2: "\<lbrakk>Cnotzero r1; Cinfinite r2\<rbrakk> \<Longrightarrow> Cinfinite (r1 *c r2)"
by (blast intro: cinfinite_cprod2 Card_order_cprod)

lemma cprod_cong: "\<lbrakk>p1 =o r1; p2 =o r2\<rbrakk> \<Longrightarrow> p1 *c p2 =o r1 *c r2"
unfolding ordIso_iff_ordLeq by (blast intro: cprod_mono)

lemma cprod_cong1: "\<lbrakk>p1 =o r1\<rbrakk> \<Longrightarrow> p1 *c p2 =o r1 *c p2"
unfolding ordIso_iff_ordLeq by (blast intro: cprod_mono1)

lemma cprod_cong2: "p2 =o r2 \<Longrightarrow> q *c p2 =o q *c r2"
unfolding ordIso_iff_ordLeq by (blast intro: cprod_mono2)

lemma cprod_com: "p1 *c p2 =o p2 *c p1"
by (simp only: cprod_def card_of_Times_commute)

lemma card_of_Csum_Times:
  "\<forall>i \<in> I. |A i| \<le>o |B| \<Longrightarrow> (CSUM i : |I|. |A i| ) \<le>o |I| *c |B|"
by (simp only: Csum_def cprod_def Field_card_of card_of_Sigma_mono1)

lemma card_of_Csum_Times':
  assumes "Card_order r" "\<forall>i \<in> I. |A i| \<le>o r"
  shows "(CSUM i : |I|. |A i| ) \<le>o |I| *c r"
proof -
  from assms(1) have *: "r =o |Field r|" by (simp add: card_of_unique)
  with assms(2) have "\<forall>i \<in> I. |A i| \<le>o |Field r|" by (blast intro: ordLeq_ordIso_trans)
  hence "(CSUM i : |I|. |A i| ) \<le>o |I| *c |Field r|" by (simp only: card_of_Csum_Times)
  also from * have "|I| *c |Field r| \<le>o |I| *c r"
    by (simp only: Field_card_of card_of_refl cprod_def ordIso_imp_ordLeq)
  finally show ?thesis .
qed

lemma cprod_csum_distrib1: "r1 *c r2 +c r1 *c r3 =o r1 *c (r2 +c r3)"
unfolding csum_def cprod_def by (simp add: Field_card_of card_of_Times_Plus_distrib ordIso_symmetric)

lemma csum_absorb2': "\<lbrakk>Card_order r2; r1 \<le>o r2; cinfinite r1 \<or> cinfinite r2\<rbrakk> \<Longrightarrow> r1 +c r2 =o r2"
unfolding csum_def by (rule conjunct2[OF Card_order_Plus_infinite])
  (auto simp: cinfinite_def dest: cinfinite_mono)

lemma csum_absorb1':
  assumes card: "Card_order r2"
  and r12: "r1 \<le>o r2" and cr12: "cinfinite r1 \<or> cinfinite r2"
  shows "r2 +c r1 =o r2"
by (rule ordIso_transitive, rule csum_com, rule csum_absorb2', (simp only: assms)+)

lemma csum_absorb1: "\<lbrakk>Cinfinite r2; r1 \<le>o r2\<rbrakk> \<Longrightarrow> r2 +c r1 =o r2"
by (rule csum_absorb1') auto

subsection {* Exponentiation *}

definition cexp (infixr "^c" 90) where
  "r1 ^c r2 \<equiv> |Func (Field r2) (Field r1)|"

lemma Card_order_cexp: "Card_order (r1 ^c r2)"
unfolding cexp_def by (rule card_of_Card_order)

lemma cexp_mono':
  assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
  and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
  shows "p1 ^c p2 \<le>o r1 ^c r2"
proof(cases "Field p1 = {}")
  case True
  hence "Field p2 \<noteq> {} \<Longrightarrow> Func (Field p2) {} = {}" unfolding Func_is_emp by simp
  with True have "|Field |Func (Field p2) (Field p1)|| \<le>o cone"
    unfolding cone_def Field_card_of
    by (cases "Field p2 = {}", auto intro: surj_imp_ordLeq simp: Func_empty)
  hence "|Func (Field p2) (Field p1)| \<le>o cone" by (simp add: Field_card_of cexp_def)
  hence "p1 ^c p2 \<le>o cone" unfolding cexp_def .
  thus ?thesis
  proof (cases "Field p2 = {}")
    case True
    with n have "Field r2 = {}" .
    hence "cone \<le>o r1 ^c r2" unfolding cone_def cexp_def Func_def
      by (auto intro: card_of_ordLeqI[where f="\<lambda>_ _. undefined"])
    thus ?thesis using `p1 ^c p2 \<le>o cone` ordLeq_transitive by auto
  next
    case False with True have "|Field (p1 ^c p2)| =o czero"
      unfolding card_of_ordIso_czero_iff_empty cexp_def Field_card_of Func_def by auto
    thus ?thesis unfolding cexp_def card_of_ordIso_czero_iff_empty Field_card_of
      by (simp add: card_of_empty)
  qed
next
  case False
  have 1: "|Field p1| \<le>o |Field r1|" and 2: "|Field p2| \<le>o |Field r2|"
    using 1 2 by (auto simp: card_of_mono2)
  obtain f1 where f1: "f1 ` Field r1 = Field p1"
    using 1 unfolding card_of_ordLeq2[OF False, symmetric] by auto
  obtain f2 where f2: "inj_on f2 (Field p2)" "f2 ` Field p2 \<subseteq> Field r2"
    using 2 unfolding card_of_ordLeq[symmetric] by blast
  have 0: "Func_map (Field p2) f1 f2 ` (Field (r1 ^c r2)) = Field (p1 ^c p2)"
    unfolding cexp_def Field_card_of using Func_map_surj[OF f1 f2 n, symmetric] .
  have 00: "Field (p1 ^c p2) \<noteq> {}" unfolding cexp_def Field_card_of Func_is_emp
    using False by simp
  show ?thesis
    using 0 card_of_ordLeq2[OF 00] unfolding cexp_def Field_card_of by blast
qed

lemma cexp_mono:
  assumes 1: "p1 \<le>o r1" and 2: "p2 \<le>o r2"
  and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
  shows "p1 ^c p2 \<le>o r1 ^c r2"
  by (rule cexp_mono'[OF 1 2 czeroE[OF n[OF czeroI[OF card]]]])

lemma cexp_mono1:
  assumes 1: "p1 \<le>o r1" and q: "Card_order q"
  shows "p1 ^c q \<le>o r1 ^c q"
using ordLeq_refl[OF q] by (rule cexp_mono[OF 1]) (auto simp: q)

lemma cexp_mono2':
  assumes 2: "p2 \<le>o r2" and q: "Card_order q"
  and n: "Field p2 = {} \<Longrightarrow> Field r2 = {}"
  shows "q ^c p2 \<le>o q ^c r2"
using ordLeq_refl[OF q] by (rule cexp_mono'[OF _ 2 n]) auto

lemma cexp_mono2:
  assumes 2: "p2 \<le>o r2" and q: "Card_order q"
  and n: "p2 =o czero \<Longrightarrow> r2 =o czero" and card: "Card_order p2"
  shows "q ^c p2 \<le>o q ^c r2"
using ordLeq_refl[OF q] by (rule cexp_mono[OF _ 2 n card]) auto

lemma cexp_mono2_Cnotzero:
  assumes "p2 \<le>o r2" "Card_order q" "Cnotzero p2"
  shows "q ^c p2 \<le>o q ^c r2"
using assms(3) czeroI by (blast intro: cexp_mono2'[OF assms(1,2)])

lemma cexp_cong:
  assumes 1: "p1 =o r1" and 2: "p2 =o r2"
  and Cr: "Card_order r2"
  and Cp: "Card_order p2"
  shows "p1 ^c p2 =o r1 ^c r2"
proof -
  obtain f where "bij_betw f (Field p2) (Field r2)"
    using 2 card_of_ordIso[of "Field p2" "Field r2"] card_of_cong by auto
  hence 0: "Field p2 = {} \<longleftrightarrow> Field r2 = {}" unfolding bij_betw_def by auto
  have r: "p2 =o czero \<Longrightarrow> r2 =o czero"
    and p: "r2 =o czero \<Longrightarrow> p2 =o czero"
     using 0 Cr Cp czeroE czeroI by auto
  show ?thesis using 0 1 2 unfolding ordIso_iff_ordLeq
    using r p cexp_mono[OF _ _ _ Cp] cexp_mono[OF _ _ _ Cr] by blast
qed

lemma cexp_cong1:
  assumes 1: "p1 =o r1" and q: "Card_order q"
  shows "p1 ^c q =o r1 ^c q"
by (rule cexp_cong[OF 1 _ q q]) (rule ordIso_refl[OF q])

lemma cexp_cong2:
  assumes 2: "p2 =o r2" and q: "Card_order q" and p: "Card_order p2"
  shows "q ^c p2 =o q ^c r2"
by (rule cexp_cong[OF _ 2]) (auto simp only: ordIso_refl Card_order_ordIso2[OF p 2] q p)

lemma cexp_cone:
  assumes "Card_order r"
  shows "r ^c cone =o r"
proof -
  have "r ^c cone =o |Field r|"
    unfolding cexp_def cone_def Field_card_of Func_empty
      card_of_ordIso[symmetric] bij_betw_def Func_def inj_on_def image_def
    by (rule exI[of _ "\<lambda>f. f ()"]) auto
  also have "|Field r| =o r" by (rule card_of_Field_ordIso[OF assms])
  finally show ?thesis .
qed

lemma cexp_cprod:
  assumes r1: "Card_order r1"
  shows "(r1 ^c r2) ^c r3 =o r1 ^c (r2 *c r3)" (is "?L =o ?R")
proof -
  have "?L =o r1 ^c (r3 *c r2)"
    unfolding cprod_def cexp_def Field_card_of
    using card_of_Func_Times by(rule ordIso_symmetric)
  also have "r1 ^c (r3 *c r2) =o ?R"
    apply(rule cexp_cong2) using cprod_com r1 by (auto simp: Card_order_cprod)
  finally show ?thesis .
qed

lemma cprod_infinite1': "\<lbrakk>Cinfinite r; Cnotzero p; p \<le>o r\<rbrakk> \<Longrightarrow> r *c p =o r"
unfolding cinfinite_def cprod_def
by (rule Card_order_Times_infinite[THEN conjunct1]) (blast intro: czeroI)+

lemma cprod_infinite: "Cinfinite r \<Longrightarrow> r *c r =o r"
using cprod_infinite1' Cinfinite_Cnotzero ordLeq_refl by blast

lemma cexp_cprod_ordLeq:
  assumes r1: "Card_order r1" and r2: "Cinfinite r2"
  and r3: "Cnotzero r3" "r3 \<le>o r2"
  shows "(r1 ^c r2) ^c r3 =o r1 ^c r2" (is "?L =o ?R")
proof-
  have "?L =o r1 ^c (r2 *c r3)" using cexp_cprod[OF r1] .
  also have "r1 ^c (r2 *c r3) =o ?R"
  apply(rule cexp_cong2)
  apply(rule cprod_infinite1'[OF r2 r3]) using r1 r2 by (fastforce simp: Card_order_cprod)+
  finally show ?thesis .
qed

lemma Cnotzero_UNIV: "Cnotzero |UNIV|"
by (auto simp: card_of_Card_order card_of_ordIso_czero_iff_empty)

lemma ordLess_ctwo_cexp:
  assumes "Card_order r"
  shows "r <o ctwo ^c r"
proof -
  have "r <o |Pow (Field r)|" using assms by (rule Card_order_Pow)
  also have "|Pow (Field r)| =o ctwo ^c r"
    unfolding ctwo_def cexp_def Field_card_of by (rule card_of_Pow_Func)
  finally show ?thesis .
qed

lemma ordLeq_cexp1:
  assumes "Cnotzero r" "Card_order q"
  shows "q \<le>o q ^c r"
proof (cases "q =o (czero :: 'a rel)")
  case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
next
  case False
  thus ?thesis
    apply -
    apply (rule ordIso_ordLeq_trans)
    apply (rule ordIso_symmetric)
    apply (rule cexp_cone)
    apply (rule assms(2))
    apply (rule cexp_mono2)
    apply (rule cone_ordLeq_Cnotzero)
    apply (rule assms(1))
    apply (rule assms(2))
    apply (rule notE)
    apply (rule cone_not_czero)
    apply assumption
    apply (rule Card_order_cone)
  done
qed

lemma ordLeq_cexp2:
  assumes "ctwo \<le>o q" "Card_order r"
  shows "r \<le>o q ^c r"
proof (cases "r =o (czero :: 'a rel)")
  case True thus ?thesis by (simp only: card_of_empty cexp_def czero_def ordIso_ordLeq_trans)
next
  case False thus ?thesis
    apply -
    apply (rule ordLess_imp_ordLeq)
    apply (rule ordLess_ordLeq_trans)
    apply (rule ordLess_ctwo_cexp)
    apply (rule assms(2))
    apply (rule cexp_mono1)
    apply (rule assms(1))
    apply (rule assms(2))
  done
qed

lemma cinfinite_cexp: "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> cinfinite (q ^c r)"
by (rule cinfinite_mono[OF ordLeq_cexp2]) simp_all

lemma Cinfinite_cexp:
  "\<lbrakk>ctwo \<le>o q; Cinfinite r\<rbrakk> \<Longrightarrow> Cinfinite (q ^c r)"
by (simp add: cinfinite_cexp Card_order_cexp)

lemma ctwo_ordLess_natLeq: "ctwo <o natLeq"
unfolding ctwo_def using finite_UNIV natLeq_cinfinite natLeq_Card_order
by (intro Cfinite_ordLess_Cinfinite) (auto simp: cfinite_def card_of_Card_order)

lemma ctwo_ordLess_Cinfinite: "Cinfinite r \<Longrightarrow> ctwo <o r"
by (rule ordLess_ordLeq_trans[OF ctwo_ordLess_natLeq natLeq_ordLeq_cinfinite])

lemma ctwo_ordLeq_Cinfinite:
  assumes "Cinfinite r"
  shows "ctwo \<le>o r"
by (rule ordLess_imp_ordLeq[OF ctwo_ordLess_Cinfinite[OF assms]])

lemma Un_Cinfinite_bound: "\<lbrakk>|A| \<le>o r; |B| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |A \<union> B| \<le>o r"
by (auto simp add: cinfinite_def card_of_Un_ordLeq_infinite_Field)

lemma UNION_Cinfinite_bound: "\<lbrakk>|I| \<le>o r; \<forall>i \<in> I. |A i| \<le>o r; Cinfinite r\<rbrakk> \<Longrightarrow> |\<Union>i \<in> I. A i| \<le>o r"
by (auto simp add: card_of_UNION_ordLeq_infinite_Field cinfinite_def)

lemma csum_cinfinite_bound:
  assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
  shows "p +c q \<le>o r"
proof -
  from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
    unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
  with assms show ?thesis unfolding cinfinite_def csum_def
    by (blast intro: card_of_Plus_ordLeq_infinite_Field)
qed

lemma cprod_cinfinite_bound:
  assumes "p \<le>o r" "q \<le>o r" "Card_order p" "Card_order q" "Cinfinite r"
  shows "p *c q \<le>o r"
proof -
  from assms(1-4) have "|Field p| \<le>o r" "|Field q| \<le>o r"
    unfolding card_order_on_def using card_of_least ordLeq_transitive by blast+
  with assms show ?thesis unfolding cinfinite_def cprod_def
    by (blast intro: card_of_Times_ordLeq_infinite_Field)
qed

lemma cprod_csum_cexp:
  "r1 *c r2 \<le>o (r1 +c r2) ^c ctwo"
unfolding cprod_def csum_def cexp_def ctwo_def Field_card_of
proof -
  let ?f = "\<lambda>(a, b). %x. if x then Inl a else Inr b"
  have "inj_on ?f (Field r1 \<times> Field r2)" (is "inj_on _ ?LHS")
    by (auto simp: inj_on_def fun_eq_iff split: bool.split)
  moreover
  have "?f ` ?LHS \<subseteq> Func (UNIV :: bool set) (Field r1 <+> Field r2)" (is "_ \<subseteq> ?RHS")
    by (auto simp: Func_def)
  ultimately show "|?LHS| \<le>o |?RHS|" using card_of_ordLeq by blast
qed

lemma Cfinite_cprod_Cinfinite: "\<lbrakk>Cfinite r; Cinfinite s\<rbrakk> \<Longrightarrow> r *c s \<le>o s"
by (intro cprod_cinfinite_bound)
  (auto intro: ordLeq_refl ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite])

lemma cprod_cexp: "(r *c s) ^c t =o r ^c t *c s ^c t"
  unfolding cprod_def cexp_def Field_card_of by (rule Func_Times_Range)

lemma cprod_cexp_csum_cexp_Cinfinite:
  assumes t: "Cinfinite t"
  shows "(r *c s) ^c t \<le>o (r +c s) ^c t"
proof -
  have "(r *c s) ^c t \<le>o ((r +c s) ^c ctwo) ^c t"
    by (rule cexp_mono1[OF cprod_csum_cexp conjunct2[OF t]])
  also have "((r +c s) ^c ctwo) ^c t =o (r +c s) ^c (ctwo *c t)"
    by (rule cexp_cprod[OF Card_order_csum])
  also have "(r +c s) ^c (ctwo *c t) =o (r +c s) ^c (t *c ctwo)"
    by (rule cexp_cong2[OF cprod_com Card_order_csum Card_order_cprod])
  also have "(r +c s) ^c (t *c ctwo) =o ((r +c s) ^c t) ^c ctwo"
    by (rule ordIso_symmetric[OF cexp_cprod[OF Card_order_csum]])
  also have "((r +c s) ^c t) ^c ctwo =o (r +c s) ^c t"
    by (rule cexp_cprod_ordLeq[OF Card_order_csum t ctwo_Cnotzero ctwo_ordLeq_Cinfinite[OF t]])
  finally show ?thesis .
qed

lemma Cfinite_cexp_Cinfinite:
  assumes s: "Cfinite s" and t: "Cinfinite t"
  shows "s ^c t \<le>o ctwo ^c t"
proof (cases "s \<le>o ctwo")
  case True thus ?thesis using t by (blast intro: cexp_mono1)
next
  case False
  hence "ctwo \<le>o s" using ordLeq_total[of s ctwo] Card_order_ctwo s
    by (auto intro: card_order_on_well_order_on)
  hence "Cnotzero s" using Cnotzero_mono[OF ctwo_Cnotzero] s by blast
  hence st: "Cnotzero (s *c t)" by (intro Cinfinite_Cnotzero[OF Cinfinite_cprod2]) (auto simp: t)
  have "s ^c t \<le>o (ctwo ^c s) ^c t"
    using assms by (blast intro: cexp_mono1 ordLess_imp_ordLeq[OF ordLess_ctwo_cexp])
  also have "(ctwo ^c s) ^c t =o ctwo ^c (s *c t)"
    by (blast intro: Card_order_ctwo cexp_cprod)
  also have "ctwo ^c (s *c t) \<le>o ctwo ^c t"
    using assms st by (intro cexp_mono2_Cnotzero Cfinite_cprod_Cinfinite Card_order_ctwo)
  finally show ?thesis .
qed

lemma csum_Cfinite_cexp_Cinfinite:
  assumes r: "Card_order r" and s: "Cfinite s" and t: "Cinfinite t"
  shows "(r +c s) ^c t \<le>o (r +c ctwo) ^c t"
proof (cases "Cinfinite r")
  case True
  hence "r +c s =o r" by (intro csum_absorb1 ordLess_imp_ordLeq[OF Cfinite_ordLess_Cinfinite] s)
  hence "(r +c s) ^c t =o r ^c t" using t by (blast intro: cexp_cong1)
  also have "r ^c t \<le>o (r +c ctwo) ^c t" using t by (blast intro: cexp_mono1 ordLeq_csum1 r)
  finally show ?thesis .
next
  case False
  with r have "Cfinite r" unfolding cinfinite_def cfinite_def by auto
  hence "Cfinite (r +c s)" by (intro Cfinite_csum s)
  hence "(r +c s) ^c t \<le>o ctwo ^c t" by (intro Cfinite_cexp_Cinfinite t)
  also have "ctwo ^c t \<le>o (r +c ctwo) ^c t" using t
    by (blast intro: cexp_mono1 ordLeq_csum2 Card_order_ctwo)
  finally show ?thesis .
qed

(* cardSuc *)

lemma Cinfinite_cardSuc: "Cinfinite r \<Longrightarrow> Cinfinite (cardSuc r)"
by (simp add: cinfinite_def cardSuc_Card_order cardSuc_finite)

lemma cardSuc_UNION_Cinfinite:
  assumes "Cinfinite r" "relChain (cardSuc r) As" "B \<le> (UN i : Field (cardSuc r). As i)" "|B| <=o r"
  shows "EX i : Field (cardSuc r). B \<le> As i"
using cardSuc_UNION assms unfolding cinfinite_def by blast

end


(* Title:      Algebras for Aggregation and Minimisation with a Linear Order
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Algebras for Aggregation and Minimisation with a Linear Order\<close>

text \<open>
This theory gives several classes of instances of linear aggregation lattices as described in \cite{Guttmann2018a}.
Each of these instances can be used as edge weights and the resulting graphs will form s-algebras and m-algebras as shown in a separate theory.
\<close>

theory Linear_Aggregation_Algebras

imports Matrix_Aggregation_Algebras HOL.Real

begin

no_notation
  inf (infixl "\<sqinter>" 70)
  and uminus ("- _" [81] 80)

subsection \<open>Linearly Ordered Commutative Semigroups\<close>

text \<open>
Any linearly ordered commutative semigroup extended by new least and greatest elements forms a linear aggregation lattice.
The extension is done so that the new least element is a unit of aggregation and the new greatest element is a zero of aggregation.
\<close>

datatype 'a ext =
    Bot
  | Val 'a
  | Top

instantiation ext :: (linordered_ab_semigroup_add) linear_aggregation_kleene_algebra
begin

fun plus_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "plus_ext Bot x = x"
| "plus_ext (Val x) Bot = Val x"
| "plus_ext (Val x) (Val y) = Val (x + y)"
| "plus_ext (Val _) Top = Top"
| "plus_ext Top _ = Top"

fun sup_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "sup_ext Bot x = x"
| "sup_ext (Val x) Bot = Val x"
| "sup_ext (Val x) (Val y) = Val (max x y)"
| "sup_ext (Val _) Top = Top"
| "sup_ext Top _ = Top"

fun inf_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "inf_ext Bot _ = Bot"
| "inf_ext (Val _) Bot = Bot"
| "inf_ext (Val x) (Val y) = Val (min x y)"
| "inf_ext (Val x) Top = Val x"
| "inf_ext Top x = x"

fun times_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where "times_ext x y = x \<sqinter> y"

fun uminus_ext :: "'a ext \<Rightarrow> 'a ext" where
  "uminus_ext Bot = Top"
| "uminus_ext (Val _) = Bot"
| "uminus_ext Top = Bot"

fun star_ext :: "'a ext \<Rightarrow> 'a ext" where "star_ext _ = Top"

fun conv_ext :: "'a ext \<Rightarrow> 'a ext" where "conv_ext x = x"

definition bot_ext :: "'a ext" where "bot_ext \<equiv> Bot"
definition one_ext :: "'a ext" where "one_ext \<equiv> Top"
definition top_ext :: "'a ext" where "top_ext \<equiv> Top"

fun less_eq_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> bool" where
  "less_eq_ext Bot _ = True"
| "less_eq_ext (Val _) Bot = False"
| "less_eq_ext (Val x) (Val y) = (x \<le> y)"
| "less_eq_ext (Val _) Top = True"
| "less_eq_ext Top Bot = False"
| "less_eq_ext Top (Val _) = False"
| "less_eq_ext Top Top = True"

fun less_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> bool" where "less_ext x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a ext"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    using less_eq_ext.elims(3) by fastforce
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_ext_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_ext_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_ext_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_ext_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_ext_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_ext_def top_ext_def)
  show "(1::'a ext) = top"
    by (simp add: one_ext_def top_ext_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_ext_def)
qed

end

text \<open>
An example of a linearly ordered commutative semigroup is the set of real numbers with standard addition as aggregation.
\<close>

lemma example_real_ext_matrix:
  fixes x :: "('a::enum,real ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

text \<open>
Another example of a linearly ordered commutative semigroup is the set of real numbers with maximum as aggregation.
\<close>

datatype real_max = Rmax real

instantiation real_max :: linordered_ab_semigroup_add
begin

fun less_eq_real_max where "less_eq_real_max (Rmax x) (Rmax y) = (x \<le> y)"
fun less_real_max where "less_real_max (Rmax x) (Rmax y) = (x < y)"
fun plus_real_max where "plus_real_max (Rmax x) (Rmax y) = Rmax (max x y)"

instance
proof
  fix x y z :: real_max
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp
  show "x + y = y + x"
    by (cases x; cases y) simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
qed

end

lemma example_real_max_ext_matrix:
  fixes x :: "('a::enum,real_max ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

text \<open>
A third example of a linearly ordered commutative semigroup is the set of real numbers with minimum as aggregation.
\<close>

datatype real_min = Rmin real

instantiation real_min :: linordered_ab_semigroup_add
begin

fun less_eq_real_min where "less_eq_real_min (Rmin x) (Rmin y) = (x \<le> y)"
fun less_real_min where "less_real_min (Rmin x) (Rmin y) = (x < y)"
fun plus_real_min where "plus_real_min (Rmin x) (Rmin y) = Rmin (min x y)"

instance
proof
  fix x y z :: real_min
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp
  show "x + y = y + x"
    by (cases x; cases y) simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
qed

end

lemma example_real_min_ext_matrix:
  fixes x :: "('a::enum,real_min ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

subsection \<open>Linearly Ordered Commutative Monoids\<close>

text \<open>
Any linearly ordered commutative monoid extended by new least and greatest elements forms a linear aggregation lattice.
This is similar to linearly ordered commutative semigroups except that the aggregation $\bot + \bot$ produces the unit of the monoid instead of the least element.
Applied to weighted graphs, this means that the aggregation of the empty graph will be the unit of the monoid (for example, $0$ for real numbers under standard addition, instead of $\bot$).
\<close>

class linordered_comm_monoid_add = linordered_ab_semigroup_add + comm_monoid_add

datatype 'a ext0 =
    Bot
  | Val 'a
  | Top

instantiation ext0 :: (linordered_comm_monoid_add) linear_aggregation_kleene_algebra
begin

fun plus_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "plus_ext0 Bot Bot = Val 0"
| "plus_ext0 Bot x = x"
| "plus_ext0 (Val x) Bot = Val x"
| "plus_ext0 (Val x) (Val y) = Val (x + y)"
| "plus_ext0 (Val _) Top = Top"
| "plus_ext0 Top _ = Top"

fun sup_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "sup_ext0 Bot x = x"
| "sup_ext0 (Val x) Bot = Val x"
| "sup_ext0 (Val x) (Val y) = Val (max x y)"
| "sup_ext0 (Val _) Top = Top"
| "sup_ext0 Top _ = Top"

fun inf_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "inf_ext0 Bot _ = Bot"
| "inf_ext0 (Val _) Bot = Bot"
| "inf_ext0 (Val x) (Val y) = Val (min x y)"
| "inf_ext0 (Val x) Top = Val x"
| "inf_ext0 Top x = x"

fun times_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where "times_ext0 x y = x \<sqinter> y"

fun uminus_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where
  "uminus_ext0 Bot = Top"
| "uminus_ext0 (Val _) = Bot"
| "uminus_ext0 Top = Bot"

fun star_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where "star_ext0 _ = Top"

fun conv_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where "conv_ext0 x = x"

definition bot_ext0 :: "'a ext0" where "bot_ext0 \<equiv> Bot"
definition one_ext0 :: "'a ext0" where "one_ext0 \<equiv> Top"
definition top_ext0 :: "'a ext0" where "top_ext0 \<equiv> Top"

fun less_eq_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> bool" where
  "less_eq_ext0 Bot _ = True"
| "less_eq_ext0 (Val _) Bot = False"
| "less_eq_ext0 (Val x) (Val y) = (x \<le> y)"
| "less_eq_ext0 (Val _) Top = True"
| "less_eq_ext0 Top Bot = False"
| "less_eq_ext0 Top (Val _) = False"
| "less_eq_ext0 Top Top = True"

fun less_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> bool" where "less_ext0 x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a ext0"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    using less_eq_ext0.elims(3) by fastforce
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_ext0_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_ext0_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    apply (cases x; cases y; cases z)
    prefer 11 using add_right_mono bot_ext0_def apply fastforce
    by (simp_all add: bot_ext0_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_ext0_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_ext0_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_ext0_def top_ext0_def)
  show "(1::'a ext0) = top"
    by (simp add: one_ext0_def top_ext0_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_ext0_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid is the set of real numbers with standard addition and unit $0$.
\<close>

instantiation real :: linordered_comm_monoid_add
begin

instance ..

end

subsection \<open>Linearly Ordered Commutative Monoids with a Least Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a least element which is a unit of aggregation, only a new greatest element has to be added to obtain a linear aggregation lattice.
\<close>

class linordered_comm_monoid_add_bot = linordered_ab_semigroup_add + order_bot +
  assumes bot_zero [simp]: "bot + x = x"
begin

sublocale linordered_comm_monoid_add where zero = bot
  apply unfold_locales
  by simp

end

datatype 'a extT =
    Val 'a
  | Top

instantiation extT :: (linordered_comm_monoid_add_bot) linear_aggregation_kleene_algebra
begin

fun plus_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "plus_extT (Val x) (Val y) = Val (x + y)"
| "plus_extT (Val _) Top = Top"
| "plus_extT Top _ = Top"

fun sup_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "sup_extT (Val x) (Val y) = Val (max x y)"
| "sup_extT (Val _) Top = Top"
| "sup_extT Top _ = Top"

fun inf_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "inf_extT (Val x) (Val y) = Val (min x y)"
| "inf_extT (Val x) Top = Val x"
| "inf_extT Top x = x"

fun times_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where "times_extT x y = x \<sqinter> y"

fun uminus_extT :: "'a extT \<Rightarrow> 'a extT" where "uminus_extT x = (if x = Val bot then Top else Val bot)"

fun star_extT :: "'a extT \<Rightarrow> 'a extT" where "star_extT _ = Top"

fun conv_extT :: "'a extT \<Rightarrow> 'a extT" where "conv_extT x = x"

definition bot_extT :: "'a extT" where "bot_extT \<equiv> Val bot"
definition one_extT :: "'a extT" where "one_extT \<equiv> Top"
definition top_extT :: "'a extT" where "top_extT \<equiv> Top"

fun less_eq_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> bool" where
  "less_eq_extT (Val x) (Val y) = (x \<le> y)"
| "less_eq_extT Top (Val _) = False"
| "less_eq_extT _ Top = True"

fun less_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> bool" where "less_extT x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extT"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (cases x) (simp_all add: bot_extT_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extT_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_extT_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extT_def)
  show "x + y = bot \<longrightarrow> x = bot"
    apply (cases x; cases y)
    apply (metis (mono_tags) add.commute add_right_mono bot.extremum bot.extremum_uniqueI bot_zero extT.inject plus_extT.simps(1) bot_extT_def)
    by (simp_all add: bot_extT_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extT_def top_extT_def)
  show "(1::'a extT) = top"
    by (simp add: one_extT_def top_extT_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extT_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid with a least element is the set of real numbers extended by minus infinity with maximum as aggregation.
\<close>

datatype real_max_bot =
    MInfty
  | R real

instantiation real_max_bot :: linordered_comm_monoid_add_bot
begin

definition "bot_real_max_bot \<equiv> MInfty"

fun less_eq_real_max_bot where
  "less_eq_real_max_bot MInfty _ = True"
| "less_eq_real_max_bot (R _) MInfty = False"
| "less_eq_real_max_bot (R x) (R y) = (x \<le> y)"

fun less_real_max_bot where
  "less_real_max_bot _ MInfty = False"
| "less_real_max_bot MInfty (R _) = True"
| "less_real_max_bot (R x) (R y) = (x < y)"

fun plus_real_max_bot where
  "plus_real_max_bot MInfty y = y"
| "plus_real_max_bot x MInfty = x"
| "plus_real_max_bot (R x) (R y) = R (max x y)"

instance
proof
  fix x y z :: real_max_bot
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
  show "bot \<le> x"
    by (cases x) (simp_all add: bot_real_max_bot_def)
  show "bot + x = x"
    by (cases x) (simp_all add: bot_real_max_bot_def)
qed

end

subsection \<open>Linearly Ordered Commutative Monoids with a Greatest Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a greatest element which is a unit of aggregation, only a new least element has to be added to obtain a linear aggregation lattice.
\<close>

class linordered_comm_monoid_add_top = linordered_ab_semigroup_add + order_top +
  assumes top_zero [simp]: "top + x = x"
begin

sublocale linordered_comm_monoid_add where zero = top
  apply unfold_locales
  by simp

lemma add_decreasing: "x + y \<le> x"
  using add_left_mono top.extremum by fastforce

end

datatype 'a extB =
    Bot
  | Val 'a

instantiation extB :: (linordered_comm_monoid_add_top) linear_aggregation_kleene_algebra
begin

fun plus_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "plus_extB Bot Bot = Val top"
| "plus_extB Bot (Val x) = Val x"
| "plus_extB (Val x) Bot = Val x"
| "plus_extB (Val x) (Val y) = Val (x + y)"

fun sup_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "sup_extB Bot x = x"
| "sup_extB (Val x) Bot = Val x"
| "sup_extB (Val x) (Val y) = Val (max x y)"

fun inf_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "inf_extB Bot _ = Bot"
| "inf_extB (Val _) Bot = Bot"
| "inf_extB (Val x) (Val y) = Val (min x y)"

fun times_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where "times_extB x y = x \<sqinter> y"

fun uminus_extB :: "'a extB \<Rightarrow> 'a extB" where
  "uminus_extB Bot = Val top"
| "uminus_extB (Val _) = Bot"

fun star_extB :: "'a extB \<Rightarrow> 'a extB" where "star_extB _ = Val top"

fun conv_extB :: "'a extB \<Rightarrow> 'a extB" where "conv_extB x = x"

definition bot_extB :: "'a extB" where "bot_extB \<equiv> Bot"
definition one_extB :: "'a extB" where "one_extB \<equiv> Val top"
definition top_extB :: "'a extB" where "top_extB \<equiv> Val top"

fun less_eq_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> bool" where
  "less_eq_extB Bot _ = True"
| "less_eq_extB (Val _) Bot = False"
| "less_eq_extB (Val x) (Val y) = (x \<le> y)"

fun less_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> bool" where "less_extB x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extB"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extB_def)
  show 1: "x \<le> top"
    by (cases x) (simp_all add: top_extB_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    apply (cases x; cases y; cases z)
    prefer 6 using 1 apply (metis (mono_tags, lifting) plus_extB.simps(2,4) top_extB_def add_right_mono less_eq_extB.simps(3) top_zero)
    by (simp_all add: bot_extB_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extB_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_extB_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extB_def top_extB_def)
  show "(1::'a extB) = top"
    by (simp add: one_extB_def top_extB_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extB_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid with a greatest element is the set of real numbers extended by infinity with minimum as aggregation.
\<close>

datatype real_min_top =
    R real
  | PInfty

instantiation real_min_top :: linordered_comm_monoid_add_top
begin

definition "top_real_min_top \<equiv> PInfty"

fun less_eq_real_min_top where
  "less_eq_real_min_top _ PInfty = True"
| "less_eq_real_min_top PInfty (R _) = False"
| "less_eq_real_min_top (R x) (R y) = (x \<le> y)"

fun less_real_min_top where
  "less_real_min_top PInfty _ = False"
| "less_real_min_top (R _) PInfty = True"
| "less_real_min_top (R x) (R y) = (x < y)"

fun plus_real_min_top where
  "plus_real_min_top PInfty y = y"
| "plus_real_min_top x PInfty = x"
| "plus_real_min_top (R x) (R y) = R (min x y)"

instance
proof
  fix x y z :: real_min_top
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
  show "x \<le> top"
    by (cases x) (simp_all add: top_real_min_top_def)
  show "top + x = x"
    by (cases x) (simp_all add: top_real_min_top_def)
qed

end

text \<open>
Another example of a linearly ordered commutative monoid with a greatest element is the unit interval of real numbers with any triangular norm (t-norm) as aggregation.
Ideally, we would like to show that the unit interval is an instance of \<open>linordered_comm_monoid_add_top\<close>.
However, this class has an addition operation, so the instantiation would require dependent types.
We therefore show only the order property in general and a particular instance of the class.
\<close>

typedef (overloaded) unit = "{0..1} :: real set"
  by auto

setup_lifting type_definition_unit

instantiation unit :: bounded_linorder
begin

lift_definition bot_unit :: unit is 0
  by simp

lift_definition top_unit :: unit is 1
  by simp

lift_definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool" is less_eq .

lift_definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool" is less .

instance
  apply intro_classes
  using bot_unit.rep_eq top_unit.rep_eq less_eq_unit.rep_eq less_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit by auto

end

text \<open>
We give the \L{}ukasiewicz t-norm as a particular instance.
\<close>

instantiation unit :: linordered_comm_monoid_add_top
begin

abbreviation tl :: "real \<Rightarrow> real \<Rightarrow> real" where
  "tl x y \<equiv> max (x + y - 1) 0"

lemma tl_assoc:
  "x \<in> {0..1} \<Longrightarrow> z \<in> {0..1} \<Longrightarrow> tl (tl x y) z = tl x (tl y z)"
  by auto

lemma tl_top_zero:
  "x \<in> {0..1} \<Longrightarrow> tl 1 x = x"
  by auto

lift_definition plus_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit" is tl
  by simp

instance
  apply intro_classes
  apply (metis (mono_tags, lifting) plus_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit tl_assoc)
  using unit.Rep_unit_inject plus_unit.rep_eq apply fastforce
  apply (simp add: less_eq_unit.rep_eq plus_unit.rep_eq)
  by (metis (mono_tags, lifting) top_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit plus_unit.rep_eq tl_top_zero)

end

subsection \<open>Linearly Ordered Commutative Monoids with a Least Element and a Greatest Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a least element which is a unit of aggregation and a greatest element, it forms a linear aggregation lattice.
\<close>

class linordered_bounded_comm_monoid_add_bot = linordered_comm_monoid_add_bot + order_top
begin

subclass bounded_linorder ..

subclass aggregation_order
  apply unfold_locales
  apply (simp add: add_right_mono)
  apply simp
  by (metis add_0_right add_left_mono bot.extremum bot.extremum_unique)

sublocale linear_aggregation_kleene_algebra where sup = max and inf = min and times = min and conv = id and one = top and star = "\<lambda>x . top" and uminus = "\<lambda>x . if x = bot then top else bot"
  apply unfold_locales
  by simp_all

lemma t_top: "x + top = top"
  by (metis add_right_mono bot.extremum bot_zero top_unique)

lemma add_increasing: "x \<le> x + y"
  using add_left_mono bot.extremum by fastforce

lemma t_max: "max x y \<le> x + y"
  using add_commute add_increasing by force

end

text \<open>
An example of a linearly ordered commutative monoid with a least and a greatest element is the unit interval of real numbers with any triangular conorm (t-conorm) as aggregation.
For the reason outlined above, we show just a particular instance of \<open>linordered_bounded_comm_monoid_add_bot\<close>.
Because the \<open>plus\<close> functions in the two instances given for the unit type are different, we work on a copy of the unit type.
\<close>

typedef (overloaded) unit2 = "{0..1} :: real set"
  by auto

setup_lifting type_definition_unit2

instantiation unit2 :: bounded_linorder
begin

lift_definition bot_unit2 :: unit2 is 0
  by simp

lift_definition top_unit2 :: unit2 is 1
  by simp

lift_definition less_eq_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> bool" is less_eq .

lift_definition less_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> bool" is less .

instance
  apply intro_classes
  using bot_unit2.rep_eq top_unit2.rep_eq less_eq_unit2.rep_eq less_unit2.rep_eq unit2.Rep_unit2_inject unit2.Rep_unit2 by auto

end

text \<open>
We give the product t-conorm as a particular instance.
\<close>

instantiation unit2 :: linordered_bounded_comm_monoid_add_bot
begin

abbreviation sp :: "real \<Rightarrow> real \<Rightarrow> real" where
  "sp x y \<equiv> x + y - x * y"

lemma sp_assoc:
  "sp (sp x y) z = sp x (sp y z)"
  by (unfold left_diff_distrib right_diff_distrib distrib_left distrib_right) simp

lemma sp_mono:
  assumes "z \<in> {0..1}"
      and "x \<le> y"
    shows "sp z x \<le> sp z y"
proof -
  have "z + (1 - z) * x \<le> z + (1 - z) * y"
    using assms mult_left_mono by fastforce
  thus ?thesis
    by (unfold left_diff_distrib right_diff_distrib distrib_left distrib_right) simp
qed

lift_definition plus_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> unit2" is sp
proof -
  fix x y :: real
  assume 1: "x \<in> {0..1}"
  assume 2: "y \<in> {0..1}"
  have "x - x * y \<le> 1 - y"
    using 1 2 by (metis (full_types) atLeastAtMost_iff diff_ge_0_iff_ge left_diff_distrib' mult.commute mult.left_neutral mult_left_le)
  hence 3: "x + y - x * y \<le> 1"
    by simp
  have "y * (x - 1) \<le> 0"
    using 1 2 by (meson atLeastAtMost_iff le_iff_diff_le_0 mult_nonneg_nonpos)
  hence "x + y - x * y \<ge> 0"
    using 1 by (metis (no_types) atLeastAtMost_iff diff_diff_eq2 diff_ge_0_iff_ge left_diff_distrib mult.commute mult.left_neutral order_trans)
  thus "x + y - x * y \<in> {0..1}"
    using 3 by simp
qed

instance
  apply intro_classes
  apply (metis (mono_tags, lifting) plus_unit2.rep_eq unit2.Rep_unit2_inject sp_assoc)
  using unit2.Rep_unit2_inject plus_unit2.rep_eq apply fastforce
  using sp_mono unit2.Rep_unit2 less_eq_unit2.rep_eq plus_unit2.rep_eq apply simp
  using bot_unit2.rep_eq unit2.Rep_unit2_inject plus_unit2.rep_eq by fastforce

end

subsection \<open>Constant Aggregation\<close>

text \<open>
Any linear order with a constant element extended by new least and greatest elements forms a linear aggregation lattice where the aggregation returns the given constant.
\<close>

class pointed_linorder = linorder +
  fixes const :: 'a

datatype 'a extC =
    Bot
  | Val 'a
  | Top

instantiation extC :: (pointed_linorder) linear_aggregation_kleene_algebra
begin

fun plus_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where "plus_extC x y = Val const"

fun sup_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where
  "sup_extC Bot x = x"
| "sup_extC (Val x) Bot = Val x"
| "sup_extC (Val x) (Val y) = Val (max x y)"
| "sup_extC (Val _) Top = Top"
| "sup_extC Top _ = Top"

fun inf_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where
  "inf_extC Bot _ = Bot"
| "inf_extC (Val _) Bot = Bot"
| "inf_extC (Val x) (Val y) = Val (min x y)"
| "inf_extC (Val x) Top = Val x"
| "inf_extC Top x = x"

fun times_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where "times_extC x y = x \<sqinter> y"

fun uminus_extC :: "'a extC \<Rightarrow> 'a extC" where
  "uminus_extC Bot = Top"
| "uminus_extC (Val _) = Bot"
| "uminus_extC Top = Bot"

fun star_extC :: "'a extC \<Rightarrow> 'a extC" where "star_extC _ = Top"

fun conv_extC :: "'a extC \<Rightarrow> 'a extC" where "conv_extC x = x"

definition bot_extC :: "'a extC" where "bot_extC \<equiv> Bot"
definition one_extC :: "'a extC" where "one_extC \<equiv> Top"
definition top_extC :: "'a extC" where "top_extC \<equiv> Top"

fun less_eq_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> bool" where
  "less_eq_extC Bot _ = True"
| "less_eq_extC (Val _) Bot = False"
| "less_eq_extC (Val x) (Val y) = (x \<le> y)"
| "less_eq_extC (Val _) Top = True"
| "less_eq_extC Top Bot = False"
| "less_eq_extC Top (Val _) = False"
| "less_eq_extC Top Top = True"

fun less_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> bool" where "less_extC x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extC"
  show "(x + y) + z = x + (y + z)"
    by simp
  show "x + y = y + x"
    by simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extC_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extC_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by simp
  show "x + y + bot = x + y"
    by simp
  show "x + y = bot \<longrightarrow> x = bot"
    by (simp add: bot_extC_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extC_def top_extC_def)
  show "(1::'a extC) = top"
    by (simp add: one_extC_def top_extC_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extC_def)
qed

end

text \<open>
An example of a linear order is the set of real numbers.
Any real number can be chosen as the constant.
\<close>

instantiation real :: pointed_linorder
begin

instance ..

end

text \<open>
The following instance shows that any linear order with a constant forms a linearly ordered commutative semigroup with the alpha-median operation as aggregation.
The alpha-median of two elements is the median of these elements and the given constant.
\<close>

fun median3 :: "'a::ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "median3 x y z =
    (if x \<le> y \<and> y \<le> z then y else
     if x \<le> z \<and> z \<le> y then z else
     if y \<le> x \<and> x \<le> z then x else
     if y \<le> z \<and> z \<le> x then z else
     if z \<le> x \<and> x \<le> y then x else y)"

interpretation alpha_median: linordered_ab_semigroup_add where plus = "median3 const" and less_eq = less_eq and less = less
proof
  fix a b c :: 'a
  show "median3 const (median3 const a b) c = median3 const a (median3 const b c)"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "const \<le> c"; cases "a \<le> b"; cases "a \<le> c"; cases "b \<le> c") auto
  show "median3 const a b = median3 const b a"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "a \<le> b") auto
  assume "a \<le> b"
  thus "median3 const c a \<le> median3 const c b"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "const \<le> c"; cases "a \<le> c"; cases "b \<le> c") auto
qed

subsection \<open>Counting Aggregation\<close>

text \<open>
Any linear order extended by new least and greatest elements and a copy of the natural numbers forms a linear aggregation lattice where the aggregation counts non-$\bot$ elements using the copy of the natural numbers.
\<close>

datatype 'a extN =
    Bot
  | Val 'a
  | N nat
  | Top

instantiation extN :: (linorder) linear_aggregation_kleene_algebra
begin

fun plus_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "plus_extN Bot Bot = N 0"
| "plus_extN Bot (Val _) = N 1"
| "plus_extN Bot (N y) = N y"
| "plus_extN Bot Top = N 1"
| "plus_extN (Val _) Bot = N 1"
| "plus_extN (Val _) (Val _) = N 2"
| "plus_extN (Val _) (N y) = N (y + 1)"
| "plus_extN (Val _) Top = N 2"
| "plus_extN (N x) Bot = N x"
| "plus_extN (N x) (Val _) = N (x + 1)"
| "plus_extN (N x) (N y) = N (x + y)"
| "plus_extN (N x) Top = N (x + 1)"
| "plus_extN Top Bot = N 1"
| "plus_extN Top (Val _) = N 2"
| "plus_extN Top (N y) = N (y + 1)"
| "plus_extN Top Top = N 2"

fun sup_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "sup_extN Bot x = x"
| "sup_extN (Val x) Bot = Val x"
| "sup_extN (Val x) (Val y) = Val (max x y)"
| "sup_extN (Val _) (N y) = N y"
| "sup_extN (Val _) Top = Top"
| "sup_extN (N x) Bot = N x"
| "sup_extN (N x) (Val _) = N x"
| "sup_extN (N x) (N y) = N (max x y)"
| "sup_extN (N _) Top = Top"
| "sup_extN Top _ = Top"

fun inf_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "inf_extN Bot _ = Bot"
| "inf_extN (Val _) Bot = Bot"
| "inf_extN (Val x) (Val y) = Val (min x y)"
| "inf_extN (Val x) (N _) = Val x"
| "inf_extN (Val x) Top = Val x"
| "inf_extN (N _) Bot = Bot"
| "inf_extN (N _) (Val y) = Val y"
| "inf_extN (N x) (N y) = N (min x y)"
| "inf_extN (N x) Top = N x"
| "inf_extN Top y = y"

fun times_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where "times_extN x y = x \<sqinter> y"

fun uminus_extN :: "'a extN \<Rightarrow> 'a extN" where
  "uminus_extN Bot = Top"
| "uminus_extN (Val _) = Bot"
| "uminus_extN (N _) = Bot"
| "uminus_extN Top = Bot"

fun star_extN :: "'a extN \<Rightarrow> 'a extN" where "star_extN _ = Top"

fun conv_extN :: "'a extN \<Rightarrow> 'a extN" where "conv_extN x = x"

definition bot_extN :: "'a extN" where "bot_extN \<equiv> Bot"
definition one_extN :: "'a extN" where "one_extN \<equiv> Top"
definition top_extN :: "'a extN" where "top_extN \<equiv> Top"

fun less_eq_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> bool" where
  "less_eq_extN Bot _ = True"
| "less_eq_extN (Val _) Bot = False"
| "less_eq_extN (Val x) (Val y) = (x \<le> y)"
| "less_eq_extN (Val _) (N _) = True"
| "less_eq_extN (Val _) Top = True"
| "less_eq_extN (N _) Bot = False"
| "less_eq_extN (N _) (Val _) = False"
| "less_eq_extN (N x) (N y) = (x \<le> y)"
| "less_eq_extN (N _) Top = True"
| "less_eq_extN Top Bot = False"
| "less_eq_extN Top (Val _) = False"
| "less_eq_extN Top (N _) = False"
| "less_eq_extN Top Top = True"

fun less_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> bool" where "less_extN x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extN"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extN_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extN_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_extN_def)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extN_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_extN_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extN_def top_extN_def)
  show "(1::'a extN) = top"
    by (simp add: one_extN_def top_extN_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extN_def)
qed

end

end