(* Walter Guttmann, 2015.06.16 *)

theory AACP

imports Main

begin

(*
theory Base

imports Main

begin
*)

-- {* This theory and the subsequent theories have been developed with Isabelle2014. *}

nitpick_params [ timeout = 600 ]

declare [[ smt_timeout = 600 ]]

class mult = times

begin

notation
  times (infixl "\<cdot>" 70) and
  times (infixl ";" 70)

end

class neg = uminus

begin

no_notation
  uminus ("- _" [81] 80)

notation
  uminus ("- _" [80] 80)

end

class while =
  fixes while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<star>" 59)

class L =
  fixes L :: "'a"

class n =
  fixes n :: "'a \<Rightarrow> 'a"

class d =
  fixes d :: "'a \<Rightarrow> 'a"

class diamond =
  fixes diamond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ > _" [50,90] 95)

class box =
  fixes box :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("| _ ] _" [50,90] 95)

context ord

begin

definition isotone :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "isotone f \<longleftrightarrow> (\<forall>x y . x \<le> y \<longrightarrow> f(x) \<le> f(y))"

definition lifted_less_eq :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("(_ \<le>\<le> _)" [51, 51] 50)
  where "f \<le>\<le> g \<longleftrightarrow> (\<forall>x . f(x) \<le> g(x))"

definition galois :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "galois l u \<longleftrightarrow> (\<forall>x y . l(x) \<le> y \<longleftrightarrow> x \<le> u(y))"

definition ascending_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "ascending_chain f \<longleftrightarrow> (\<forall>n . f n \<le> f (Suc n))"

definition descending_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "descending_chain f \<longleftrightarrow> (\<forall>n . f (Suc n) \<le> f n)"

definition directed :: "'a set \<Rightarrow> bool"
  where "directed X \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>x\<in>X . \<forall>y\<in>X . \<exists>z\<in>X . x \<le> z \<and> y \<le> z)"

definition codirected :: "'a set \<Rightarrow> bool"
  where "codirected X \<longleftrightarrow> X \<noteq> {} \<and> (\<forall>x\<in>X . \<forall>y\<in>X . \<exists>z\<in>X . z \<le> x \<and> z \<le> y)"

definition chain :: "'a set \<Rightarrow> bool"
  where "chain X \<longleftrightarrow> (\<forall>x\<in>X . \<forall>y\<in>X . x \<le> y \<or> y \<le> x)"

end

context order

begin

lemma lifted_reflexive: "f = g \<longrightarrow> f \<le>\<le> g"
  by (metis lifted_less_eq_def order_refl)

lemma lifted_transitive: "f \<le>\<le> g \<and> g \<le>\<le> h \<longrightarrow> f \<le>\<le> h"
  by (smt lifted_less_eq_def order_trans)

lemma lifted_antisymmetric: "f \<le>\<le> g \<and> g \<le>\<le> f \<longrightarrow> f = g"
  by (metis (full_types) antisym ext lifted_less_eq_def)

lemma galois_char: "galois l u \<longleftrightarrow> (\<forall>x . x \<le> u(l(x))) \<and> (\<forall>x . l(u(x)) \<le> x) \<and> isotone l \<and> isotone u"
  apply (rule iffI)
  apply (metis (full_types) galois_def isotone_def order_refl order_trans)
  apply (metis galois_def isotone_def order_trans)
  done

lemma galois_closure: "galois l u \<longrightarrow> l(x) = l(u(l(x))) \<and> u(x) = u(l(u(x)))"
  by (smt antisym galois_char isotone_def)

lemma ascending_chain_k: "ascending_chain f \<longrightarrow> f m \<le> f (m + k)"
  apply (induct k)
  apply simp
  apply (metis add_Suc_right ascending_chain_def order_trans)
  done

lemma ascending_chain_isotone: "ascending_chain f \<and> m \<le> k \<longrightarrow> f m \<le> f k"
  by (metis ascending_chain_k le_iff_add)

lemma ascending_chain_comparable: "ascending_chain f \<longrightarrow> f k \<le> f m \<or> f m \<le> f k"
  by (metis nat_le_linear ascending_chain_isotone)

lemma ascending_chain_chain: "ascending_chain f \<longrightarrow> chain (range f)"
  by (smt ascending_chain_comparable chain_def image_iff)

lemma chain_directed: "X \<noteq> {} \<and> chain X \<longrightarrow> directed X"
  by (metis chain_def directed_def)

lemma ascending_chain_directed: "ascending_chain f \<longrightarrow> directed (range f)"
  by (metis UNIV_not_empty ascending_chain_chain chain_directed empty_is_image)

lemma descending_chain_k: "descending_chain f \<longrightarrow> f (m + k) \<le> f m"
  apply (induct k)
  apply simp
  apply (metis add_Suc_right descending_chain_def order_trans)
  done

lemma descending_chain_antitone: "descending_chain f \<and> m \<le> k \<longrightarrow> f k \<le> f m"
  by (metis descending_chain_k le_iff_add)

lemma descending_chain_comparable: "descending_chain f \<longrightarrow> f k \<le> f m \<or> f m \<le> f k"
  by (metis nat_le_linear descending_chain_antitone)

lemma descending_chain_chain: "descending_chain f \<longrightarrow> chain (range f)"
  unfolding chain_def
  apply simp
  apply (smt descending_chain_comparable)
  done

lemma chain_codirected: "X \<noteq> {} \<and> chain X \<longrightarrow> codirected X"
  by (metis chain_def codirected_def)

lemma descending_chain_codirected: "descending_chain f \<longrightarrow> codirected (range f)"
  by (metis UNIV_not_empty descending_chain_chain chain_codirected empty_is_image)

end

context complete_lattice

begin

lemma sup_Sup: assumes nonempty: "A \<noteq> {}"
   shows "sup x (Sup A) = Sup ((sup x) ` A)"
  apply (rule antisym)
  apply (metis Sup_mono Sup_upper2 assms ex_in_conv imageI le_supI sup_ge1 sup_ge2)
  apply (smt Sup_least Sup_upper image_iff le_iff_sup sup.commute sup_ge1 sup_left_commute)
  done

lemma sup_SUP: "Y \<noteq> {} \<longrightarrow> sup x (SUP y:Y . f y) = (SUP y:Y. sup x (f y))"
  unfolding SUP_def
  apply rule
  apply (subst sup_Sup)
  apply (smt empty_is_image)
  apply (metis image_image)
  done

lemma inf_Inf: assumes nonempty: "A \<noteq> {}"
   shows "inf x (Inf A) = Inf ((inf x) ` A)"
  apply (rule antisym)
  apply (smt Inf_greatest Inf_lower image_iff le_iff_inf inf.commute inf_le1 inf_left_commute)
  apply (metis Inf_mono Inf_lower2 assms ex_in_conv imageI le_infI inf_le1 inf_le2)
  done

lemma inf_INF: "Y \<noteq> {} \<longrightarrow> inf x (INF y:Y . f y) = (INF y:Y. inf x (f y))"
  unfolding INF_def
  apply rule
  apply (subst inf_Inf)
  apply (smt empty_is_image)
  apply (metis image_image)
  done

lemma SUP_image_id[simp]: "(SUP x:f`A . x) = (SUP x:A . f x)"
  by simp

lemma INF_image_id[simp]: "(INF x:f`A . x) = (INF x:A . f x)"
  by simp

end

lemma image_Collect_2: "f ` { g x | x . P x } = { f (g x) | x . P x }"
  by auto

-- {* The following instantiation and four lemmas are from Jose Divason Mallagaray. *}

instantiation "fun" :: (type, type) power

begin

definition one_fun :: "'a \<Rightarrow> 'a"
  where one_fun_def: "one_fun \<equiv> id"

definition times_fun :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where times_fun_def: "times_fun \<equiv> comp"

instance
  by intro_classes

end

lemma id_power: "id^m = id"
  apply (induct m)
  apply (metis one_fun_def power_0)
  apply (simp add: times_fun_def)
  done

lemma power_zero_id: "f^0 = id"
  by (metis one_fun_def power_0)

lemma power_succ_unfold: "f^Suc m = f \<circ> f^m"
  by (metis power_Suc times_fun_def)

lemma power_succ_unfold_ext: "(f^Suc m) x = f ((f^m) x)"
  by (metis o_apply power_succ_unfold)

(*
end


theory Fixpoint

imports Base

begin
*)

context order

begin

definition is_fixpoint               :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_fixpoint              f x \<longleftrightarrow> f(x) = x"
definition is_prefixpoint            :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_prefixpoint           f x \<longleftrightarrow> f(x) \<le> x"
definition is_postfixpoint           :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_postfixpoint          f x \<longleftrightarrow> f(x) \<ge> x"
definition is_least_fixpoint         :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_least_fixpoint        f x \<longleftrightarrow> f(x) = x \<and> (\<forall>y . f(y) = y \<longrightarrow> x \<le> y)"
definition is_greatest_fixpoint      :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_greatest_fixpoint     f x \<longleftrightarrow> f(x) = x \<and> (\<forall>y . f(y) = y \<longrightarrow> x \<ge> y)"
definition is_least_prefixpoint      :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_least_prefixpoint     f x \<longleftrightarrow> f(x) \<le> x \<and> (\<forall>y . f(y) \<le> y \<longrightarrow> x \<le> y)"
definition is_greatest_postfixpoint  :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool" where "is_greatest_postfixpoint f x \<longleftrightarrow> f(x) \<ge> x \<and> (\<forall>y . f(y) \<ge> y \<longrightarrow> x \<ge> y)"
definition has_fixpoint              :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_fixpoint              f \<longleftrightarrow> (\<exists>x . is_fixpoint f x)"
definition has_prefixpoint           :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_prefixpoint           f \<longleftrightarrow> (\<exists>x . is_prefixpoint f x)"
definition has_postfixpoint          :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_postfixpoint          f \<longleftrightarrow> (\<exists>x . is_postfixpoint f x)"
definition has_least_fixpoint        :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_least_fixpoint        f \<longleftrightarrow> (\<exists>x . is_least_fixpoint f x)"
definition has_greatest_fixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_greatest_fixpoint     f \<longleftrightarrow> (\<exists>x . is_greatest_fixpoint f x)"
definition has_least_prefixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_least_prefixpoint     f \<longleftrightarrow> (\<exists>x . is_least_prefixpoint f x)"
definition has_greatest_postfixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where "has_greatest_postfixpoint f \<longleftrightarrow> (\<exists>x . is_greatest_postfixpoint f x)"
definition the_least_fixpoint        :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<mu> _"  [201] 200) where "\<mu>  f = (THE x . is_least_fixpoint f x)"
definition the_greatest_fixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<nu> _"  [201] 200) where "\<nu>  f = (THE x . is_greatest_fixpoint f x)"
definition the_least_prefixpoint     :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<mu> _" [201] 200) where "p\<mu> f = (THE x . is_least_prefixpoint f x)"
definition the_greatest_postfixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<nu> _" [201] 200) where "p\<nu> f = (THE x . is_greatest_postfixpoint f x)"

lemma least_fixpoint_unique: "has_least_fixpoint f \<longrightarrow> (\<exists>!x . is_least_fixpoint f x)"
  by (smt antisym has_least_fixpoint_def is_least_fixpoint_def)

lemma greatest_fixpoint_unique: "has_greatest_fixpoint f \<longrightarrow> (\<exists>!x . is_greatest_fixpoint f x)"
  by (smt antisym has_greatest_fixpoint_def is_greatest_fixpoint_def)

lemma least_prefixpoint_unique: "has_least_prefixpoint f \<longrightarrow> (\<exists>!x . is_least_prefixpoint f x)"
  by (smt antisym has_least_prefixpoint_def is_least_prefixpoint_def)

lemma greatest_postfixpoint_unique: "has_greatest_postfixpoint f \<longrightarrow> (\<exists>!x . is_greatest_postfixpoint f x)"
  by (smt antisym has_greatest_postfixpoint_def is_greatest_postfixpoint_def)

lemma least_fixpoint: "has_least_fixpoint f \<longrightarrow> is_least_fixpoint f (\<mu> f)"
proof
  assume "has_least_fixpoint f"
  hence "is_least_fixpoint f (THE x . is_least_fixpoint f x)"
    by (smt least_fixpoint_unique theI')
  thus "is_least_fixpoint f (\<mu> f)"
    by (simp add: is_least_fixpoint_def the_least_fixpoint_def)
qed

lemma greatest_fixpoint: "has_greatest_fixpoint f \<longrightarrow> is_greatest_fixpoint f (\<nu> f)"
proof
  assume "has_greatest_fixpoint f"
  hence "is_greatest_fixpoint f (THE x . is_greatest_fixpoint f x)"
    by (smt greatest_fixpoint_unique theI')
  thus "is_greatest_fixpoint f (\<nu> f)"
    by (simp add: is_greatest_fixpoint_def the_greatest_fixpoint_def)
qed

lemma least_prefixpoint: "has_least_prefixpoint f \<longrightarrow> is_least_prefixpoint f (p\<mu> f)"
proof
  assume "has_least_prefixpoint f"
  hence "is_least_prefixpoint f (THE x . is_least_prefixpoint f x)"
    by (smt least_prefixpoint_unique theI')
  thus "is_least_prefixpoint f (p\<mu> f)"
    by (simp add: is_least_prefixpoint_def the_least_prefixpoint_def)
qed

lemma greatest_postfixpoint: "has_greatest_postfixpoint f \<longrightarrow> is_greatest_postfixpoint f (p\<nu> f)"
proof
  assume "has_greatest_postfixpoint f"
  hence "is_greatest_postfixpoint f (THE x . is_greatest_postfixpoint f x)"
    by (smt greatest_postfixpoint_unique theI')
  thus "is_greatest_postfixpoint f (p\<nu> f)"
    by (simp add: is_greatest_postfixpoint_def the_greatest_postfixpoint_def)
qed

lemma least_fixpoint_same: "is_least_fixpoint f x \<longrightarrow> x = \<mu> f"
  by (metis least_fixpoint least_fixpoint_unique has_least_fixpoint_def)

lemma greatest_fixpoint_same: "is_greatest_fixpoint f x \<longrightarrow> x = \<nu> f"
  by (metis greatest_fixpoint greatest_fixpoint_unique has_greatest_fixpoint_def)

lemma least_prefixpoint_same: "is_least_prefixpoint f x \<longrightarrow> x = p\<mu> f"
  by (metis least_prefixpoint least_prefixpoint_unique has_least_prefixpoint_def)

lemma greatest_postfixpoint_same: "is_greatest_postfixpoint f x \<longrightarrow> x = p\<nu> f"
  by (metis greatest_postfixpoint greatest_postfixpoint_unique has_greatest_postfixpoint_def)

lemma least_fixpoint_char: "is_least_fixpoint f x \<longleftrightarrow> has_least_fixpoint f \<and> x = \<mu> f"
  by (metis least_fixpoint_same has_least_fixpoint_def)

lemma least_prefixpoint_char: "is_least_prefixpoint f x \<longleftrightarrow> has_least_prefixpoint f \<and> x = p\<mu> f"
  by (metis least_prefixpoint_same has_least_prefixpoint_def)

lemma greatest_fixpoint_char: "is_greatest_fixpoint f x \<longleftrightarrow> has_greatest_fixpoint f \<and> x = \<nu> f"
  by (metis greatest_fixpoint_same has_greatest_fixpoint_def)

lemma greatest_postfixpoint_char: "is_greatest_postfixpoint f x \<longleftrightarrow> has_greatest_postfixpoint f \<and> x = p\<nu> f"
  by (metis greatest_postfixpoint_same has_greatest_postfixpoint_def)

lemma mu_unfold: "has_least_fixpoint f \<longrightarrow> f (\<mu> f) = \<mu> f"
  by (metis is_least_fixpoint_def least_fixpoint)

lemma pmu_unfold: "has_least_prefixpoint f \<longrightarrow> f (p\<mu> f) \<le> p\<mu> f"
  by (metis is_least_prefixpoint_def least_prefixpoint)

lemma nu_unfold: "has_greatest_fixpoint f \<longrightarrow> \<nu> f = f (\<nu> f)"
  by (metis is_greatest_fixpoint_def greatest_fixpoint)

lemma pnu_unfold: "has_greatest_postfixpoint f \<longrightarrow> p\<nu> f \<le> f (p\<nu> f)"
  by (metis is_greatest_postfixpoint_def greatest_postfixpoint)

lemma least_prefixpoint_fixpoint: "has_least_prefixpoint f \<and> isotone f \<longrightarrow> is_least_fixpoint f (p\<mu> f)"
  by (smt eq_iff is_least_fixpoint_def is_least_prefixpoint_def isotone_def least_prefixpoint)

lemma pmu_mu: "has_least_prefixpoint f \<and> isotone f \<longrightarrow> p\<mu> f = \<mu> f"
  by (smt has_least_fixpoint_def is_least_fixpoint_def least_fixpoint_unique least_prefixpoint_fixpoint least_fixpoint)

lemma greatest_postfixpoint_fixpoint: "has_greatest_postfixpoint f \<and> isotone f \<longrightarrow> is_greatest_fixpoint f (p\<nu> f)"
  by (smt eq_iff is_greatest_fixpoint_def is_greatest_postfixpoint_def isotone_def greatest_postfixpoint)

lemma pnu_nu: "has_greatest_postfixpoint f \<and> isotone f \<longrightarrow> p\<nu> f = \<nu> f"
  by (smt has_greatest_fixpoint_def is_greatest_fixpoint_def greatest_fixpoint_unique greatest_postfixpoint_fixpoint greatest_fixpoint)

lemma pmu_isotone: "has_least_prefixpoint f \<and> has_least_prefixpoint g \<and> f \<le>\<le> g \<longrightarrow> p\<mu> f \<le> p\<mu> g"
  by (smt is_least_prefixpoint_def least_prefixpoint lifted_less_eq_def order_trans)

lemma mu_isotone: "has_least_prefixpoint f \<and> has_least_prefixpoint g \<and> isotone f \<and> isotone g \<and> f \<le>\<le> g \<longrightarrow> \<mu> f \<le> \<mu> g"
  by (metis pmu_isotone pmu_mu)

lemma pnu_isotone: "has_greatest_postfixpoint f \<and> has_greatest_postfixpoint g \<and> f \<le>\<le> g \<longrightarrow> p\<nu> f \<le> p\<nu> g"
  by (smt is_greatest_postfixpoint_def lifted_less_eq_def order_trans greatest_postfixpoint)

lemma nu_isotone: "has_greatest_postfixpoint f \<and> has_greatest_postfixpoint g \<and> isotone f \<and> isotone g \<and> f \<le>\<le> g \<longrightarrow> \<nu> f \<le> \<nu> g"
  by (metis pnu_isotone pnu_nu)

lemma mu_square: "isotone f \<and> has_least_fixpoint f \<and> has_least_fixpoint (f \<circ> f) \<longrightarrow> \<mu> f = \<mu> (f \<circ> f)"
  by (metis (no_types, hide_lams) antisym is_least_fixpoint_def ord.isotone_def least_fixpoint_char least_fixpoint_unique o_apply)

lemma nu_square: "isotone f \<and> has_greatest_fixpoint f \<and> has_greatest_fixpoint (f \<circ> f) \<longrightarrow> \<nu> f = \<nu> (f \<circ> f)"
  by (metis (no_types, hide_lams) antisym is_greatest_fixpoint_def ord.isotone_def greatest_fixpoint_char greatest_fixpoint_unique o_apply)

lemma mu_roll: "isotone g \<and> has_least_fixpoint (f \<circ> g) \<and> has_least_fixpoint (g \<circ> f) \<longrightarrow> \<mu> (g \<circ> f) = g(\<mu> (f \<circ> g))"
  apply (rule impI)
  apply (rule antisym)
  apply (smt is_least_fixpoint_def least_fixpoint o_apply)
  apply (smt is_least_fixpoint_def isotone_def least_fixpoint o_apply)
  done

lemma nu_roll: "isotone g \<and> has_greatest_fixpoint (f \<circ> g) \<and> has_greatest_fixpoint (g \<circ> f) \<longrightarrow> \<nu> (g \<circ> f) = g(\<nu> (f \<circ> g))"
  apply (rule impI)
  apply (rule antisym)
  apply (smt is_greatest_fixpoint_def greatest_fixpoint isotone_def o_apply)
  apply (smt is_greatest_fixpoint_def greatest_fixpoint o_apply)
  done

lemma mu_below_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<longrightarrow> \<mu> f \<le> \<nu> f"
  by (metis is_greatest_fixpoint_def is_least_fixpoint_def least_fixpoint greatest_fixpoint)

lemma pmu_below_pnu_fix: "has_fixpoint f \<and> has_least_prefixpoint f \<and> has_greatest_postfixpoint f \<longrightarrow> p\<mu> f \<le> p\<nu> f"
  by (smt has_fixpoint_def is_fixpoint_def is_greatest_postfixpoint_def is_least_prefixpoint_def le_less order_trans least_prefixpoint greatest_postfixpoint)

lemma pmu_below_pnu_iso: "isotone f \<and> has_least_prefixpoint f \<and> has_greatest_postfixpoint f \<longrightarrow> p\<mu> f \<le> p\<nu> f"
  by (metis has_fixpoint_def is_fixpoint_def is_least_fixpoint_def least_prefixpoint_fixpoint pmu_below_pnu_fix)

lemma mu_fusion_1: "galois l u \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_fixpoint h \<and> l(g(u(\<mu> h))) \<le> h(l(u(\<mu> h))) \<longrightarrow> l(p\<mu> g) \<le> \<mu> h"
proof
  assume 1: "galois l u \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_fixpoint h \<and> l(g(u(\<mu> h))) \<le> h(l(u(\<mu> h)))"
  hence "l(g(u(\<mu> h))) \<le> \<mu> h"
    by (metis galois_char least_fixpoint_same least_fixpoint_unique is_least_fixpoint_def isotone_def order_trans)
  thus "l(p\<mu> g) \<le> \<mu> h" using 1
    by (metis galois_def least_prefixpoint is_least_prefixpoint_def least_fixpoint_same least_fixpoint_unique)
qed

lemma mu_fusion_2: "galois l u \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_fixpoint h \<and> l \<circ> g \<le>\<le> h \<circ> l \<longrightarrow> l(p\<mu> g) \<le> \<mu> h"
  by (metis lifted_less_eq_def mu_fusion_1 o_apply)

lemma mu_fusion_equal_1: "galois l u \<and> isotone g \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_fixpoint h \<and> l(g(u(\<mu> h))) \<le> h(l(u(\<mu> h))) \<and> l(g(p\<mu> g)) = h(l(p\<mu> g)) \<longrightarrow> \<mu> h = l(p\<mu> g) \<and> \<mu> h = l(\<mu> g)"
  by (metis antisym least_fixpoint least_prefixpoint_fixpoint is_least_fixpoint_def mu_fusion_1 pmu_mu)

lemma mu_fusion_equal_2: "galois l u \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_prefixpoint h \<and> l(g(u(\<mu> h))) \<le> h(l(u(\<mu> h))) \<and> l(g(p\<mu> g)) = h(l(p\<mu> g)) \<longrightarrow> p\<mu> h = l(p\<mu> g) \<and> \<mu> h = l(p\<mu> g)"
  by (smt antisym galois_char least_fixpoint_char least_prefixpoint least_prefixpoint_fixpoint is_least_prefixpoint_def isotone_def mu_fusion_1)

lemma mu_fusion_equal_3: "galois l u \<and> isotone g \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_fixpoint h \<and> l \<circ> g = h \<circ> l \<longrightarrow> \<mu> h = l(p\<mu> g) \<and> \<mu> h = l(\<mu> g)"
  by (metis mu_fusion_equal_1 o_apply order_refl)

lemma mu_fusion_equal_4: "galois l u \<and> isotone h \<and> has_least_prefixpoint g \<and> has_least_prefixpoint h \<and> l \<circ> g = h \<circ> l \<longrightarrow> p\<mu> h = l(p\<mu> g) \<and> \<mu> h = l(p\<mu> g)"
  by (metis mu_fusion_equal_2 o_apply order_refl)

lemma nu_fusion_1: "galois l u \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_fixpoint h \<and> h(u(l(\<nu> h))) \<le> u(g(l(\<nu> h))) \<longrightarrow> \<nu> h \<le> u(p\<nu> g)"
proof
  assume 1: "galois l u \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_fixpoint h \<and> h(u(l(\<nu> h))) \<le> u(g(l(\<nu> h)))"
  hence "\<nu> h \<le> u(g(l(\<nu> h)))" using 1
    by (metis galois_char greatest_fixpoint_same greatest_fixpoint_unique is_greatest_fixpoint_def isotone_def order_trans)
  thus "\<nu> h \<le> u(p\<nu> g)" using 1
    by (smt galois_def greatest_postfixpoint is_greatest_postfixpoint_def greatest_fixpoint_same greatest_fixpoint_unique)
qed

lemma nu_fusion_2: "galois l u \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_fixpoint h \<and> h \<circ> u \<le>\<le> u \<circ> g \<longrightarrow> \<nu> h \<le> u(p\<nu> g)"
  by (metis lifted_less_eq_def nu_fusion_1 o_apply)

lemma nu_fusion_equal_1: "galois l u \<and> isotone g \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_fixpoint h \<and> h(u(l(\<nu> h))) \<le> u(g(l(\<nu> h))) \<and> h(u(p\<nu> g)) = u(g(p\<nu> g)) \<longrightarrow> \<nu> h = u(p\<nu> g) \<and> \<nu> h = u(\<nu> g)"
  by (metis antisym greatest_fixpoint greatest_postfixpoint_fixpoint is_greatest_fixpoint_def nu_fusion_1 pnu_nu)

lemma nu_fusion_equal_2: "galois l u \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_postfixpoint h \<and> h(u(l(\<nu> h))) \<le> u(g(l(\<nu> h))) \<and> h(u(p\<nu> g)) = u(g(p\<nu> g)) \<longrightarrow> p\<nu> h = u(p\<nu> g) \<and> \<nu> h = u(p\<nu> g)"
  by (smt antisym galois_char greatest_fixpoint_char greatest_postfixpoint greatest_postfixpoint_fixpoint is_greatest_postfixpoint_def isotone_def nu_fusion_1)

lemma nu_fusion_equal_3: "galois l u \<and> isotone g \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_fixpoint h \<and> h \<circ> u = u \<circ> g \<longrightarrow> \<nu> h = u(p\<nu> g) \<and> \<nu> h = u(\<nu> g)"
  by (metis nu_fusion_equal_1 o_apply order_refl)

lemma nu_fusion_equal_4: "galois l u \<and> isotone h \<and> has_greatest_postfixpoint g \<and> has_greatest_postfixpoint h \<and> h \<circ> u = u \<circ> g \<longrightarrow> p\<nu> h = u(p\<nu> g) \<and> \<nu> h = u(p\<nu> g)"
  by (metis nu_fusion_equal_2 o_apply order_refl)

lemma mu_exchange_1: "galois l u \<and> isotone g \<and> isotone h \<and> has_least_prefixpoint (l \<circ> h) \<and> has_least_prefixpoint (h \<circ> g) \<and> has_least_fixpoint (g \<circ> h) \<and> l \<circ> h \<circ> g \<le>\<le> g \<circ> h \<circ> l \<longrightarrow> \<mu>(l \<circ> h) \<le> \<mu>(g \<circ> h)"
proof
  assume 1: "galois l u \<and> isotone g \<and> isotone h \<and> has_least_prefixpoint (l \<circ> h) \<and> has_least_prefixpoint (h \<circ> g) \<and> has_least_fixpoint (g \<circ> h) \<and> l \<circ> h \<circ> g \<le>\<le> g \<circ> h \<circ> l"
  hence "l \<circ> (h \<circ> g) \<le>\<le> (g \<circ> h) \<circ> l"
    by (metis o_assoc)
  thus "\<mu>(l \<circ> h) \<le> \<mu>(g \<circ> h)" using 1
    by (smt galois_char is_least_prefixpoint_def isotone_def least_fixpoint_char least_prefixpoint least_prefixpoint_fixpoint mu_fusion_2 mu_roll o_apply)
qed

lemma mu_exchange_2: "galois l u \<and> isotone g \<and> isotone h \<and> has_least_prefixpoint (l \<circ> h) \<and> has_least_prefixpoint (h \<circ> l) \<and> has_least_prefixpoint (h \<circ> g) \<and> has_least_fixpoint (g \<circ> h) \<and> has_least_fixpoint (h \<circ> g) \<and> l \<circ> h \<circ> g \<le>\<le> g \<circ> h \<circ> l \<longrightarrow> \<mu>(h \<circ> l) \<le> \<mu>(h \<circ> g)"
  by (smt galois_char isotone_def least_fixpoint_char least_prefixpoint_fixpoint mu_exchange_1 mu_roll o_apply)

lemma mu_exchange_equal: "galois l u \<and> galois k t \<and> isotone h \<and> has_least_prefixpoint (l \<circ> h) \<and> has_least_prefixpoint (h \<circ> l) \<and> has_least_prefixpoint (k \<circ> h) \<and> has_least_prefixpoint (h \<circ> k) \<and> l \<circ> h \<circ> k = k \<circ> h \<circ> l \<longrightarrow> \<mu>(l \<circ> h) = \<mu>(k \<circ> h) \<and> \<mu>(h \<circ> l) = \<mu>(h \<circ> k)"
  by (smt antisym galois_char isotone_def least_fixpoint_char least_prefixpoint_fixpoint lifted_reflexive mu_exchange_1 mu_exchange_2 o_apply)

lemma nu_exchange_1: "galois l u \<and> isotone g \<and> isotone h \<and> has_greatest_postfixpoint (u \<circ> h) \<and> has_greatest_postfixpoint (h \<circ> g) \<and> has_greatest_fixpoint (g \<circ> h) \<and> g \<circ> h \<circ> u \<le>\<le> u \<circ> h \<circ> g \<longrightarrow> \<nu>(g \<circ> h) \<le> \<nu>(u \<circ> h)"
proof
  assume 1: "galois l u \<and> isotone g \<and> isotone h \<and> has_greatest_postfixpoint (u \<circ> h) \<and> has_greatest_postfixpoint (h \<circ> g) \<and> has_greatest_fixpoint (g \<circ> h) \<and> g \<circ> h \<circ> u \<le>\<le> u \<circ> h \<circ> g"
  hence "(g \<circ> h) \<circ> u \<le>\<le> u \<circ> (h \<circ> g)"
    by (metis o_assoc)
  thus "\<nu>(g \<circ> h) \<le> \<nu>(u \<circ> h)" using 1
    by (smt galois_char is_greatest_postfixpoint_def isotone_def greatest_fixpoint_char greatest_postfixpoint greatest_postfixpoint_fixpoint nu_fusion_2 nu_roll o_apply)
qed

lemma nu_exchange_2: "galois l u \<and> isotone g \<and> isotone h \<and> has_greatest_postfixpoint (u \<circ> h) \<and> has_greatest_postfixpoint (h \<circ> u) \<and> has_greatest_postfixpoint (h \<circ> g) \<and> has_greatest_fixpoint (g \<circ> h) \<and> has_greatest_fixpoint (h \<circ> g) \<and> g \<circ> h \<circ> u \<le>\<le> u \<circ> h \<circ> g \<longrightarrow> \<nu>(h \<circ> g) \<le> \<nu>(h \<circ> u)"
  by (smt galois_char isotone_def greatest_fixpoint_char greatest_postfixpoint_fixpoint nu_exchange_1 nu_roll o_apply)

lemma nu_exchange_equal: "galois l u \<and> galois k t \<and> isotone h \<and> has_greatest_postfixpoint (u \<circ> h) \<and> has_greatest_postfixpoint (h \<circ> u) \<and> has_greatest_postfixpoint (t \<circ> h) \<and> has_greatest_postfixpoint (h \<circ> t) \<and> u \<circ> h \<circ> t = t \<circ> h \<circ> u \<longrightarrow> \<nu>(u \<circ> h) = \<nu>(t \<circ> h) \<and> \<nu>(h \<circ> u) = \<nu>(h \<circ> t)"
  by (smt antisym galois_char isotone_def greatest_fixpoint_char greatest_postfixpoint_fixpoint lifted_reflexive nu_exchange_1 nu_exchange_2 o_apply)

lemma mu_commute_fixpoint_1: "isotone f \<and> has_least_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> is_fixpoint f (\<mu>(f \<circ> g))"
  by (metis is_fixpoint_def mu_roll)

lemma mu_commute_fixpoint_2: "isotone g \<and> has_least_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> is_fixpoint g (\<mu>(f \<circ> g))"
  by (metis is_fixpoint_def mu_roll)

lemma mu_commute_least_fixpoint: "isotone f \<and> isotone g \<and> has_least_fixpoint f \<and> has_least_fixpoint g \<and> has_least_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> (\<mu>(f \<circ> g) = \<mu> f \<longrightarrow> \<mu> g \<le> \<mu> f)"
  by (metis is_least_fixpoint_def least_fixpoint_same least_fixpoint_unique mu_roll)

(* converse claimed by [Davey & Priestley 2002, page 200, exercise 8.27(iii)] for continuous f, g on a CPO ; does it hold without additional assumptions?
lemma mu_commute_least_fixpoint_converse: "isotone f \<and> isotone g \<and> has_least_prefixpoint f \<and> has_least_prefixpoint g \<and> has_least_prefixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> (\<mu> g \<le> \<mu> f \<longrightarrow> \<mu>(f \<circ> g) = \<mu> f)"
*)

lemma nu_commute_fixpoint_1: "isotone f \<and> has_greatest_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> is_fixpoint f (\<nu>(f \<circ> g))"
  by (metis is_fixpoint_def nu_roll)

lemma nu_commute_fixpoint_2: "isotone g \<and> has_greatest_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> is_fixpoint g (\<nu>(f \<circ> g))"
  by (metis is_fixpoint_def nu_roll)

lemma nu_commute_greatest_fixpoint: "isotone f \<and> isotone g \<and> has_greatest_fixpoint f \<and> has_greatest_fixpoint g \<and> has_greatest_fixpoint (f \<circ> g) \<and> f \<circ> g = g \<circ> f \<longrightarrow> (\<nu>(f \<circ> g) = \<nu> f \<longrightarrow> \<nu> f \<le> \<nu> g)"
  by (smt is_greatest_fixpoint_def greatest_fixpoint_same greatest_fixpoint_unique nu_roll)

lemma mu_diagonal_1: "isotone (\<lambda>x . f x x) \<and> (\<forall>x . isotone (\<lambda>y . f x y)) \<and> isotone (\<lambda>x . \<mu>(\<lambda>y . f x y)) \<and> (\<forall>x . has_least_fixpoint (\<lambda>y . f x y)) \<and> has_least_prefixpoint (\<lambda>x . \<mu>(\<lambda>y . f x y)) \<longrightarrow> \<mu>(\<lambda>x . f x x) = \<mu>(\<lambda>x . \<mu>(\<lambda>y . f x y))"
  by (smt is_least_fixpoint_def is_least_prefixpoint_def least_fixpoint_same least_fixpoint_unique least_prefixpoint least_prefixpoint_fixpoint)

lemma mu_diagonal_2: "(\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_least_prefixpoint (\<lambda>y . f x y)) \<and> has_least_prefixpoint (\<lambda>x . \<mu>(\<lambda>y . f x y)) \<longrightarrow> \<mu>(\<lambda>x . f x x) = \<mu>(\<lambda>x . \<mu>(\<lambda>y . f x y))"
proof
  assume 1: "(\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_least_prefixpoint (\<lambda>y . f x y)) \<and> has_least_prefixpoint (\<lambda>x . \<mu>(\<lambda>y . f x y))"
  hence "isotone (\<lambda>x . \<mu>(\<lambda>y . f x y))"
    by (smt isotone_def lifted_less_eq_def mu_isotone)
  thus "\<mu>(\<lambda>x . f x x) = \<mu>(\<lambda>x . \<mu>(\<lambda>y . f x y))" using 1
    by (smt is_least_fixpoint_def is_least_prefixpoint_def least_fixpoint_same least_prefixpoint least_prefixpoint_fixpoint)
qed

lemma nu_diagonal_1: "isotone (\<lambda>x . f x x) \<and> (\<forall>x . isotone (\<lambda>y . f x y)) \<and> isotone (\<lambda>x . \<nu>(\<lambda>y . f x y)) \<and> (\<forall>x . has_greatest_fixpoint (\<lambda>y . f x y)) \<and> has_greatest_postfixpoint (\<lambda>x . \<nu>(\<lambda>y . f x y)) \<longrightarrow> \<nu>(\<lambda>x . f x x) = \<nu>(\<lambda>x . \<nu>(\<lambda>y . f x y))"
  by (smt is_greatest_fixpoint_def is_greatest_postfixpoint_def greatest_fixpoint_same greatest_fixpoint_unique greatest_postfixpoint greatest_postfixpoint_fixpoint)

lemma nu_diagonal_2: "(\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_greatest_postfixpoint (\<lambda>y . f x y)) \<and> has_greatest_postfixpoint (\<lambda>x . \<nu>(\<lambda>y . f x y)) \<longrightarrow> \<nu>(\<lambda>x . f x x) = \<nu>(\<lambda>x . \<nu>(\<lambda>y . f x y))"
proof
  assume 1: "(\<forall>x . isotone (\<lambda>y . f x y) \<and> isotone (\<lambda>y . f y x) \<and> has_greatest_postfixpoint (\<lambda>y . f x y)) \<and> has_greatest_postfixpoint (\<lambda>x . \<nu>(\<lambda>y . f x y))"
  hence "isotone (\<lambda>x . \<nu>(\<lambda>y . f x y))"
    by (smt isotone_def lifted_less_eq_def nu_isotone)
  thus "\<nu>(\<lambda>x . f x x) = \<nu>(\<lambda>x . \<nu>(\<lambda>y . f x y))" using 1
    by (smt greatest_fixpoint_same greatest_postfixpoint greatest_postfixpoint_fixpoint is_greatest_fixpoint_def is_greatest_postfixpoint_def)
qed

end

(*
end


theory Lattice

imports Base

begin
*)

class join_semilattice = plus + ord +
  assumes add_associative: "(x + y) + z = x + (y + z)"
  assumes add_commutative: "x + y = y + x"
  assumes add_idempotent: "x + x = x"
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  assumes less_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"

begin

subclass order
  apply unfold_locales
  apply (metis less_def)
  apply (metis add_idempotent less_eq_def)
  apply (metis add_associative less_eq_def)
  apply (metis add_commutative less_eq_def)
  done

lemma add_left_isotone: "x \<le> y \<longrightarrow> x + z \<le> y + z"
  by (smt add_associative add_commutative add_idempotent less_eq_def)

lemma add_right_isotone: "x \<le> y \<longrightarrow> z + x \<le> z + y"
  by (metis add_commutative add_left_isotone)

lemma add_isotone: "w \<le> y \<and> x \<le> z \<longrightarrow> w + x \<le> y + z"
  by (smt add_associative add_commutative less_eq_def)

lemma add_left_upper_bound: "x \<le> x + y"
  by (metis add_associative add_idempotent less_eq_def)

lemma add_right_upper_bound: "y \<le> x + y"
  by (metis add_commutative add_left_upper_bound)

lemma add_least_upper_bound: "x \<le> z \<and> y \<le> z \<longleftrightarrow> x + y \<le> z"
  by (smt add_associative add_commutative add_left_upper_bound less_eq_def)

lemma add_left_divisibility: "x \<le> y \<longleftrightarrow> (\<exists>z . x + z = y)"
  by (metis add_left_upper_bound less_eq_def)

lemma add_right_divisibility: "x \<le> y \<longleftrightarrow> (\<exists>z . z + x = y)"
  by (metis add_commutative add_left_divisibility)

lemma add_same_context:"x \<le> y + z \<and> y \<le> x + z \<longrightarrow> x + z = y + z"
  by (smt add_associative add_commutative less_eq_def)

lemma add_relative_same_increasing: "x \<le> y \<and> x + z = x + w \<longrightarrow> y + z = y + w"
  by (smt add_associative add_right_divisibility)

lemma ascending_chain_left_add: "ascending_chain f \<longrightarrow> ascending_chain (\<lambda>n . x + f n)"
  by (metis ascending_chain_def add_right_isotone)

lemma ascending_chain_right_add: "ascending_chain f \<longrightarrow> ascending_chain (\<lambda>n . f n + x)"
  by (metis ascending_chain_def add_left_isotone)

lemma descending_chain_left_add: "descending_chain f \<longrightarrow> descending_chain (\<lambda>n . x + f n)"
  by (metis descending_chain_def add_right_isotone)

lemma descending_chain_right_add: "descending_chain f \<longrightarrow> descending_chain (\<lambda>n . f n + x)"
  by (metis descending_chain_def add_left_isotone)

primrec pSum0 :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
  where "pSum0 f 0 = f 0"
      | "pSum0 f (Suc m) = pSum0 f m + f m"

lemma pSum0_below: "(\<forall>i . f i \<le> x) \<longrightarrow> pSum0 f m \<le> x"
  apply (induct m)
  apply (metis pSum0.simps(1))
  by (metis add_least_upper_bound pSum0.simps(2))

end

class bounded_join_semilattice = join_semilattice + zero +
  assumes add_left_zero: "0 + x = x"

begin

lemma add_right_zero: "x + 0 = x"
  by (metis add_commutative add_left_zero)

lemma zero_least: "0 \<le> x"
  by (metis add_left_upper_bound add_left_zero)

end

class meet =
  fixes meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<frown>" 65)

class meet_semilattice = meet + ord +
  assumes meet_associative: "(x \<frown> y) \<frown> z = x \<frown> (y \<frown> z)"
  assumes meet_commutative: "x \<frown> y = y \<frown> x"
  assumes meet_idempotent: "x \<frown> x = x"
  assumes meet_less_eq_def: "x \<le> y \<longleftrightarrow> x \<frown> y = x"
  assumes meet_less_def: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"

sublocale meet_semilattice < meet!: join_semilattice where plus = meet and less_eq = "(\<lambda>x y . y \<le> x)" and less = "(\<lambda>x y . y < x)"
  apply unfold_locales
  apply (rule meet_associative)
  apply (rule meet_commutative)
  apply (rule meet_idempotent)
  apply (metis meet_commutative meet_less_eq_def)
  apply (metis meet_less_def)
  done

class T =
  fixes T :: "'a" ("\<top>")

class bounded_meet_semilattice = meet_semilattice + T +
  assumes meet_left_top: "T \<frown> x = x"

sublocale bounded_meet_semilattice < meet!: bounded_join_semilattice where plus = meet and less_eq = "(\<lambda>x y . y \<le> x)" and less = "(\<lambda>x y . y < x)" and zero = T
  apply unfold_locales
  apply (rule meet_left_top)
  done

class bounded_distributive_lattice = bounded_join_semilattice + bounded_meet_semilattice +
  assumes meet_left_dist_add: "x \<frown> (y + z) = (x \<frown> y) + (x \<frown> z)"
  assumes add_left_dist_meet: "x + (y \<frown> z) = (x + y) \<frown> (x + z)"
  assumes meet_absorb: "x \<frown> (x + y) = x"
  assumes add_absorb: "x + (x \<frown> y) = x"

begin

lemma meet_left_zero: "0 \<frown> x = 0"
  by (metis add_absorb add_left_zero)

lemma meet_right_zero: "x \<frown> 0 = 0"
  by (metis meet_commutative meet_left_zero)

lemma add_left_top_1: "T + x = T"
  by (metis add_absorb meet_left_top)

lemma add_right_top_1: "x + T = T"
  by (metis add_commutative add_left_top_1)

lemma meet_same_context:"x \<le> y \<frown> z \<and> y \<le> x \<frown> z \<longrightarrow> x \<frown> z = y \<frown> z"
  by (metis eq_iff meet.add_least_upper_bound)

lemma relative_equality: "x + z = y + z \<and> x \<frown> z = y \<frown> z \<longrightarrow> x = y"
  by (metis add_absorb add_commutative add_left_dist_meet)

end

(*
end


theory Semiring

imports Fixpoint Lattice

begin
*)

class monoid = mult + one +
  assumes mult_associative: "(x ; y) ; z = x ; (y ; z)"
  assumes mult_left_one_1: "1 ; x = x"
  assumes mult_right_one: "x ; 1 = x"

class non_associative_left_semiring = bounded_join_semilattice + mult + one +
  assumes mult_left_sub_dist_add: "x ; y + x ; z \<le> x ; (y + z)"
  assumes mult_right_dist_add: "(x + y) ; z = x ; z + y ; z"
  assumes mult_left_zero: "0 ; x = 0"
  assumes mult_left_one: "1 ; x = x"
  assumes mult_sub_right_one: "x \<le> x ; 1"

begin

lemma mult_left_isotone: "x \<le> y \<longrightarrow> x ; z \<le> y ; z"
  by (metis less_eq_def mult_right_dist_add)

lemma mult_right_isotone: "x \<le> y \<longrightarrow> z ; x \<le> z ; y"
  by (metis add_least_upper_bound less_eq_def mult_left_sub_dist_add)

lemma mult_isotone: "w \<le> y \<and> x \<le> z \<longrightarrow> w ; x \<le> y ; z"
  by (smt mult_left_isotone mult_right_isotone order_trans)

lemma affine_isotone: "isotone (\<lambda>x . y ; x + z)"
  by (smt add_commutative add_right_isotone isotone_def mult_right_isotone)

lemma mult_left_sub_dist_add_left: "x ; y \<le> x ; (y + z)"
  by (metis add_left_upper_bound mult_right_isotone)

lemma mult_left_sub_dist_add_right: "x ; z \<le> x ; (y + z)"
  by (metis add_right_upper_bound mult_right_isotone)

lemma mult_right_sub_dist_add_left: "x ; z \<le> (x + y) ; z"
  by (metis add_left_upper_bound mult_right_dist_add)

lemma mult_right_sub_dist_add_right: "y ; z \<le> (x + y) ; z"
  by (metis add_right_upper_bound mult_right_dist_add)

lemma case_split_left: "1 \<le> w + z \<and> w ; x \<le> y \<and> z ; x \<le> y \<longrightarrow> x \<le> y"
  by (smt add_associative add_commutative less_eq_def mult_left_one mult_right_dist_add order_refl)

lemma case_split_left_equal: "w + z = 1 \<and> w ; x = w ; y \<and> z ; x = z ; y \<longrightarrow> x = y"
  by (metis mult_left_one mult_right_dist_add)

lemma ascending_chain_left_mult: "ascending_chain f \<longrightarrow> ascending_chain (\<lambda>n . x ; f n)"
  by (metis ascending_chain_def mult_right_isotone)

lemma ascending_chain_right_mult: "ascending_chain f \<longrightarrow> ascending_chain (\<lambda>n . f n ; x)"
  by (metis ascending_chain_def mult_left_isotone)

lemma descending_chain_left_mult: "descending_chain f \<longrightarrow> descending_chain (\<lambda>n . x ; f n)"
  by (metis descending_chain_def mult_right_isotone)

lemma descending_chain_right_mult: "descending_chain f \<longrightarrow> descending_chain (\<lambda>n . f n ; x)"
  by (metis descending_chain_def mult_left_isotone)

-- {* Some results about transitive closures in this class and the next two classes are taken from a joint paper with Rudolf Berghammer. *}

abbreviation Lf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Lf y \<equiv> (\<lambda> x . 1 + x ; y)"
abbreviation Rf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Rf y \<equiv> (\<lambda> x . 1 + y ; x)"
abbreviation Sf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Sf y \<equiv> (\<lambda> x . 1 + y + x ; x)"

abbreviation lstar :: "'a \<Rightarrow> 'a" where "lstar y \<equiv> p\<mu> (Lf y)"
abbreviation rstar :: "'a \<Rightarrow> 'a" where "rstar y \<equiv> p\<mu> (Rf y)"
abbreviation sstar :: "'a \<Rightarrow> 'a" where "sstar y \<equiv> p\<mu> (Sf y)"

lemma lstar_rec_isotone: "isotone (Lf y)"
  by (smt2 add_isotone add_right_divisibility isotone_def mult_right_sub_dist_add_right order.refl)

lemma rstar_rec_isotone: "isotone (Rf y)"
  by (metis add_isotone isotone_def less_eq_def mult_left_sub_dist_add_left order_refl)

lemma sstar_rec_isotone: "isotone (Sf y)"
  by (simp add: add_right_isotone isotone_def mult_isotone)

lemma lstar_fixpoint: "has_least_prefixpoint (Lf y) \<longrightarrow> lstar y = \<mu> (Lf y)"
  by (metis pmu_mu lstar_rec_isotone)

lemma rstar_fixpoint: "has_least_prefixpoint (Rf y) \<longrightarrow> rstar y = \<mu> (Rf y)"
  by (metis pmu_mu rstar_rec_isotone)

lemma sstar_fixpoint: "has_least_prefixpoint (Sf y) \<longrightarrow> sstar y = \<mu> (Sf y)"
  by (metis pmu_mu sstar_rec_isotone)

lemma sstar_increasing: "has_least_prefixpoint (Sf y) \<longrightarrow> y \<le> sstar y"
  by (metis add_least_upper_bound add_left_upper_bound order.trans pmu_unfold)

lemma rstar_below_sstar: "has_least_prefixpoint (Rf y) \<and> has_least_prefixpoint (Sf y) \<longrightarrow> rstar y \<le> sstar y"
proof
  assume 1: "has_least_prefixpoint (Rf y) \<and> has_least_prefixpoint (Sf y)"
  hence "Rf y (sstar y) \<le> Sf y (sstar y)"
    by (smt2 add_isotone add_left_upper_bound add_right_upper_bound dual_order.trans mult_left_isotone pmu_unfold)
  also have "... \<le> sstar y" using 1
    by (metis (erased, lifting) pmu_unfold)
  finally show "rstar y \<le> sstar y" using 1
    by (metis (erased, lifting) is_least_prefixpoint_def least_prefixpoint)
qed

end

class pre_left_semiring = non_associative_left_semiring +
  assumes mult_semi_associative: "(x ; y) ; z \<le> x ; (y ; z)"

begin

lemma mult_one_associative: "x ; 1 ; y = x ; y"
  by (metis dual_order.antisym mult_left_isotone mult_left_one mult_semi_associative mult_sub_right_one)

lemma mult_sup_associative_one: "(x ; (y ; 1)) ; z \<le> x ; (y ; z)"
  by (metis mult_semi_associative mult_one_associative)

lemma rstar_increasing: "has_least_prefixpoint (Rf y) \<longrightarrow> y \<le> rstar y"
proof
  assume "has_least_prefixpoint (Rf y)"
  hence "Rf y (rstar y) \<le> rstar y"
    by (metis pmu_unfold)
  thus "y \<le> rstar y"
    by (metis add_least_upper_bound mult_right_isotone mult_sub_right_one order.trans)
qed

end

class residuated_pre_left_semiring = pre_left_semiring + inverse +
  assumes lres_galois: "x ; y \<le> z \<longleftrightarrow> x \<le> z / y"

begin

-- {* Theorem 32.2 *}

lemma lres_left_isotone: "x \<le> y \<longrightarrow> x / z \<le> y / z"
  by (metis lres_galois order.refl order.trans)

-- {* Theorem 32.2 *}

lemma lres_right_antitone: "x \<le> y \<longrightarrow> z / y \<le> z / x"
  by (metis lres_galois mult_right_isotone order.refl order_trans)

lemma lres_inverse: "(x / y) ; y \<le> x"
  by (metis lres_galois order_refl)

lemma lres_one: "x / 1 \<le> x"
  by (metis dual_order.trans mult_sub_right_one lres_inverse)

lemma lres_mult_sub_lres_lres: "x / (z ; y) \<le> (x / y) / z"
  by (metis lres_galois lres_inverse mult_semi_associative order.trans)

-- {* Theorem 32.4 *}

lemma mult_lres_sub_assoc: "x ; (y / z) \<le> (x ; y) / z"
  by (metis (full_types) lres_galois lres_inverse mult_right_isotone mult_semi_associative order_trans)

lemma lstar_below_rstar: "has_least_prefixpoint (Lf y) \<and> has_least_prefixpoint (Rf y) \<longrightarrow> lstar y \<le> rstar y"
proof
  assume 1: "has_least_prefixpoint (Lf y) \<and> has_least_prefixpoint (Rf y)"
  have "y ; (rstar y / y) ; y \<le> y ; rstar y"
    by (metis mult_right_isotone mult_semi_associative order_trans lres_inverse)
  also have "... \<le> rstar y" using 1
    by (metis add_least_upper_bound pmu_unfold)
  finally have "y ; (rstar y / y) \<le> rstar y / y"
    by (metis lres_galois)
  hence "Rf y (rstar y / y) \<le> rstar y / y" using 1
    by (metis add_least_upper_bound lres_galois mult_left_one rstar_increasing)
  hence "rstar y \<le> rstar y / y" using 1
    by (metis is_least_prefixpoint_def least_prefixpoint)
  hence "Lf y (rstar y) \<le> rstar y" using 1
    by (metis add_least_upper_bound lres_galois pmu_unfold)
  thus "lstar y \<le> rstar y" using 1
    by (metis (erased, lifting) is_least_prefixpoint_def least_prefixpoint)
qed

-- {* The next proof follows an argument of Rudolf Berghammer; see Satz 10.1.5 in his 2012 book. *}

lemma rstar_sstar: "has_least_prefixpoint (Rf y) \<and> has_least_prefixpoint (Sf y) \<longrightarrow> rstar y = sstar y"
proof
  assume 1: "has_least_prefixpoint (Rf y) \<and> has_least_prefixpoint (Sf y)"
  have "Rf y (rstar y / rstar y) ; rstar y \<le> rstar y + y ; ((rstar y / rstar y) ; rstar y)"
    by (metis add_isotone mult_left_one mult_right_dist_add mult_semi_associative)
  also have "... \<le> rstar y + y ; rstar y"
    by (metis add_right_isotone mult_right_isotone lres_inverse)
  also have "... \<le> rstar y" using 1
    by (metis (full_types) add_least_upper_bound order_refl pmu_unfold)
  finally have "Rf y (rstar y / rstar y) \<le> rstar y / rstar y"
    by (metis lres_galois)
  hence "rstar y ; rstar y \<le> rstar y" using 1
    by (metis (erased, lifting) is_least_prefixpoint_def least_prefixpoint lres_galois)
  hence "y + rstar y ; rstar y \<le> rstar y" using 1
    by (metis add_least_upper_bound rstar_increasing)
  hence "Sf y (rstar y) \<le> rstar y" using 1
    by (metis (full_types) add_least_upper_bound pmu_unfold)
  hence "sstar y \<le> rstar y" using 1
    by (metis (erased, lifting) is_least_prefixpoint_def least_prefixpoint)
  thus "rstar y = sstar y" using 1
    by (metis antisym rstar_below_sstar)
qed

end

class idempotent_left_semiring = non_associative_left_semiring + monoid

begin

subclass pre_left_semiring
  apply unfold_locales
  apply (metis mult_associative order_refl)
  done

lemma zero_right_mult_decreasing: "x ; 0 \<le> x"
  by (metis add_right_zero mult_left_sub_dist_add_right mult_right_one)

lemma test_preserves_equation: "p \<le> p ; p \<and> p \<le> 1 \<longrightarrow> (p ; x \<le> x ; p \<longleftrightarrow> p ; x = p ; x ; p)"
  apply rule
  apply rule
  apply (rule antisym)
  apply (smt antisym mult_associative mult_right_isotone mult_right_one)
  apply (metis mult_right_isotone mult_right_one)
  apply (metis mult_left_isotone mult_left_one)
  done

end

class idempotent_left_zero_semiring = idempotent_left_semiring +
  assumes mult_left_dist_add: "x ; (y + z) = x ; y + x ; z"

begin

lemma case_split_right: "1 \<le> w + z \<and> x ; w \<le> y \<and> x ; z \<le> y \<longrightarrow> x \<le> y"
  by (smt add_associative add_commutative less_eq_def mult_left_dist_add mult_right_one)

lemma case_split_right_equal: "w + z = 1 \<and> x ; w = y ; w \<and> x ; z = y ; z \<longrightarrow> x = y"
  by (metis mult_left_dist_add mult_right_one)

end

class idempotent_semiring = idempotent_left_zero_semiring +
  assumes mult_right_zero: "x ; 0 = 0"

class bounded_pre_left_semiring = pre_left_semiring + T +
  assumes add_right_top: "x + T = T"

begin

lemma add_left_top: "T + x = T"
  by (metis add_commutative add_right_top)

lemma top_greatest: "x \<le> T"
  by (metis add_left_top add_right_upper_bound)

lemma top_left_mult_increasing: "x \<le> T ; x"
  by (metis mult_left_isotone mult_left_one top_greatest)

lemma top_right_mult_increasing: "x \<le> x ; T"
  by (metis order_trans mult_right_isotone mult_sub_right_one top_greatest)

lemma top_mult_top: "T ; T = T"
  by (metis add_right_divisibility add_right_top top_right_mult_increasing)

definition vector :: "'a \<Rightarrow> bool"
  where "vector x \<longleftrightarrow> x = x ; T"

lemma vector_zero: "vector 0"
  by (metis mult_left_zero vector_def)

lemma vector_top: "vector T"
  by (metis top_mult_top vector_def)

lemma vector_add_closed: "vector x \<and> vector y \<longrightarrow> vector (x + y)"
  by (metis mult_right_dist_add vector_def)

lemma vector_left_mult_closed: "vector y \<longrightarrow> vector (x ; y)"
  by (metis antisym mult_semi_associative top_right_mult_increasing vector_def)

end

class bounded_residuated_pre_left_semiring = residuated_pre_left_semiring + bounded_pre_left_semiring

begin

-- {* Theorem 32.8 *}

lemma lres_top_decreasing: "x / T \<le> x"
  by (metis lres_one lres_right_antitone order_trans top_greatest)

-- {* Theorem 32.9 *}

lemma top_lres_absorb: "T / x = T"
  by (metis eq_iff lres_galois top_greatest)

end

class bounded_idempotent_left_semiring = bounded_pre_left_semiring + idempotent_left_semiring

class bounded_idempotent_left_zero_semiring = bounded_idempotent_left_semiring + idempotent_left_zero_semiring

class bounded_idempotent_semiring = bounded_idempotent_left_zero_semiring + idempotent_semiring

(*
end


theory Itering

imports Semiring

begin
*)

class circ =
  fixes circ :: "'a \<Rightarrow> 'a" ("_\<^sup>\<circ>" [100] 100)

class left_conway_semiring = idempotent_left_semiring + circ +
  assumes circ_left_unfold: "1 + x ; x\<^sup>\<circ> = x\<^sup>\<circ>"
  assumes circ_left_slide: "(x ; y)\<^sup>\<circ> ; x \<le> x ; (y ; x)\<^sup>\<circ>"
  assumes circ_add_1: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; (y ; x\<^sup>\<circ>)\<^sup>\<circ>"

begin

-- {* Theorem 14.19 *}

lemma circ_mult_sub: "1 + x ; (y ; x)\<^sup>\<circ> ; y \<le> (x ; y)\<^sup>\<circ>"
  by (metis add_right_isotone circ_left_slide circ_left_unfold mult_associative mult_right_isotone)

-- {* Theorem 14.8 *}

lemma circ_right_unfold_sub: "1 + x\<^sup>\<circ> ; x \<le> x\<^sup>\<circ>"
  by (metis circ_mult_sub mult_left_one mult_right_one)

-- {* Theorem 1.1 and Theorem 14.1 *}

lemma circ_zero: "0\<^sup>\<circ> = 1"
  by (metis add_right_zero circ_left_unfold mult_left_zero)

-- {* Theorem 1.4 and Theorem 1.13 and Theorem 14.4 and Theorem 14.13 *}

lemma circ_increasing: "x \<le> x\<^sup>\<circ>"
  by (metis add_right_upper_bound circ_left_unfold circ_right_unfold_sub mult_left_one mult_right_sub_dist_add_left order_trans)

-- {* Theorem 1.3 and Theorem 14.3 *}

lemma circ_reflexive: "1 \<le> x\<^sup>\<circ>"
  by (metis add_left_divisibility circ_left_unfold)

-- {* Theorem 1.5 *}

lemma circ_mult_increasing: "x \<le> x ; x\<^sup>\<circ>"
  by (metis circ_reflexive mult_right_isotone mult_right_one)

-- {* Theorem 14.5 *}

lemma circ_mult_increasing_2: "x \<le> x\<^sup>\<circ> ; x"
  by (metis circ_reflexive mult_left_isotone mult_left_one_1)

-- {* Theorem 1.11 and Theorem 14.11 *}

lemma circ_transitive_equal: "x\<^sup>\<circ> ; x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis add_idempotent circ_add_1 circ_left_unfold mult_associative)

-- {* Theorem 1.17 and Theorem 14.17 *}

lemma circ_circ_circ: "x\<^sup>\<circ>\<^sup>\<circ>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis add_idempotent circ_add_1 circ_increasing circ_transitive_equal less_eq_def)

-- {* Theorem 1.18 and Theorem 14.18 *}

lemma circ_one: "1\<^sup>\<circ> = 1\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_circ_circ circ_zero)

-- {* Theorem 14.21 *}

lemma circ_add_sub: "(x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ> \<le> (x + y)\<^sup>\<circ>"
  by (metis circ_add_1 circ_left_slide)

lemma circ_plus_one: "x\<^sup>\<circ> = 1 + x\<^sup>\<circ>"
  by (metis less_eq_def circ_reflexive)

-- {* Theorem 1.12 and Theorem 14.12 *}

lemma circ_rtc_2: "1 + x + x\<^sup>\<circ> ; x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis add_associative circ_increasing circ_plus_one circ_transitive_equal less_eq_def)

-- {* Theorem 1.2 and Theorem 14.2 *}

lemma mult_zero_circ: "(x ; 0)\<^sup>\<circ> = 1 + x ; 0"
  by (metis circ_left_unfold mult_associative mult_left_zero)

lemma mult_zero_add_circ: "(x + y ; 0)\<^sup>\<circ> = x\<^sup>\<circ> ; (y ; 0)\<^sup>\<circ>"
  by (metis circ_add_1 mult_associative mult_left_zero)

-- {* Theorem 14.6 *}

lemma circ_plus_sub: "x\<^sup>\<circ> ; x \<le> x ; x\<^sup>\<circ>"
  by (metis circ_left_slide mult_left_one mult_right_one)

lemma circ_loop_fixpoint: "y ; (y\<^sup>\<circ> ; z) + z = y\<^sup>\<circ> ; z"
  by (metis add_commutative circ_left_unfold mult_associative mult_left_one mult_right_dist_add)

-- {* Theorem 1.6 and Theorem 14.7 *}

lemma left_plus_below_circ: "x ; x\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis add_right_upper_bound circ_left_unfold)

lemma right_plus_below_circ: "x\<^sup>\<circ> ; x \<le> x\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_right_unfold_sub)

lemma circ_add_upper_bound: "x \<le> z\<^sup>\<circ> \<and> y \<le> z\<^sup>\<circ> \<longrightarrow> x + y \<le> z\<^sup>\<circ>"
  by (metis add_least_upper_bound)

lemma circ_mult_upper_bound: "x \<le> z\<^sup>\<circ> \<and> y \<le> z\<^sup>\<circ> \<longrightarrow> x ; y \<le> z\<^sup>\<circ>"
  by (metis mult_isotone circ_transitive_equal)

lemma circ_sub_dist: "x\<^sup>\<circ> \<le> (x + y)\<^sup>\<circ>"
  by (metis circ_add_sub circ_plus_one mult_left_one mult_right_sub_dist_add_left order_trans)

lemma circ_sub_dist_1: "x \<le> (x + y)\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_increasing)

lemma circ_sub_dist_2: "x ; y \<le> (x + y)\<^sup>\<circ>"
  by (metis add_commutative circ_mult_upper_bound circ_sub_dist_1)

-- {* Theorem 1.20 and Theorem 14.23 *}

lemma circ_sub_dist_3: "x\<^sup>\<circ> ; y\<^sup>\<circ> \<le> (x + y)\<^sup>\<circ>"
  by (metis add_commutative circ_mult_upper_bound circ_sub_dist)

-- {* Theorem 1 and Theorem 14 *}

lemma circ_isotone: "x \<le> y \<longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
  by (metis circ_sub_dist less_eq_def)

-- {* Theorem 1.21 and Theorem 14.24 *}

lemma circ_add_2: "(x + y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_increasing circ_isotone circ_reflexive mult_isotone mult_left_one mult_right_one)

lemma circ_sup_one_left_unfold: "1 \<le> x \<longrightarrow> x ; x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis antisym less_eq_def mult_left_one mult_right_sub_dist_add_left left_plus_below_circ)

lemma circ_sup_one_right_unfold: "1 \<le> x \<longrightarrow> x\<^sup>\<circ> ; x = x\<^sup>\<circ>"
  by (metis antisym less_eq_def mult_left_sub_dist_add_left mult_right_one right_plus_below_circ)

-- {* Theorem 1.23 and Theorem 14.26 *}

lemma circ_decompose_4: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> ; (y\<^sup>\<circ> ; x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis add_associative add_commutative circ_add_1 circ_loop_fixpoint circ_plus_one circ_rtc_2 circ_transitive_equal mult_associative)

-- {* Theorem 1.22 and Theorem 14.25 *}

lemma circ_decompose_5: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> = (y\<^sup>\<circ> ; x\<^sup>\<circ>)\<^sup>\<circ>"
  by (smt add_associative add_commutative add_left_zero circ_add_1 circ_decompose_4 mult_left_zero mult_right_one)

lemma circ_decompose_6: "x\<^sup>\<circ> ; (y ; x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> ; (x ; y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis add_commutative circ_add_1)

lemma circ_decompose_7: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ> ; (x + y)\<^sup>\<circ>"
  by (metis circ_add_1 circ_decompose_6 circ_transitive_equal mult_associative)

lemma circ_decompose_8: "(x + y)\<^sup>\<circ> = (x + y)\<^sup>\<circ> ; x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis antisym eq_refl mult_associative mult_isotone mult_right_one circ_mult_upper_bound circ_reflexive circ_sub_dist_3)

lemma circ_decompose_9: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ> ; (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_4 mult_associative)

lemma circ_decompose_10: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> ; x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis add_right_upper_bound circ_loop_fixpoint circ_reflexive circ_sup_one_right_unfold mult_associative order_trans)

lemma circ_back_loop_prefixpoint: "(z ; y\<^sup>\<circ>) ; y + z \<le> z ; y\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_left_unfold mult_associative mult_left_sub_dist_add_left mult_right_isotone mult_right_one right_plus_below_circ)

-- {* Theorem 1 and Theorem 14 *}

lemma circ_loop_is_fixpoint: "is_fixpoint (\<lambda>x . y ; x + z) (y\<^sup>\<circ> ; z)"
  by (metis circ_loop_fixpoint is_fixpoint_def)

-- {* Theorem 14 *}

lemma circ_back_loop_is_prefixpoint: "is_prefixpoint (\<lambda>x . x ; y + z) (z ; y\<^sup>\<circ>)"
  by (metis circ_back_loop_prefixpoint is_prefixpoint_def)

-- {* Theorem 1.16 and Theorem 14.16 *}

lemma circ_circ_add: "(1 + x)\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis add_commutative circ_add_1 circ_decompose_4 circ_zero mult_right_one)

-- {* Theorem 14.14 *}

lemma circ_circ_mult_sub: "x\<^sup>\<circ> ; 1\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

-- {* Theorem 14.9 *}

lemma left_plus_circ: "(x ; x\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (smt add_idempotent circ_add_1 circ_loop_fixpoint circ_transitive_equal mult_right_dist_add)

-- {* Theorem 1.10 and Theorem 14.10 *}

lemma right_plus_circ: "(x\<^sup>\<circ> ; x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis add_commutative circ_isotone circ_loop_fixpoint circ_plus_sub circ_sub_dist eq_iff left_plus_circ)

lemma circ_square: "(x ; x)\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone left_plus_circ mult_right_isotone)

-- {* Theorem 1.19 *}

lemma circ_mult_sub_add: "(x ; y)\<^sup>\<circ> \<le> (x + y)\<^sup>\<circ>"
  by (metis add_left_upper_bound add_right_upper_bound circ_isotone circ_square mult_isotone order_trans)

lemma circ_add_mult_zero: "x\<^sup>\<circ> ; y = (x + y ; 0)\<^sup>\<circ> ; y"
proof -
  have "(x + y ; 0)\<^sup>\<circ> ; y = x\<^sup>\<circ> ; (1 + y ; 0) ; y"
    by (metis mult_zero_add_circ mult_zero_circ)
  also have "... = x\<^sup>\<circ> ; (y + y ; 0)"
    by (metis mult_associative mult_left_one mult_left_zero mult_right_dist_add)
  also have "... = x\<^sup>\<circ> ; y"
    by (metis add_commutative less_eq_def zero_right_mult_decreasing)
  finally show ?thesis
    by metis
qed

-- {* Theorem 14.22 *}

lemma troeger_1: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; (1 + y ; (x + y)\<^sup>\<circ>)"
  by (metis circ_add_1 circ_left_unfold mult_associative)

lemma troeger_2: "(x + y)\<^sup>\<circ> ; z = x\<^sup>\<circ> ; (y ; (x + y)\<^sup>\<circ> ; z + z)"
  by (metis circ_add_1 circ_loop_fixpoint mult_associative)

lemma troeger_3: "(x + y ; 0)\<^sup>\<circ> = x\<^sup>\<circ> ; (1 + y ; 0)"
  by (metis mult_zero_add_circ mult_zero_circ)

lemma circ_add_sub_add_one_1: "x + y \<le> x\<^sup>\<circ> ; (1 + y)"
  by (smt add_associative add_commutative add_idempotent circ_increasing circ_loop_fixpoint less_eq_def mult_left_sub_dist_add_left mult_right_one)

lemma circ_add_sub_add_one_2: "x\<^sup>\<circ> ; (x + y) \<le> x\<^sup>\<circ> ; (1 + y)"
  by (metis circ_add_sub_add_one_1 circ_transitive_equal mult_associative mult_right_isotone)

lemma circ_add_sub_add_one: "x ; x\<^sup>\<circ> ; (x + y) \<le> x ; x\<^sup>\<circ> ; (1 + y)"
  by (metis circ_add_sub_add_one_2 mult_associative mult_right_isotone)

lemma circ_square_2: "(x ; x)\<^sup>\<circ> ; (x + 1) \<le> x\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_increasing circ_mult_upper_bound circ_reflexive circ_square)

-- {* Theorem 1.25 and Theorem 14.28 *}

lemma circ_extra_circ: "(y ; x\<^sup>\<circ>)\<^sup>\<circ> = (y ; y\<^sup>\<circ> ; x\<^sup>\<circ>)\<^sup>\<circ>"
  by (smt add_commutative add_idempotent circ_add_1 circ_left_unfold mult_associative)

-- {* Theorem 14.15 *}

lemma circ_circ_sub_mult: "1\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

-- {* Theorem 14.27 *}

lemma circ_decompose_11: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (smt circ_add_1 circ_circ_add circ_decompose_4 circ_decompose_8 circ_rtc_2 circ_transitive_equal mult_associative)

-- {* Theorem 14.20 *}

lemma circ_mult_below_circ_circ: "(x ; y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_reflexive dual_order.trans mult_left_isotone mult_right_isotone mult_right_one)

-- {* Theorem 14 counterexamples *}

lemma circ_right_unfold: "1 + x\<^sup>\<circ> ; x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_mult: "1 + x ; (y ; x)\<^sup>\<circ> ; y = (x ; y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_slide: "(x ; y)\<^sup>\<circ> ; x = x ; (y ; x)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_plus_same: "x\<^sup>\<circ> ; x = x ; x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; 1\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult_1: "x\<^sup>\<circ> ; 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma "x\<^sup>\<circ> ; 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> ; x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult: "1\<^sup>\<circ> ; x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_add: "(x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ> = (x + y)\<^sup>\<circ>" nitpick [expect=genuine,card=8] oops
lemma circ_unfold_sum: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> + x\<^sup>\<circ> ; y ; (x + y)\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops

lemma mult_zero_add_circ_2: "(x + y ; 0)\<^sup>\<circ> = x\<^sup>\<circ> + x\<^sup>\<circ> ; y ; 0" nitpick [expect=genuine,card=7] oops
lemma sub_mult_one_circ: "x ; 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> ; x" nitpick [expect=genuine] oops
lemma circ_back_loop_fixpoint: "(z ; y\<^sup>\<circ>) ; y + z = z ; y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x ; y + z) (z ; y\<^sup>\<circ>)" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> ; y\<^sup>\<circ> \<le> (x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops

end

class bounded_left_conway_semiring = bounded_idempotent_left_semiring + left_conway_semiring

begin

lemma circ_top_1: "T\<^sup>\<circ> = T"
  by (metis add_right_top antisym circ_left_unfold mult_left_sub_dist_add_left mult_right_one top_greatest)

lemma circ_right_top_1: "x\<^sup>\<circ> ; T = T"
  by (metis add_right_top circ_loop_fixpoint)

lemma circ_left_top_1: "T ; x\<^sup>\<circ> = T"
  by (metis antisym circ_plus_one mult_left_sub_dist_add_left mult_right_one top_greatest)

lemma mult_top_circ_1: "(x ; T)\<^sup>\<circ> = 1 + x ; T"
  by (metis circ_left_top_1 circ_left_unfold mult_associative)

end

class left_zero_conway_semiring = idempotent_left_zero_semiring + left_conway_semiring

begin

lemma mult_zero_add_circ_2: "(x + y ; 0)\<^sup>\<circ> = x\<^sup>\<circ> + x\<^sup>\<circ> ; y ; 0"
  by (metis mult_associative mult_left_dist_add mult_right_one troeger_3)

lemma circ_unfold_sum: "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> + x\<^sup>\<circ> ; y ; (x + y)\<^sup>\<circ>"
  by (metis mult_associative mult_left_dist_add mult_right_one troeger_1)

end

class left_conway_semiring_1 = left_conway_semiring +
  assumes circ_right_slide: "x ; (y ; x)\<^sup>\<circ> \<le> (x ; y)\<^sup>\<circ> ; x"

begin

-- {* Theorem 1.26 *}

lemma circ_slide_1: "x ; (y ; x)\<^sup>\<circ> = (x ; y)\<^sup>\<circ> ; x"
  by (metis antisym circ_left_slide circ_right_slide)

-- {* Theorem 1.9 *}

lemma circ_right_unfold_1: "1 + x\<^sup>\<circ> ; x = x\<^sup>\<circ>"
  by (metis circ_left_unfold circ_slide_1 mult_left_one mult_right_one)

lemma circ_mult_1: "(x ; y)\<^sup>\<circ> = 1 + x ; (y ; x)\<^sup>\<circ> ; y"
  by (metis circ_left_unfold circ_slide_1 mult_associative)

lemma circ_add_9: "(x + y)\<^sup>\<circ> = (x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (metis circ_add_1 circ_slide_1)

-- {* Theorem 1.7 *}

lemma circ_plus_same: "x\<^sup>\<circ> ; x = x ; x\<^sup>\<circ>"
  by (metis circ_slide_1 mult_left_one mult_right_one)

lemma circ_decompose_12: "x\<^sup>\<circ> ; y\<^sup>\<circ> \<le> (x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (metis circ_add_9 circ_sub_dist_3)

end

class left_zero_conway_semiring_1 = left_zero_conway_semiring + left_conway_semiring_1

begin

lemma circ_back_loop_fixpoint: "(z ; y\<^sup>\<circ>) ; y + z = z ; y\<^sup>\<circ>"
  by (metis add_commutative circ_left_unfold circ_plus_same mult_associative mult_left_dist_add mult_right_one)

-- {* Theorem 1 *}

lemma circ_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x ; y + z) (z ; y\<^sup>\<circ>)"
  by (metis circ_back_loop_fixpoint is_fixpoint_def)

lemma circ_elimination: "x ; y = 0 \<longrightarrow> x ; y\<^sup>\<circ> \<le> x"
  by (metis add_left_zero circ_back_loop_fixpoint circ_plus_same mult_associative mult_left_zero order_refl)

end

class itering_1 = left_conway_semiring_1 +
  assumes circ_simulate: "z ; x \<le> y ; z \<longrightarrow> z ; x\<^sup>\<circ> \<le> y\<^sup>\<circ> ; z"

begin

-- {* Theorem 1.15 *}

lemma circ_circ_mult: "1\<^sup>\<circ> ; x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_add circ_reflexive circ_simulate circ_sub_dist_3 circ_sup_one_left_unfold circ_transitive_equal mult_left_one order_refl)

lemma sub_mult_one_circ: "x ; 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> ; x"
  by (metis circ_simulate mult_left_one mult_right_one order_refl)

lemma circ_import: "p \<le> p ; p \<and> p \<le> 1 \<and> p ; x \<le> x ; p \<longrightarrow> p ; x\<^sup>\<circ> = p ; (p ; x)\<^sup>\<circ>"
  apply rule
  apply (rule antisym)
  apply (smt antisym circ_simulate circ_slide_1 mult_associative mult_right_isotone mult_right_one order_refl test_preserves_equation)
  apply (metis circ_isotone mult_left_isotone mult_left_one mult_right_isotone)
  done

end

class itering_2 = left_conway_semiring_1 +
  assumes circ_simulate_right: "z ; x \<le> y ; z + w \<longrightarrow> z ; x\<^sup>\<circ> \<le> y\<^sup>\<circ> ; (z + w ; x\<^sup>\<circ>)"
  assumes circ_simulate_left: "x ; z \<le> z ; y + w \<longrightarrow> x\<^sup>\<circ> ; z \<le> (z + x\<^sup>\<circ> ; w) ; y\<^sup>\<circ>"

begin

subclass itering_1
  apply unfold_locales
  apply (metis add_right_zero circ_simulate_right mult_left_zero)
  done

lemma circ_simulate_left_1: "x ; z \<le> z ; y \<longrightarrow> x\<^sup>\<circ> ; z \<le> z ; y\<^sup>\<circ> + x\<^sup>\<circ> ; 0"
  by (metis add_right_zero circ_simulate_left mult_associative mult_left_zero mult_right_dist_add)

lemma circ_separate_1: "y ; x \<le> x ; y \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
proof -
  have "y ; x \<le> x ; y \<longrightarrow> y\<^sup>\<circ> ; x ; y\<^sup>\<circ> \<le> x ; y\<^sup>\<circ> + y\<^sup>\<circ> ; 0"
    by (smt circ_simulate_left_1 circ_transitive_equal mult_associative mult_left_isotone mult_left_zero mult_right_dist_add)
  thus ?thesis
    by (smt add_commutative circ_add_1 circ_simulate_right circ_sub_dist_3 less_eq_def mult_associative mult_left_zero zero_right_mult_decreasing)
qed

-- {* Theorem 1.14 *}

lemma circ_circ_mult_1: "x\<^sup>\<circ> ; 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis add_commutative circ_circ_add circ_separate_1 mult_left_one mult_right_one order_refl)

end

class itering_3 = itering_2 + left_zero_conway_semiring_1

begin

lemma circ_simulate_1: "y ; x \<le> x ; y \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (smt add_associative add_right_zero circ_loop_fixpoint circ_simulate circ_simulate_left_1 mult_associative mult_left_zero mult_zero_add_circ_2)

-- {* Theorem 4 *}

lemma atomicity_refinement: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r\<^sup>\<circ> ; q \<le> q ; r\<^sup>\<circ> \<and> q \<le> 1 \<longrightarrow> s ; (x + b + r + l)\<^sup>\<circ> ; q \<le> s ; (x ; b\<^sup>\<circ> ; q + r + l)\<^sup>\<circ>"
proof
  assume 1: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r\<^sup>\<circ> ; q \<le> q ; r\<^sup>\<circ> \<and> q \<le> 1"
  hence "s ; (x + b + r + l)\<^sup>\<circ> ; q = s ; l\<^sup>\<circ> ; (x + b + r)\<^sup>\<circ> ; q"
    by (smt add_commutative add_least_upper_bound circ_separate_1 mult_associative mult_left_sub_dist_add_right mult_right_dist_add order_trans)
  also have "... = s ; l\<^sup>\<circ> ; b\<^sup>\<circ> ; r\<^sup>\<circ> ; q ; (x ; b\<^sup>\<circ> ; r\<^sup>\<circ> ; q)\<^sup>\<circ>" using 1
    by (smt add_associative add_commutative circ_add_1 circ_separate_1 circ_slide_1 mult_associative)
  also have "... \<le> s ; l\<^sup>\<circ> ; b\<^sup>\<circ> ; r\<^sup>\<circ> ; q ; (x ; b\<^sup>\<circ> ; q ; r\<^sup>\<circ>)\<^sup>\<circ>" using 1
    by (metis circ_isotone mult_associative mult_right_isotone)
  also have "... \<le> s ; q ; l\<^sup>\<circ> ; b\<^sup>\<circ> ; r\<^sup>\<circ> ; (x ; b\<^sup>\<circ> ; q ; r\<^sup>\<circ>)\<^sup>\<circ>" using 1
    by (metis mult_left_isotone mult_right_isotone mult_right_one)
  also have "... \<le> s ; l\<^sup>\<circ> ; q ; b\<^sup>\<circ> ; r\<^sup>\<circ> ; (x ; b\<^sup>\<circ> ; q ; r\<^sup>\<circ>)\<^sup>\<circ>" using 1
    by (metis circ_simulate mult_associative mult_left_isotone mult_right_isotone)
  also have "... \<le> s ; l\<^sup>\<circ> ; r\<^sup>\<circ> ; (x ; b\<^sup>\<circ> ; q ; r\<^sup>\<circ>)\<^sup>\<circ>" using 1
    by (metis add_left_zero circ_back_loop_fixpoint circ_plus_same mult_associative mult_left_zero mult_left_isotone mult_right_isotone mult_right_one)
  also have "... \<le> s ; (x ; b\<^sup>\<circ> ; q + r + l)\<^sup>\<circ>" using 1
    by (metis add_commutative circ_add_1 circ_sub_dist_3 mult_associative mult_right_isotone)
  finally show "s ; (x + b + r + l)\<^sup>\<circ> ; q \<le> s ; (x ; b\<^sup>\<circ> ; q + r + l)\<^sup>\<circ>" .
qed

end

class itering = idempotent_left_zero_semiring + circ +
  assumes circ_add: "(x + y)\<^sup>\<circ> = (x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  assumes circ_mult: "(x ; y)\<^sup>\<circ> = 1 + x ; (y ; x)\<^sup>\<circ> ; y"
  assumes circ_simulate_right_plus: "z ; x \<le> y ; y\<^sup>\<circ> ; z + w \<longrightarrow> z ; x\<^sup>\<circ> \<le> y\<^sup>\<circ> ; (z + w ; x\<^sup>\<circ>)"
  assumes circ_simulate_left_plus: "x ; z \<le> z ; y\<^sup>\<circ> + w \<longrightarrow> x\<^sup>\<circ> ; z \<le> (z + x\<^sup>\<circ> ; w) ; y\<^sup>\<circ>"

begin

lemma circ_right_unfold: "1 + x\<^sup>\<circ> ; x = x\<^sup>\<circ>"
  by (metis circ_mult mult_left_one mult_right_one)

lemma circ_slide: "x ; (y ; x)\<^sup>\<circ> = (x ; y)\<^sup>\<circ> ; x"
  by (smt2 circ_mult mult_associative mult_left_dist_add mult_left_one mult_right_dist_add mult_right_one order_refl)

-- {* Theorem 50.6 *}

subclass itering_3
  apply unfold_locales
  apply (metis circ_mult mult_left_one mult_right_one) -- {* Theorem 1.8 *}
  apply (metis circ_slide order_refl)
  apply (metis circ_add circ_slide)
  apply (metis circ_slide order_refl)
  apply (metis add_left_isotone circ_right_unfold mult_left_isotone mult_left_sub_dist_add_left mult_right_one order_trans circ_simulate_right_plus)
  apply (metis add_commutative add_left_upper_bound add_right_isotone circ_mult mult_right_isotone mult_right_one order_trans circ_simulate_left_plus)
  done

lemma circ_simulate_right_plus_1: "z ; x \<le> y ; y\<^sup>\<circ> ; z \<longrightarrow> z ; x\<^sup>\<circ> \<le> y\<^sup>\<circ> ; z"
  by (metis add_right_zero circ_simulate_right_plus mult_left_zero)

lemma circ_simulate_left_plus_1: "x ; z \<le> z ; y\<^sup>\<circ> \<longrightarrow> x\<^sup>\<circ> ; z \<le> z ; y\<^sup>\<circ> + x\<^sup>\<circ> ; 0"
  by (smt add_right_zero circ_simulate_left_plus mult_associative mult_left_zero mult_right_dist_add)

lemma circ_simulate_2: "y ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ> \<longleftrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  apply (rule iffI)
  apply (smt add_associative add_right_zero circ_loop_fixpoint circ_simulate_left_plus_1 mult_associative mult_left_zero mult_zero_add_circ_2)
  apply (metis circ_increasing mult_left_isotone order_trans)
  done

lemma circ_simulate_absorb: "y ; x \<le> x \<longrightarrow> y\<^sup>\<circ> ; x \<le> x + y\<^sup>\<circ> ; 0"
  by (metis circ_simulate_left_plus_1 circ_zero mult_right_one)

lemma circ_simulate_3: "y ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis add_least_upper_bound circ_reflexive circ_simulate_2 less_eq_def mult_right_isotone mult_right_one)

lemma circ_separate_mult_1: "y ; x \<le> x ; y \<longrightarrow> (x ; y)\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis circ_mult_sub_add circ_separate_1)

-- {* Theorem 1.24 *}

lemma circ_separate_unfold: "(y ; x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> + y\<^sup>\<circ> ; y ; x ; x\<^sup>\<circ> ; (y ; x\<^sup>\<circ>)\<^sup>\<circ>"
  by (smt add_commutative circ_add circ_left_unfold circ_loop_fixpoint mult_associative mult_left_dist_add mult_right_one)

-- {* Theorem 3 *}

lemma separation: "y ; x \<le> x ; y\<^sup>\<circ> \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
proof -
  have "y ; x \<le> x ; y\<^sup>\<circ> \<longrightarrow> y\<^sup>\<circ> ; x ; y\<^sup>\<circ> \<le> x ; y\<^sup>\<circ> + y\<^sup>\<circ> ; 0"
    by (smt circ_simulate_left_plus_1 circ_transitive_equal mult_associative mult_left_isotone mult_left_zero mult_right_dist_add)
  thus ?thesis
    by (smt add_commutative circ_add_1 circ_simulate_right circ_sub_dist_3 less_eq_def mult_associative mult_left_zero zero_right_mult_decreasing)
qed

-- {* Theorem 3 *}

lemma simulation: "y ; x \<le> x ; y\<^sup>\<circ> \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis add_right_upper_bound circ_isotone circ_mult_upper_bound circ_sub_dist separation)

-- {* Theorem 3 *}

lemma circ_simulate_4: "y ; x \<le> x ; x\<^sup>\<circ> ; (1 + y) \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
proof
  assume "y ; x \<le> x ; x\<^sup>\<circ> ; (1 + y)"
  hence "(1 + y) ; x \<le> x ; x\<^sup>\<circ> ; (1 + y)"
    by (smt add_associative add_commutative add_left_upper_bound circ_back_loop_fixpoint less_eq_def mult_left_dist_add mult_left_one mult_right_dist_add mult_right_one)
  hence "y ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
    by (metis circ_add_upper_bound circ_increasing circ_reflexive circ_simulate_right_plus_1 mult_right_isotone mult_right_sub_dist_add_right order_trans)
  thus "y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
    by (metis circ_simulate_2)
qed

lemma circ_simulate_5: "y ; x \<le> x ; x\<^sup>\<circ> ; (x + y) \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis circ_add_sub_add_one circ_simulate_4 order_trans)

lemma circ_simulate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis add_commutative circ_back_loop_fixpoint circ_simulate_5 mult_right_sub_dist_add_left order_trans)

-- {* Theorem 3 *}

lemma circ_separate_4: "y ; x \<le> x ; x\<^sup>\<circ> ; (1 + y) \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
proof
  assume 1: "y ; x \<le> x ; x\<^sup>\<circ> ; (1 + y)"
  hence "y ; x ; x\<^sup>\<circ> \<le> x ; x\<^sup>\<circ> + x ; x\<^sup>\<circ> ; y ; x\<^sup>\<circ>"
    by (smt circ_transitive_equal less_eq_def mult_associative mult_left_dist_add mult_right_dist_add mult_right_one)
  also have "... \<le> x ; x\<^sup>\<circ> + x ; x\<^sup>\<circ> ; x\<^sup>\<circ> ; y\<^sup>\<circ>" using 1
    by (metis add_right_isotone circ_simulate_2 circ_simulate_4 mult_associative mult_right_isotone)
  finally have "y ; x ; x\<^sup>\<circ> \<le> x ; x\<^sup>\<circ> ; y\<^sup>\<circ>"
    by (metis circ_reflexive circ_transitive_equal less_eq_def mult_associative mult_right_isotone mult_right_one)
  hence "y\<^sup>\<circ> ; (y\<^sup>\<circ> ; x)\<^sup>\<circ> \<le> x\<^sup>\<circ> ; (y\<^sup>\<circ> + y\<^sup>\<circ> ; 0 ; (y\<^sup>\<circ> ; x)\<^sup>\<circ>)"
    by (smt add_right_upper_bound circ_back_loop_fixpoint circ_simulate_left_plus_1 circ_simulate_right_plus circ_transitive_equal mult_associative order_trans)
  thus "(x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
    by (smt add_commutative antisym circ_add_1 circ_slide circ_sub_dist_3 circ_transitive_equal less_eq_def mult_associative mult_left_zero mult_right_sub_dist_add_right zero_right_mult_decreasing)
qed

lemma circ_separate_5: "y ; x \<le> x ; x\<^sup>\<circ> ; (x + y) \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis circ_add_sub_add_one circ_separate_4 order_trans)

lemma circ_separate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>"
  by (metis add_commutative circ_back_loop_fixpoint circ_separate_5 mult_right_sub_dist_add_left order_trans)

end

class bounded_itering = bounded_idempotent_left_zero_semiring + itering

begin

-- {* Theorem 1 *}

lemma circ_top: "T\<^sup>\<circ> = T"
  by (metis add_right_top antisym circ_left_unfold mult_left_sub_dist_add_left mult_right_one top_greatest)

lemma circ_right_top: "x\<^sup>\<circ> ; T = T"
  by (metis add_right_top circ_loop_fixpoint)

lemma circ_left_top: "T ; x\<^sup>\<circ> = T"
  by (metis add_right_top circ_add circ_right_top circ_top)

lemma mult_top_circ: "(x ; T)\<^sup>\<circ> = 1 + x ; T"
  by (metis circ_left_top circ_mult mult_associative)

-- {* Theorem 1 counterexamples *}

lemma "1 = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x ; x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x ; x\<^sup>\<circ> = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "(x ; y)\<^sup>\<circ> = (x + y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> ; y\<^sup>\<circ> = (x + y)\<^sup>\<circ>" nitpick [expect=genuine,card=6] oops
lemma "(x + y)\<^sup>\<circ> = (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 = 1\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "1 = (x ; 0)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 + x ; 0 = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ> ; 1\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "z + y ; x = x \<longrightarrow> y\<^sup>\<circ> ; z \<le> x" nitpick [expect=genuine] oops
lemma "y ; x = x \<longrightarrow> y\<^sup>\<circ> ; x \<le> x" nitpick [expect=genuine] oops
lemma "z + x ; y = x \<longrightarrow> z ; y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x ; y = x \<longrightarrow> x ; y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x = z + y ; x \<longrightarrow> x \<le> y\<^sup>\<circ> ; z" nitpick [expect=genuine] oops
lemma "x = y ; x \<longrightarrow> x \<le> y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x ; z = z ; y \<longrightarrow> x\<^sup>\<circ> ; z \<le> z ; y\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "x\<^sup>\<circ> = (x ; x)\<^sup>\<circ> ; (x + 1)" oops
lemma "y\<^sup>\<circ> ; x\<^sup>\<circ> \<le> x\<^sup>\<circ> ; y\<^sup>\<circ> \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>" oops
lemma "y ; x \<le> (1 + x) ; y\<^sup>\<circ> \<longrightarrow> (x + y)\<^sup>\<circ> = x\<^sup>\<circ> ; y\<^sup>\<circ>" oops
lemma "y ; x \<le> x \<longrightarrow> y\<^sup>\<circ> ; x \<le> 1\<^sup>\<circ> ; x" oops

end

class left_conway_semiring_L = left_conway_semiring + L +
  assumes one_circ_mult_split: "1\<^sup>\<circ> ; x = L + x"
  assumes L_split_add: "x ; (y + L) \<le> x ; y + L"

begin

lemma L_def: "L = 1\<^sup>\<circ> ; 0"
  by (metis add_right_zero one_circ_mult_split)

lemma one_circ_split: "1\<^sup>\<circ> = L + 1"
  by (metis mult_right_one one_circ_mult_split)

lemma one_circ_circ_split: "1\<^sup>\<circ>\<^sup>\<circ> = L + 1"
  by (metis circ_one one_circ_split)

lemma sub_mult_one_circ: "x ; 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> ; x"
  by (metis L_split_add add_commutative mult_right_one one_circ_mult_split)

lemma one_circ_mult_split_2: "1\<^sup>\<circ> ; x = x ; 1\<^sup>\<circ> + L"
  by (smt add_associative add_commutative add_least_upper_bound circ_back_loop_prefixpoint less_eq_def one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split: "x ; 1\<^sup>\<circ> \<le> x + L"
  by (metis add_commutative one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2: "x ; 1\<^sup>\<circ> \<le> x + 1\<^sup>\<circ>"
  by (metis L_def add_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split: "x ; L \<le> x ; 0 + L"
  by (metis L_split_add add_left_zero)

lemma L_left_zero: "L ; x = L"
  by (metis L_def mult_associative mult_left_zero)

lemma one_circ_L: "1\<^sup>\<circ> ; L = L"
  by (metis L_def circ_transitive_equal mult_associative)

lemma mult_L_circ: "(x ; L)\<^sup>\<circ> = 1 + x ; L"
  by (metis L_left_zero circ_left_unfold mult_associative)

lemma mult_L_circ_mult: "(x ; L)\<^sup>\<circ> ; y = y + x ; L"
  by (metis L_left_zero mult_L_circ mult_associative mult_left_one mult_right_dist_add)

lemma circ_L: "L\<^sup>\<circ> = L + 1"
  by (metis L_left_zero add_commutative circ_left_unfold)

lemma L_below_one_circ: "L \<le> 1\<^sup>\<circ>"
  by (metis L_def zero_right_mult_decreasing)

lemma circ_circ_mult_1: "x\<^sup>\<circ> ; 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis L_left_zero add_commutative circ_add_1 circ_circ_add mult_zero_circ one_circ_split)

lemma circ_circ_mult: "1\<^sup>\<circ> ; x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_mult_1 circ_circ_sub_mult sub_mult_one_circ)

lemma circ_circ_split: "x\<^sup>\<circ>\<^sup>\<circ> = L + x\<^sup>\<circ>"
  by (metis circ_circ_mult one_circ_mult_split)

lemma circ_add_6: "L + (x + y)\<^sup>\<circ> = (x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis add_associative add_commutative circ_add_1 circ_circ_add circ_circ_split circ_decompose_4)

end

class itering_L = itering + L +
  assumes L_def: "L = 1\<^sup>\<circ> ; 0"

begin

lemma one_circ_split: "1\<^sup>\<circ> = L + 1"
  by (metis L_def add_commutative antisym circ_add_upper_bound circ_reflexive circ_simulate_absorb mult_right_one order_refl zero_right_mult_decreasing)

lemma one_circ_mult_split: "1\<^sup>\<circ> ; x = L + x"
  by (metis L_def add_commutative circ_loop_fixpoint mult_associative mult_left_zero mult_zero_circ one_circ_split)

lemma sub_mult_one_circ_split: "x ; 1\<^sup>\<circ> \<le> x + L"
  by (metis add_commutative one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2: "x ; 1\<^sup>\<circ> \<le> x + 1\<^sup>\<circ>"
  by (metis L_def add_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split: "x ; L \<le> x ; 0 + L"
  by (smt L_def mult_associative mult_left_isotone mult_right_dist_add sub_mult_one_circ_split_2)

subclass left_conway_semiring_L
  apply unfold_locales
  apply (metis L_def add_commutative circ_loop_fixpoint mult_associative mult_left_zero mult_zero_circ one_circ_split)
  apply (metis add_commutative mult_associative mult_left_isotone one_circ_mult_split sub_mult_one_circ)
  done

lemma circ_left_induct_mult_L: "L \<le> x \<longrightarrow> x ; y \<le> x \<longrightarrow> x ; y\<^sup>\<circ> \<le> x"
  by (metis circ_one circ_simulate less_eq_def one_circ_mult_split)

lemma circ_left_induct_mult_iff_L: "L \<le> x \<longrightarrow> x ; y \<le> x \<longleftrightarrow> x ; y\<^sup>\<circ> \<le> x"
  by (smt add_least_upper_bound circ_back_loop_fixpoint circ_left_induct_mult_L less_eq_def)

lemma circ_left_induct_L: "L \<le> x \<longrightarrow> x ; y + z \<le> x \<longrightarrow> z ; y\<^sup>\<circ> \<le> x"
  by (metis add_least_upper_bound circ_left_induct_mult_L less_eq_def mult_right_dist_add)

end

(*
end


theory KleeneAlgebra

imports Itering

begin
*)

class star =
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [100] 100)

class left_kleene_algebra = idempotent_left_semiring + star +
  assumes star_left_unfold : "1 + y ; y\<^sup>\<star> \<le> y\<^sup>\<star>"
  assumes star_left_induct : "z + y ; x \<le> x \<longrightarrow> y\<^sup>\<star> ; z \<le> x"

begin

lemma star_left_unfold_equal: "1 + x ; x\<^sup>\<star> = x\<^sup>\<star>"
  by (smt add_right_isotone antisym mult_right_isotone mult_right_one star_left_induct star_left_unfold)

lemma star_left_slide: "(x ; y)\<^sup>\<star> ; x \<le> x ; (y ; x)\<^sup>\<star>"
  by (metis mult_associative mult_left_sub_dist_add mult_right_one star_left_induct star_left_unfold_equal)

lemma star_isotone: "x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (metis add_right_isotone mult_left_isotone order_trans star_left_unfold mult_right_one star_left_induct)

lemma star_add_1_sub: "x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
proof -
  have "x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> ; (y ; (x + y)\<^sup>\<star>)\<^sup>\<star>"
    by (smt add_left_upper_bound mult_right_isotone star_isotone)
  also have "... \<le> x\<^sup>\<star> ; ((x + y) ; (x + y)\<^sup>\<star>)\<^sup>\<star>"
    by (smt add_right_upper_bound mult_left_isotone mult_right_isotone star_isotone)
  also have "... \<le> x\<^sup>\<star> ; (x + y)\<^sup>\<star>\<^sup>\<star>"
    by (smt add_least_upper_bound mult_right_isotone star_isotone star_left_unfold)
  also have "... \<le> (x + y)\<^sup>\<star> ; (x + y)\<^sup>\<star>\<^sup>\<star>"
    by (smt add_left_upper_bound mult_left_isotone star_isotone)
  also have "... \<le> (x + y)\<^sup>\<star>"
    by (smt add_least_upper_bound mult_right_one star_left_induct star_left_unfold)
  finally show "x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by smt
qed

lemma star_add_1: "(x + y)\<^sup>\<star> = x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star>"
  apply (rule antisym)
  apply (smt add_least_upper_bound add_left_upper_bound add_right_upper_bound mult_associative mult_left_one mult_right_dist_add mult_right_one star_left_induct star_left_unfold_equal)
  apply (smt star_add_1_sub)
  done

end

-- {* Theorem 50.1 *}

sublocale left_kleene_algebra < star!: left_conway_semiring where circ = star
  apply unfold_locales
  apply (metis star_left_unfold_equal)
  apply (metis star_left_slide)
  apply (metis star_add_1)
  done

context left_kleene_algebra

begin

-- {* Many lemmas in this class are taken from Georg Struth's Isabelle theories. *}

lemma star_sub_one: "x \<le> 1 \<longrightarrow> x\<^sup>\<star> = 1"
  by (metis add_right_isotone eq_iff less_eq_def mult_right_one star.circ_plus_one star_left_induct)

lemma star_one: "1\<^sup>\<star> = 1"
  by (metis eq_iff star_sub_one)

lemma star_left_induct_mult: "x ; y \<le> y \<longrightarrow> x\<^sup>\<star> ; y \<le> y"
  by (metis add_commutative less_eq_def order_refl star_left_induct)

lemma star_left_induct_mult_iff: "x ; y \<le> y \<longleftrightarrow> x\<^sup>\<star> ; y \<le> y"
  by (metis mult_associative mult_left_isotone mult_left_one mult_right_isotone order_trans star_left_induct_mult star.circ_reflexive star.left_plus_below_circ)

lemma star_involutive: "x\<^sup>\<star> = x\<^sup>\<star>\<^sup>\<star>"
  by (smt antisym less_eq_def mult_left_sub_dist_add_left mult_right_one star_left_induct star.circ_plus_one star.left_plus_below_circ star.circ_transitive_equal)

lemma star_sup_one: "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
  by (metis star.circ_circ_add star_involutive)

lemma star_left_induct_equal: "z + x ; y = y \<longrightarrow> x\<^sup>\<star> ; z \<le> y"
  by (metis order_refl star_left_induct)

lemma star_left_induct_mult_equal: "x ; y = y \<longrightarrow> x\<^sup>\<star> ; y \<le> y"
  by (metis order_refl star_left_induct_mult)

lemma star_star_upper_bound: "x\<^sup>\<star> \<le> z\<^sup>\<star> \<longrightarrow> x\<^sup>\<star>\<^sup>\<star> \<le> z\<^sup>\<star>"
  by (metis star_involutive)

lemma star_simulation_left: "x ; z \<le> z ; y \<longrightarrow> x\<^sup>\<star> ; z \<le> z ; y\<^sup>\<star>"
  by (smt add_commutative add_least_upper_bound mult_right_dist_add less_eq_def mult_associative mult_right_one star.left_plus_below_circ star.circ_increasing star_left_induct star_involutive star.circ_isotone star.circ_reflexive mult_left_sub_dist_add_left)

lemma quasicomm_1: "y ; x \<le> x ; (x + y)\<^sup>\<star> \<longleftrightarrow> y\<^sup>\<star> ; x \<le> x ; (x + y)\<^sup>\<star>"
  by (smt mult_isotone order_refl order_trans star.circ_increasing star_involutive star_simulation_left)

lemma star_rtc_3: "1 + x + y ; y = y \<longrightarrow> x\<^sup>\<star> \<le> y"
  by (metis add_least_upper_bound less_eq_def mult_left_sub_dist_add_left mult_right_one star_left_induct_mult_iff star.circ_sub_dist)

lemma star_decompose_1: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> ; y\<^sup>\<star>)\<^sup>\<star>"
  apply (rule antisym)
  apply (smt add_least_upper_bound mult_isotone mult_left_one mult_right_one star.circ_increasing star.circ_isotone star.circ_reflexive)
  apply (smt star.circ_isotone star.circ_sub_dist_3 star_involutive)
  done

lemma star_sum: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> + y\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_decompose_1 star_involutive)

lemma star_decompose_3: "(x\<^sup>\<star> ; y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_decompose_1 star.circ_add_1)

lemma star_loop_least_fixpoint: "y ; x + z = x \<longrightarrow> y\<^sup>\<star> ; z \<le> x"
  by (metis add_commutative star_left_induct_equal)

lemma star_loop_is_least_fixpoint: "is_least_fixpoint (\<lambda>x . y ; x + z) (y\<^sup>\<star> ; z)"
  by (smt is_least_fixpoint_def star.circ_loop_fixpoint star_loop_least_fixpoint)

lemma star_loop_mu: "\<mu> (\<lambda>x . y ; x + z) = y\<^sup>\<star> ; z"
  by (metis least_fixpoint_same star_loop_is_least_fixpoint)

lemma affine_has_least_fixpoint: "has_least_fixpoint (\<lambda>x . y ; x + z)"
  by (metis has_least_fixpoint_def star_loop_is_least_fixpoint)

lemma circ_add: "(x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> = (x + y)\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_mult: "1 + x ; (y ; x)\<^sup>\<star> ; y = (x ; y)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_plus_same: "x\<^sup>\<star> ; x = x ; x\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_unfold_sum: "(x + y)\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>\<star> ; y ; (x + y)\<^sup>\<star>" nitpick [expect=genuine,card=8] oops
lemma mult_zero_add_circ_2: "(x + y ; 0)\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>\<star> ; y ; 0" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_left: "x ; z \<le> z ; y + w \<longrightarrow> x\<^sup>\<star> ; z \<le> (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_simulate_1: "y ; x \<le> x ; y \<longrightarrow> y\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_1: "y ; x \<le> x ; y \<longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma atomicity_refinement: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r\<^sup>\<star> ; q \<le> q ; r\<^sup>\<star> \<and> q \<le> 1 \<longrightarrow> s ; (x + b + r + l)\<^sup>\<star> ; q \<le> s ; (x ; b\<^sup>\<star> ; q + r + l)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_simulate_left_plus: "x ; z \<le> z ; y\<^sup>\<star> + w \<longrightarrow> x\<^sup>\<star> ; z \<le> (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_separate_unfold: "(y ; x\<^sup>\<star>)\<^sup>\<star> = y\<^sup>\<star> + y\<^sup>\<star> ; y ; x ; x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma separation: "y ; x \<le> x ; y\<^sup>\<star> \<longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_4: "y ; x \<le> x ; x\<^sup>\<star> ; (1 + y) \<longrightarrow> y\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_5: "y ; x \<le> x ; x\<^sup>\<star> ; (x + y) \<longrightarrow> y\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> y\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_4: "y ; x \<le> x ; x\<^sup>\<star> ; (1 + y) \<longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_5: "y ; x \<le> x ; x\<^sup>\<star> ; (x + y) \<longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops

end

class strong_left_kleene_algebra = left_kleene_algebra +
  assumes star_right_induct: "z + x ; y \<le> x \<longrightarrow> z ; y\<^sup>\<star> \<le> x"

begin

lemma star_plus: "y\<^sup>\<star> ; y = y ; y\<^sup>\<star>"
  by (smt add_least_upper_bound antisym less_eq_def mult_left_one mult_right_dist_add star.circ_plus_sub star_left_unfold star_right_induct)

lemma star_slide: "(x ; y)\<^sup>\<star> ; x = x ; (y ; x)\<^sup>\<star>"
  by (smt add_least_upper_bound antisym mult_associative mult_left_isotone mult_left_one mult_right_one order_trans star_left_slide star_left_unfold star_right_induct)

lemma star_simulation_right: "z ; x \<le> y ; z \<longrightarrow> z ; x\<^sup>\<star> \<le> y\<^sup>\<star> ; z"
  by (smt add_commutative add_least_upper_bound add_left_upper_bound mult_associative order_trans star.circ_loop_fixpoint star_left_induct star_plus star_right_induct)

end

sublocale strong_left_kleene_algebra < star!: itering_1 where circ = star
  apply unfold_locales
  apply (metis star_slide order_refl)
  apply (metis star_simulation_right)
  done

context strong_left_kleene_algebra

begin

lemma star_right_induct_mult: "y ; x \<le> y \<longrightarrow> y ; x\<^sup>\<star> \<le> y"
  by (metis add_least_upper_bound eq_refl star_right_induct)

lemma star_right_induct_mult_iff: "y ; x \<le> y \<longleftrightarrow> y ; x\<^sup>\<star> \<le> y"
  by (metis mult_right_isotone order_trans star.circ_increasing star_right_induct_mult)

lemma star_simulation_right_equal: "z ; x = y ; z \<longrightarrow> z ; x\<^sup>\<star> = y\<^sup>\<star> ; z"
  by (metis eq_iff star_simulation_left star_simulation_right)

lemma star_simulation_star: "x ; y \<le> y ; x \<longrightarrow> x\<^sup>\<star> ; y\<^sup>\<star> \<le> y\<^sup>\<star> ; x\<^sup>\<star>"
  by (metis star_simulation_left star_simulation_right)

lemma star_right_induct_equal: "z + y ; x = y \<longrightarrow> z ; x\<^sup>\<star> \<le> y"
  by (metis order_refl star_right_induct)

lemma star_right_induct_mult_equal: "y ; x = y \<longrightarrow> y ; x\<^sup>\<star> \<le> y"
  by (metis order_refl star_right_induct_mult)

lemma star_back_loop_least_fixpoint: "x ; y + z = x \<longrightarrow> z ; y\<^sup>\<star> \<le> x"
  by (metis add_commutative star_right_induct_equal)

lemma star_back_loop_is_least_fixpoint: "is_least_fixpoint (\<lambda>x . x ; y + z) (z ; y\<^sup>\<star>)"
  by (smt add_commutative add_right_isotone antisym is_least_fixpoint_def mult_left_isotone star.circ_back_loop_prefixpoint star_back_loop_least_fixpoint star_right_induct)

lemma star_back_loop_mu: "\<mu> (\<lambda>x . x ; y + z) = z ; y\<^sup>\<star>"
  by (metis least_fixpoint_same star_back_loop_is_least_fixpoint)

lemma star_square: "x\<^sup>\<star> = (1 + x) ; (x ; x)\<^sup>\<star>"
proof -
  let ?f = "\<lambda>y . y ; x + 1"
  have 1: "isotone ?f"
    by (smt add_left_isotone isotone_def mult_left_isotone)
  have 2: "?f \<circ> ?f = (\<lambda>y . y ; (x ; x) + (1 + x))"
    by (simp add: add_associative add_commutative mult_associative mult_left_one mult_right_dist_add o_def)
  thus ?thesis using 1
    by (metis mu_square mult_left_one star_back_loop_mu has_least_fixpoint_def star_back_loop_is_least_fixpoint)
qed

lemma star_square_2: "x\<^sup>\<star> = (x ; x)\<^sup>\<star> ; (x + 1)"
  by (smt add_commutative antisym mult_left_one mult_left_sub_dist_add mult_right_dist_add mult_right_one star.circ_square_2 star_slide star_square)

lemma star_circ_simulate_right_plus: "z ; x \<le> y ; y\<^sup>\<star> ; z + w \<longrightarrow> z ; x\<^sup>\<star> \<le> y\<^sup>\<star> ; (z + w ; x\<^sup>\<star>)"
proof
  assume 1: "z ; x \<le> y ; y\<^sup>\<star> ; z + w"
  have "(z + w ; x\<^sup>\<star>) ; x \<le> z ; x + w ; x\<^sup>\<star>"
    by (metis add_right_isotone mult_associative mult_right_dist_add mult_right_isotone star.circ_increasing star.circ_transitive_equal)
  also have "... \<le> y ; y\<^sup>\<star> ; z + w + w ; x\<^sup>\<star>" using 1
    by (metis add_left_isotone)
  also have "... \<le> y ; y\<^sup>\<star> ; z + w ; x\<^sup>\<star>"
    by (metis add_least_upper_bound add_right_isotone add_right_upper_bound star.circ_back_loop_prefixpoint)
  also have "... \<le> y\<^sup>\<star> ; (z + w ; x\<^sup>\<star>)"
    by (metis add_least_upper_bound mult_isotone mult_left_isotone mult_left_one mult_left_sub_dist_add_left star.circ_reflexive star.left_plus_below_circ)
  finally have "y\<^sup>\<star> ; (z + w ; x\<^sup>\<star>) ; x \<le> y\<^sup>\<star> ; (z + w ; x\<^sup>\<star>)"
    by (metis mult_associative mult_right_isotone star.circ_transitive_equal)
  thus "z ; x\<^sup>\<star> \<le> y\<^sup>\<star> ; (z + w ; x\<^sup>\<star>)"
    by (metis add_least_upper_bound star_right_induct mult_left_sub_dist_add_left star.circ_loop_fixpoint)
qed

lemma star_circ_simulate_left_plus: "x ; z \<le> z ; y\<^sup>\<star> + w \<longrightarrow> x\<^sup>\<star> ; z \<le> (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops

end

class left_zero_kleene_algebra = idempotent_left_zero_semiring + strong_left_kleene_algebra

begin

lemma star_star_absorb: "y\<^sup>\<star> ; (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<star> = (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<star>"
  by (metis add_commutative mult_associative star.circ_decompose_4 star.circ_slide_1 star_decompose_1 star_decompose_3)

lemma star_circ_simulate_left_plus: "x ; z \<le> z ; y\<^sup>\<star> + w \<longrightarrow> x\<^sup>\<star> ; z \<le> (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>"
proof
  assume 1: "x ; z \<le> z ; y\<^sup>\<star> + w"
  have "x ; ((z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>) \<le> x ; z ; y\<^sup>\<star> + x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (smt add_right_isotone mult_associative mult_left_dist_add mult_right_dist_add mult_right_sub_dist_add_left star.circ_loop_fixpoint)
  also have "... \<le> (z + w + x\<^sup>\<star> ; w) ; y\<^sup>\<star>" using 1
    by (smt add_left_divisibility add_left_isotone mult_associative mult_right_dist_add star.circ_transitive_equal)
  also have "... = (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>"
    by (metis add_associative add_right_upper_bound less_eq_def star.circ_loop_fixpoint)
  finally show "x\<^sup>\<star> ; z \<le> (z + x\<^sup>\<star> ; w) ; y\<^sup>\<star>"
    by (metis add_least_upper_bound mult_left_sub_dist_add_left mult_right_one star.circ_right_unfold_1 star_left_induct)
qed

end

-- {* Theorem 2.1 *}

sublocale left_zero_kleene_algebra < star!: itering where circ = star
  apply unfold_locales
  apply (metis star.circ_add_9)
  apply (metis star.circ_mult_1)
  apply (rule star_circ_simulate_right_plus)
  apply (rule star_circ_simulate_left_plus)
  done

class kleene_algebra = left_zero_kleene_algebra + idempotent_semiring

class left_kleene_conway_semiring = left_kleene_algebra + left_conway_semiring

begin

lemma star_below_circ: "x\<^sup>\<star> \<le> x\<^sup>\<circ>"
  by (metis circ_left_unfold mult_right_one order_refl star_left_induct)

lemma star_zero_below_circ_mult: "x\<^sup>\<star> ; 0 \<le> x\<^sup>\<circ> ; y"
  by (metis mult_isotone star_below_circ zero_least)

lemma star_mult_circ: "x\<^sup>\<star> ; x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis add_right_divisibility antisym circ_left_unfold star_left_induct_mult star.circ_loop_fixpoint)

lemma circ_mult_star: "x\<^sup>\<circ> ; x\<^sup>\<star> = x\<^sup>\<circ>"
  by (metis add_associative add_least_upper_bound circ_left_unfold circ_rtc_2 eq_iff left_plus_circ star.circ_add_sub star.circ_back_loop_prefixpoint star.circ_increasing star_below_circ star_mult_circ star_sup_one)

lemma circ_star: "x\<^sup>\<circ>\<^sup>\<star> = x\<^sup>\<circ>"
  by (metis circ_left_unfold left_plus_circ less_def less_le star.circ_increasing star_below_circ star_sup_one)

lemma star_circ: "x\<^sup>\<star>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_add circ_sub_dist less_eq_def star.circ_rtc_2 star_below_circ)

lemma circ_add_3: "(x\<^sup>\<circ> ; y\<^sup>\<circ>)\<^sup>\<star> \<le> (x + y)\<^sup>\<circ>"
  by (metis circ_add_1 circ_isotone circ_left_unfold circ_star mult_left_sub_dist_add_left mult_right_isotone mult_right_one star.circ_isotone)

end

class left_zero_kleene_conway_semiring = left_zero_kleene_algebra + itering

begin

subclass left_kleene_conway_semiring ..

lemma circ_isolate: "x\<^sup>\<circ> = x\<^sup>\<circ> ; 0 + x\<^sup>\<star>"
  by (metis add_commutative antisym circ_add_upper_bound circ_mult_star circ_simulate_absorb star.left_plus_below_circ star_below_circ zero_right_mult_decreasing)

lemma circ_isolate_mult: "x\<^sup>\<circ> ; y = x\<^sup>\<circ> ; 0 + x\<^sup>\<star> ; y"
  by (metis circ_isolate mult_associative mult_left_zero mult_right_dist_add)

lemma circ_isolate_mult_sub: "x\<^sup>\<circ> ; y \<le> x\<^sup>\<circ> + x\<^sup>\<star> ; y"
  by (metis add_left_isotone circ_isolate_mult zero_right_mult_decreasing)

lemma circ_sub_decompose: "(x\<^sup>\<circ> ; y)\<^sup>\<circ> \<le> (x\<^sup>\<star> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (smt add_commutative add_least_upper_bound add_right_upper_bound circ_back_loop_fixpoint circ_isolate_mult mult_zero_add_circ_2 zero_right_mult_decreasing)

lemma circ_add_4: "(x + y)\<^sup>\<circ> = (x\<^sup>\<star> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  apply (rule antisym)
  apply (smt circ_add circ_sub_decompose circ_transitive_equal mult_associative mult_left_isotone)
  apply (smt circ_add circ_isotone mult_left_isotone star_below_circ)
  done

lemma circ_add_5: "(x\<^sup>\<circ> ; y)\<^sup>\<circ> ; x\<^sup>\<circ> = (x\<^sup>\<star> ; y)\<^sup>\<circ> ; x\<^sup>\<circ>"
  by (metis circ_add circ_add_4)

lemma plus_circ: "(x\<^sup>\<star> ; x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (smt add_idempotent circ_add_4 circ_decompose_7 circ_star star.circ_decompose_5 star.right_plus_circ)

lemma "(x\<^sup>\<star> ; y ; x\<^sup>\<star>)\<^sup>\<circ> = (x\<^sup>\<star> ; y)\<^sup>\<circ>" nitpick [expect=genuine] oops

end

class bounded_left_kleene_algebra = bounded_idempotent_left_semiring + left_kleene_algebra

sublocale bounded_left_kleene_algebra < star!: bounded_left_conway_semiring where circ = star ..

class bounded_left_zero_kleene_algebra = bounded_idempotent_left_semiring + left_zero_kleene_algebra

sublocale bounded_left_zero_kleene_algebra < star!: bounded_itering where circ = star ..

class bounded_kleene_algebra = bounded_idempotent_semiring + kleene_algebra

sublocale bounded_kleene_algebra < star!: bounded_itering where circ = star ..

(*
end


theory OmegaAlgebra

imports KleeneAlgebra

begin
*)

class omega =
  fixes omega :: "'a \<Rightarrow> 'a" ("_\<^sup>\<omega>" [100] 100)

class left_omega_algebra = left_kleene_algebra + omega +
  assumes omega_unfold: "y\<^sup>\<omega> = y ; y\<^sup>\<omega>"
  assumes omega_induct: "x \<le> z + y ; x \<longrightarrow> x \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; z"

begin

-- {* Many lemmas in this class are taken from Georg Struth's Isabelle theories. *}

lemma star_zero_below_omega: "x\<^sup>\<star> ; 0 \<le> x\<^sup>\<omega>"
  by (metis add_left_zero omega_unfold star_left_induct_equal)

lemma star_zero_below_omega_zero: "x\<^sup>\<star> ; 0 \<le> x\<^sup>\<omega> ; 0"
  by (metis add_left_zero mult_associative omega_unfold star_left_induct_equal)

lemma omega_induct_mult: "y \<le> x ; y \<longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis add_commutative add_left_zero less_eq_def omega_induct star_zero_below_omega)

lemma omega_sub_dist: "x\<^sup>\<omega> \<le> (x+y)\<^sup>\<omega>"
  by (metis mult_right_sub_dist_add_left omega_induct_mult omega_unfold)

lemma omega_isotone: "x \<le> y \<longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (metis less_eq_def omega_sub_dist)

lemma omega_induct_equal: "y = z + x ; y \<longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> ; z"
  by (metis omega_induct order_refl)

lemma omega_zero: "0\<^sup>\<omega> = 0"
  by (metis mult_left_zero omega_unfold)

lemma omega_one_greatest: "x \<le> 1\<^sup>\<omega>"
  by (metis mult_left_one omega_induct_mult order_refl)

lemma star_mult_omega: "x\<^sup>\<star> ; x\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis antisym_conv mult_isotone omega_unfold star.circ_increasing star_left_induct_mult_equal star_left_induct_mult_iff)

lemma omega_sub_vector: "x\<^sup>\<omega> ; y \<le> x\<^sup>\<omega>"
  by (metis mult_associative omega_induct_mult omega_unfold order_refl)

lemma omega_simulation: "z ; x \<le> y ; z \<longrightarrow> z ; x\<^sup>\<omega> \<le> y\<^sup>\<omega> "
  by (smt less_eq_def mult_associative mult_right_sub_dist_add_left omega_induct_mult omega_unfold)

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

lemma left_plus_omega: "(x ; x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis antisym mult_associative omega_induct_mult omega_unfold order_refl star.left_plus_circ star_mult_omega)

lemma omega_slide: "x ; (y ; x)\<^sup>\<omega> = (x ; y)\<^sup>\<omega>"
  by (metis antisym mult_associative mult_right_isotone omega_simulation omega_unfold order_refl)

lemma omega_simulation_2: "y ; x \<le> x ; y \<longrightarrow> (x ; y)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis less_eq_def mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)

lemma wagner: "(x + y)\<^sup>\<omega> = x ; (x + y)\<^sup>\<omega> + z \<longrightarrow> (x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> ; z"
  by (metis add_commutative add_least_upper_bound eq_iff omega_induct omega_sub_dist star_left_induct)

lemma right_plus_omega: "(x\<^sup>\<star> ; x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis left_plus_omega omega_slide star_mult_omega)

lemma omega_sub_dist_1: "(x ; y\<^sup>\<star>)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis add_least_upper_bound left_plus_omega mult_isotone mult_left_one mult_right_dist_add omega_isotone order_refl star_decompose_1 star.circ_increasing star.circ_plus_one)

lemma omega_sub_dist_2: "(x\<^sup>\<star> ; y)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis add_commutative mult_isotone omega_slide omega_sub_dist_1 star_mult_omega star.circ_sub_dist)

lemma omega_star: "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega>"
  by (metis eq_iff mult_left_sub_dist_add_left mult_right_one omega_sub_vector star.circ_left_unfold)

lemma omega_mult_omega_star: "x\<^sup>\<omega> ; x\<^sup>\<omega>\<^sup>\<star> = x\<^sup>\<omega>"
  by (metis add_least_upper_bound antisym omega_sub_vector star.circ_back_loop_prefixpoint)

lemma omega_sum_unfold_1: "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> ; y ; (x + y)\<^sup>\<omega>"
  by (metis mult_associative mult_right_dist_add omega_unfold wagner)

lemma omega_sum_unfold_2: "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> ; y)\<^sup>\<omega> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>"
  by (metis omega_induct_equal omega_sum_unfold_1)

lemma omega_sum_unfold_3: "(x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis omega_sum_unfold_1 star_left_induct_equal)

lemma omega_decompose: "(x + y)\<^sup>\<omega> = (x\<^sup>\<star> ; y)\<^sup>\<omega> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>"
  by (metis add_least_upper_bound antisym omega_sub_dist_2 omega_sum_unfold_2 omega_sum_unfold_3)

lemma omega_loop_fixpoint: "y ; (y\<^sup>\<omega> + y\<^sup>\<star> ; z) + z = y\<^sup>\<omega> + y\<^sup>\<star> ; z"
  apply (rule antisym)
  apply (smt add_commutative add_least_upper_bound add_right_isotone add_right_upper_bound mult_left_sub_dist_add_left mult_right_isotone omega_induct omega_unfold order_trans star.circ_loop_fixpoint)
  apply (smt add_associative add_left_isotone mult_left_sub_dist_add omega_unfold star.circ_loop_fixpoint)
  done

lemma omega_loop_greatest_fixpoint: "y ; x + z = x \<longrightarrow> x \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; z"
  by (metis add_commutative omega_induct_equal)

lemma omega_square: "x\<^sup>\<omega> = (x ; x)\<^sup>\<omega>"
  by (metis antisym mult_associative omega_induct_mult omega_mult_omega_star omega_slide omega_sub_vector omega_unfold)

lemma mult_zero_omega: "(x ; 0)\<^sup>\<omega> = x ; 0"
  by (metis mult_left_zero omega_slide)

lemma mult_zero_add_omega: "(x + y ; 0)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> ; y ; 0"
  by (smt add_associative add_commutative add_idempotent mult_associative mult_left_one mult_left_zero mult_right_dist_add mult_zero_omega star.mult_zero_circ omega_decompose)

lemma omega_mult_star: "x\<^sup>\<omega> ; x\<^sup>\<star> = x\<^sup>\<omega>"
  by (metis antisym mult_left_sub_dist_add_left mult_right_one omega_sub_vector star.circ_plus_one)

lemma omega_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y ; x + z) (y\<^sup>\<omega> + y\<^sup>\<star> ; z)"
  by (smt is_greatest_fixpoint_def omega_loop_fixpoint omega_loop_greatest_fixpoint)

lemma omega_loop_nu: "\<nu> (\<lambda>x . y ; x + z) = y\<^sup>\<omega> + y\<^sup>\<star> ; z"
  by (metis greatest_fixpoint_same omega_loop_is_greatest_fixpoint)

lemma omega_loop_zero_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y ; x) (y\<^sup>\<omega>)"
  by (metis is_greatest_fixpoint_def omega_induct_mult omega_unfold order_refl)

lemma omega_loop_zero_nu: "\<nu> (\<lambda>x . y ; x) = y\<^sup>\<omega>"
  by (metis greatest_fixpoint_same omega_loop_zero_is_greatest_fixpoint)

lemma affine_has_greatest_fixpoint: "has_greatest_fixpoint (\<lambda>x . y ; x + z)"
  by (metis has_greatest_fixpoint_def omega_loop_is_greatest_fixpoint)

lemma omega_separate_unfold: "(x\<^sup>\<star> ; y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> ; x ; (x\<^sup>\<star> ; y)\<^sup>\<omega>"
  by (metis add_commutative mult_associative omega_slide omega_sum_unfold_1 star.circ_loop_fixpoint)

lemma omega_zero_left_slide: "(x ; y)\<^sup>\<star> ; ((x ; y)\<^sup>\<omega> ; 0 + 1) ; x \<le> x ; (y ; x)\<^sup>\<star> ; ((y ; x)\<^sup>\<omega> ; 0 + 1)"
proof -
  have "x + x ; (y ; x) ; (y ; x)\<^sup>\<star> ; ((y ; x)\<^sup>\<omega> ; 0 + 1) \<le> x ; (y ; x)\<^sup>\<star> ; ((y ; x)\<^sup>\<omega> ; 0 + 1)"
    by (smt add_commutative add_least_upper_bound mult_associative mult_left_isotone mult_right_isotone star.circ_back_loop_prefixpoint star.left_plus_below_circ star.mult_zero_add_circ star.mult_zero_circ)
  hence "((x ; y)\<^sup>\<omega> ; 0 + 1) ; x + x ; y ; (x ; (y ; x)\<^sup>\<star> ; ((y ; x)\<^sup>\<omega> ; 0 + 1)) \<le> x ; (y ; x)\<^sup>\<star> ; ((y ; x)\<^sup>\<omega> ; 0 + 1)"
    by (smt add_associative less_eq_def mult_associative mult_left_one mult_left_sub_dist_add_left mult_left_zero mult_right_dist_add omega_slide star_mult_omega)
  thus ?thesis
    by (metis mult_associative star_left_induct)
qed

lemma omega_zero_add_1: "(x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1) = x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
proof (rule antisym)
  have 1: "(x + y) ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1) \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
    by (smt add_associative add_commutative less_eq_def mult_associative mult_left_isotone mult_right_dist_add star.circ_add_1 star.left_plus_below_circ star.mult_zero_add_circ star.mult_zero_circ star_decompose_1)
  have 2: "1 \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
    by (smt add_commutative mult_associative star.circ_add_1 star.circ_reflexive star.mult_zero_add_circ star.mult_zero_circ)
  have "(y ; x\<^sup>\<star>)\<^sup>\<omega> ; 0 \<le> (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0"
    by (smt mult_left_isotone mult_left_sub_dist_add_right mult_right_one omega_isotone)
  also have 3: "... \<le> (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
    by (smt add_commutative mult_associative mult_left_one mult_right_sub_dist_add_left order_trans star.circ_sub_dist_1 star.mult_zero_add_circ star.mult_zero_circ)
  finally have 4: "(x\<^sup>\<star> ; y)\<^sup>\<omega> ; 0 \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
    by (smt mult_associative mult_right_isotone omega_slide)
  have "y ; (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega> ; 0 \<le> y ; (x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + y))\<^sup>\<star> ; x\<^sup>\<star> ; x\<^sup>\<omega> ; 0 ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0"
    by (metis mult_left_isotone mult_left_sub_dist_add_right mult_right_isotone star.circ_isotone mult_associative mult_left_zero star_mult_omega)
  also have "... \<le> y ; (x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + y))\<^sup>\<star> ; (x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; y)\<^sup>\<omega> ; 0"
    by (smt mult_associative mult_left_isotone mult_left_sub_dist_add_left omega_slide)
  also have "... = y ; (x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; y)\<^sup>\<omega> ; 0"
    by (smt mult_associative mult_left_one mult_left_zero mult_right_dist_add star_mult_omega)
  finally have "x\<^sup>\<star> ; y ; (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega> ; 0 \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)" using 3
    by (smt mult_associative mult_right_isotone omega_slide order_trans)
  hence "(x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega> ; 0 \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)"
    by (smt add_associative add_commutative less_eq_def mult_associative mult_isotone mult_left_one mult_right_one mult_right_sub_dist_add_left order_trans star.circ_loop_fixpoint star.circ_reflexive star.mult_zero_circ)
  hence "(x + y)\<^sup>\<omega> ; 0 \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)" using 4
    by (metis add_least_upper_bound mult_right_dist_add omega_decompose)
  thus "(x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1) \<le> x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1)" using 1 2
    by (smt add_least_upper_bound mult_associative star_left_induct)
next
  have 5: "x\<^sup>\<omega> ; 0 \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)"
    by (metis add_commutative add_left_zero mult_associative mult_left_isotone mult_left_one mult_right_dist_add omega_sub_dist order_trans star_mult_omega zero_right_mult_decreasing)
  have 6: "(y ; x\<^sup>\<star>)\<^sup>\<omega> ; 0 \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)"
    by (metis add_commutative mult_left_isotone omega_sub_dist_1 mult_associative mult_left_sub_dist_add_left order_trans star_mult_omega)
  have 7: "(y ; x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (metis mult_left_one mult_right_sub_dist_add_left star.circ_add_1 star.circ_plus_one)
  hence "(y ; x\<^sup>\<star>)\<^sup>\<star> ; x\<^sup>\<omega> ; 0 \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)"
    by (smt add_associative less_eq_def mult_associative mult_isotone mult_right_dist_add omega_sub_dist)
  hence "(x\<^sup>\<omega> ; 0 + y ; x\<^sup>\<star>)\<^sup>\<omega> ; 0 \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)" using 6
    by (smt add_commutative add_least_upper_bound mult_associative mult_right_dist_add mult_zero_add_omega omega_unfold omega_zero)
  hence "(y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 \<le> y ; x\<^sup>\<star> ; (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)"
    by (smt mult_associative mult_left_one mult_left_zero mult_right_dist_add mult_right_isotone omega_slide)
  also have "... \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)" using 7
    by (metis mult_left_isotone order_refl star.circ_mult_upper_bound star_left_induct_mult_iff)
  finally have "(y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1) \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)" using 5
    by (smt add_commutative add_least_upper_bound mult_associative order_refl star.circ_mult_upper_bound star.circ_reflexive star.circ_sub_dist_1 star.mult_zero_add_circ star.mult_zero_circ star_left_induct)
  hence "(x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1) \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)" using 5
    by (metis add_commutative mult_associative star.circ_isotone star.circ_mult_upper_bound star.mult_zero_add_circ star.mult_zero_circ star_involutive)
  thus "x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) ; (y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<star> ; ((y ; x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))\<^sup>\<omega> ; 0 + 1) \<le> (x + y)\<^sup>\<star> ; ((x + y)\<^sup>\<omega> ; 0 + 1)"
    by (smt add_associative add_commutative mult_associative star.circ_mult_upper_bound star.circ_sub_dist star.mult_zero_add_circ star.mult_zero_circ)
qed

lemma star_omega_greatest: "x\<^sup>\<star>\<^sup>\<omega> = 1\<^sup>\<omega>"
  by (metis add_commutative less_eq_def omega_one_greatest omega_sub_dist star.circ_plus_one)

lemma omega_vector_greatest: "x\<^sup>\<omega> ; 1\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis antisym mult_isotone omega_mult_omega_star omega_one_greatest omega_sub_vector)

lemma mult_greatest_omega: "(x ; 1\<^sup>\<omega>)\<^sup>\<omega> \<le> x ; 1\<^sup>\<omega>"
  by (metis mult_right_isotone omega_slide omega_sub_vector)

lemma omega_mult_star_2: "x\<^sup>\<omega> ; y\<^sup>\<star> = x\<^sup>\<omega>"
  by (metis mult_associative omega_mult_star omega_vector_greatest star_involutive star_omega_greatest)

lemma omega_import: "p \<le> p ; p \<and> p ; x \<le> x ; p \<longrightarrow> p ; x\<^sup>\<omega> = p ; (p ; x)\<^sup>\<omega>"
proof
  assume 1: "p \<le> p ; p \<and> p ; x \<le> x ; p"
  hence "p ; x\<^sup>\<omega> \<le> p ; (p ; x) ; x\<^sup>\<omega>"
    by (metis mult_associative mult_left_isotone omega_unfold)
  also have "... \<le> p ; x ; p ; x\<^sup>\<omega>" using 1
    by (metis mult_associative mult_left_isotone mult_right_isotone)
  finally have "p ; x\<^sup>\<omega> \<le> (p ; x)\<^sup>\<omega>"
    by (metis mult_associative omega_induct_mult)
  hence "p ; x\<^sup>\<omega> \<le> p ; (p ; x)\<^sup>\<omega>" using 1
    by (metis mult_associative mult_left_isotone mult_right_isotone order_trans)
  thus "p ; x\<^sup>\<omega> = p ; (p ; x)\<^sup>\<omega>" using 1
    by (metis add_left_divisibility antisym mult_right_isotone omega_induct_mult omega_slide omega_sub_dist)
qed

lemma omega_circ_simulate_right_plus: "z ; x \<le> y ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; z + w \<longrightarrow> z ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) \<le> (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; (z + w ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>))" nitpick [expect=genuine] oops
lemma omega_circ_simulate_left_plus: "x ; z \<le> z ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) + w \<longrightarrow> (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; z \<le> (z + (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; w) ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>)" nitpick [expect=genuine] oops

end

-- {* Theorem 50.2 *}

sublocale left_omega_algebra < comb0!: left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))"
  apply unfold_locales
  apply (smt add_associative add_commutative less_eq_def mult_associative mult_left_sub_dist_add_left omega_unfold star.circ_loop_fixpoint star_mult_omega)
  apply (smt mult_associative omega_zero_left_slide)
  apply (smt mult_associative omega_zero_add_1)
  done

class left_zero_omega_algebra = left_zero_kleene_algebra + left_omega_algebra

begin

lemma star_omega_absorb: "y\<^sup>\<star> ; (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<omega> = (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<omega>"
proof -
  have "y\<^sup>\<star> ; (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<omega> = y\<^sup>\<star> ; y\<^sup>\<star> ; x ; (y\<^sup>\<star> ; x)\<^sup>\<star> ; y\<^sup>\<omega> + y\<^sup>\<star> ; y\<^sup>\<omega>"
    by (metis add_commutative mult_associative mult_right_dist_add star.circ_back_loop_fixpoint star.circ_plus_same)
  thus ?thesis
    by (metis mult_associative star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
qed

lemma omega_circ_simulate_right_plus: "z ; x \<le> y ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; z + w \<longrightarrow> z ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) \<le> (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; (z + w ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>))"
proof
  assume "z ; x \<le> y ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; z + w"
  hence 1: "z ; x \<le> y\<^sup>\<omega> ; 0 + y ; y\<^sup>\<star> ; z + w"
    by (metis mult_associative mult_left_dist_add mult_left_zero mult_right_dist_add omega_unfold)
  hence "(y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>) ; x \<le> y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; (y\<^sup>\<omega> ; 0 + y ; y\<^sup>\<star> ; z + w) + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
    by (smt add_associative add_left_upper_bound add_right_upper_bound less_eq_def mult_associative mult_left_dist_add mult_left_zero mult_right_dist_add star.circ_back_loop_fixpoint)
  also have "... = y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; y ; y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
    by (smt add_associative add_right_upper_bound less_eq_def mult_associative mult_left_dist_add star.circ_back_loop_fixpoint star_mult_omega)
  also have "... \<le> y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
    by (smt add_commutative add_left_isotone mult_left_isotone star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have "z + (y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>) ; x \<le> y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
    by (smt add_least_upper_bound add_left_upper_bound star.circ_loop_fixpoint)
  hence 2: "z ; x\<^sup>\<star> \<le> y\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<omega> ; 0 + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
    by (metis star_right_induct)
  have "z ; x\<^sup>\<omega> ; 0 \<le> (y\<^sup>\<omega> ; 0 + y ; y\<^sup>\<star> ; z + w) ; x\<^sup>\<omega> ; 0" using 1
    by (smt add_left_divisibility mult_associative mult_right_sub_dist_add_left omega_unfold)
  hence "z ; x\<^sup>\<omega> ; 0 \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; (y\<^sup>\<omega> ; 0 + w ; x\<^sup>\<omega> ; 0)"
    by (smt add_associative add_commutative left_plus_omega mult_associative mult_left_zero mult_right_dist_add omega_induct star.left_plus_circ)
  thus "z ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) \<le> (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; (z + w ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>))" using 2
    by (smt add_associative add_commutative less_eq_def mult_associative mult_left_dist_add mult_left_zero mult_right_dist_add omega_unfold omega_zero star_mult_omega zero_right_mult_decreasing)
qed

lemma omega_circ_simulate_left_plus: "x ; z \<le> z ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) + w \<longrightarrow> (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; z \<le> (z + (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; w) ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>)"
proof
  assume 1: "x ; z \<le> z ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) + w"
  have "x ; (z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>) = x ; z ; y\<^sup>\<omega> ; 0 + x ; z ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x ; x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x ; x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (smt mult_associative mult_left_dist_add omega_unfold)
  also have "... \<le> x ; z ; y\<^sup>\<omega> ; 0 + x ; z ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (metis add_isotone add_right_isotone mult_left_isotone star.left_plus_below_circ)
  also have "... \<le> (z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> + w) ; y\<^sup>\<omega> ; 0 + (z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> + w) ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>" using 1
    by (metis add_left_isotone mult_associative mult_left_dist_add mult_left_isotone)
  also have "... = z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> ; y\<^sup>\<omega> ; 0 + w ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> ; y\<^sup>\<star> + w ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (smt add_associative mult_associative mult_left_zero mult_right_dist_add)
  also have "... = z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (smt add_associative add_commutative add_idempotent mult_associative mult_right_dist_add star.circ_loop_fixpoint star.circ_transitive_equal star_mult_omega)
  finally have "(x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; z \<le> z ; y\<^sup>\<omega> ; 0 + z ; y\<^sup>\<star> + x\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<omega> ; 0 + x\<^sup>\<star> ; w ; y\<^sup>\<star>"
    by (smt add_least_upper_bound add_left_upper_bound mult_associative mult_left_zero mult_right_dist_add star.circ_back_loop_fixpoint star_left_induct)
  thus "(x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; z \<le> (z + (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) ; w) ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>)"
    by (smt add_associative mult_associative mult_left_dist_add mult_left_zero mult_right_dist_add)
qed

lemma omega_translate: "x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) = x\<^sup>\<omega> ; 0 + x\<^sup>\<star>"
  by (metis mult_associative mult_left_dist_add mult_right_one star_mult_omega)

lemma omega_circ_simulate_right: "z ; x \<le> y ; z + w \<longrightarrow> z ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) \<le> (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; (z + w ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>))"
proof
  assume "z ; x \<le> y ; z + w"
  also have "... \<le> y ; (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; z + w"
    by (metis add_left_isotone comb0.circ_reflexive mult_left_isotone mult_right_isotone mult_right_one omega_translate)
  finally show "z ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>) \<le> (y\<^sup>\<omega> ; 0 + y\<^sup>\<star>) ; (z + w ; (x\<^sup>\<omega> ; 0 + x\<^sup>\<star>))"
    by (metis omega_circ_simulate_right_plus)
qed

end

sublocale left_zero_omega_algebra < comb1!: left_conway_semiring_1 where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))"
  apply unfold_locales
  apply (smt eq_iff mult_associative mult_left_dist_add mult_left_zero mult_right_dist_add mult_right_one omega_slide star_slide)
  done

sublocale left_zero_omega_algebra < comb0!: itering where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))"
  apply unfold_locales
  apply (metis comb1.circ_add_9)
  apply (metis comb1.circ_mult_1)
  apply (metis omega_circ_simulate_right_plus omega_translate)
  apply (metis omega_circ_simulate_left_plus omega_translate)
  done

-- {* Theorem 2.2 *}

sublocale left_zero_omega_algebra < comb2!: itering where circ = "(\<lambda>x . x\<^sup>\<omega> ; 0 + x\<^sup>\<star>)"
  apply unfold_locales
  apply (metis comb1.circ_add_9 omega_translate)
  apply (metis comb1.circ_mult_1 omega_translate)
  apply (metis omega_circ_simulate_right_plus)
  apply (metis omega_circ_simulate_left_plus)
  done

class omega_algebra = kleene_algebra + left_zero_omega_algebra

class left_omega_conway_semiring = left_omega_algebra + left_conway_semiring

begin

subclass left_kleene_conway_semiring ..

lemma circ_below_omega_star: "x\<^sup>\<circ> \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis circ_left_unfold mult_right_one omega_induct order_refl)

lemma omega_mult_circ: "x\<^sup>\<omega> ; x\<^sup>\<circ> = x\<^sup>\<omega>"
  by (metis circ_star mult_associative omega_mult_star omega_vector_greatest star_omega_greatest)

lemma circ_mult_omega: "x\<^sup>\<circ> ; x\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis antisym add_right_divisibility circ_loop_fixpoint circ_plus_sub omega_simulation)

lemma circ_omega_greatest: "x\<^sup>\<circ>\<^sup>\<omega> = 1\<^sup>\<omega>"
  by (metis circ_star star_omega_greatest)

lemma omega_circ: "x\<^sup>\<omega>\<^sup>\<circ> = 1 + x\<^sup>\<omega>"
  by (metis antisym circ_left_unfold mult_left_sub_dist_add_left mult_right_one omega_sub_vector)

end

class bounded_left_omega_algebra = bounded_left_kleene_algebra + left_omega_algebra

begin

lemma omega_one: "1\<^sup>\<omega> = T"
  by (smt add_left_top less_eq_def omega_one_greatest)

lemma star_omega_top: "x\<^sup>\<star>\<^sup>\<omega> = T"
  by (metis add_left_top less_eq_def omega_one omega_sub_dist star.circ_plus_one)

lemma omega_vector: "x\<^sup>\<omega> ; T = x\<^sup>\<omega>"
  by (metis add_commutative less_eq_def omega_sub_vector top_right_mult_increasing)

lemma mult_top_omega: "(x ; T)\<^sup>\<omega> \<le> x ; T"
  by (metis mult_right_isotone omega_slide top_greatest)

end

sublocale bounded_left_omega_algebra < comb0!: bounded_left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))" ..

class bounded_left_zero_omega_algebra = bounded_left_zero_kleene_algebra + left_zero_omega_algebra

begin

subclass bounded_left_omega_algebra ..

end

sublocale bounded_left_zero_omega_algebra < comb0!: bounded_itering where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1))" ..

class bounded_omega_algebra = bounded_kleene_algebra + omega_algebra

begin

subclass bounded_left_zero_omega_algebra ..

end

class bounded_left_omega_conway_semiring = bounded_left_omega_algebra + left_omega_conway_semiring

begin

subclass left_kleene_conway_semiring ..

subclass bounded_left_conway_semiring ..

lemma circ_omega: "x\<^sup>\<circ>\<^sup>\<omega> = T"
  by (metis circ_star star_omega_top)

end

class top_left_omega_algebra = bounded_left_omega_algebra +
  assumes top_left_zero: "T ; x = T"

begin

lemma omega_translate_3: "x\<^sup>\<star> ; (x\<^sup>\<omega> ; 0 + 1) = x\<^sup>\<star> ; (x\<^sup>\<omega> + 1)"
  by (metis mult_associative omega_mult_star_2 star.circ_top_1 top_left_zero)

end

-- {* Theorem 50.2 *}

sublocale top_left_omega_algebra < comb4!: left_conway_semiring where circ = "(\<lambda>x . x\<^sup>\<star> ; (x\<^sup>\<omega> + 1))"
  apply unfold_locales
  apply (metis comb0.circ_left_unfold omega_translate_3)
  apply (metis comb0.circ_left_slide omega_translate_3)
  apply (metis comb0.circ_add_1 omega_translate_3)
  done

class top_left_zero_omega_algebra = bounded_left_zero_omega_algebra +
  assumes top_left_zero: "T ; x = T"

begin

lemma omega_translate_2: "x\<^sup>\<omega> ; 0 + x\<^sup>\<star> = x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis mult_associative omega_mult_star_2 star.circ_top top_left_zero)

end

-- {* Theorem 2.3 *}

sublocale top_left_zero_omega_algebra < comb3!: itering where circ = "(\<lambda>x . x\<^sup>\<omega> + x\<^sup>\<star>)"
  apply unfold_locales
  apply (metis comb2.circ_add_9 omega_translate_2)
  apply (metis comb2.circ_mult_1 omega_translate_2)
  apply (metis omega_circ_simulate_right_plus omega_translate_2)
  apply (metis omega_circ_simulate_left_plus omega_translate_2)
  done

class Omega =
  fixes Omega :: "'a \<Rightarrow> 'a" ("_\<^sup>\<Omega>" [100] 100)

(*
end


theory BinaryItering

imports Semiring

begin
*)

class binary_itering = idempotent_left_zero_semiring + while +
  assumes while_productstar: "(x ; y) \<star> z = z + x ; ((y ; x) \<star> (y ; z))"
  assumes while_sumstar: "(x + y) \<star> z = (x \<star> y) \<star> (x \<star> z)"
  assumes while_left_dist_add: "x \<star> (y + z) = (x \<star> y) + (x \<star> z)"
  assumes while_sub_associative: "(x \<star> y) ; z \<le> x \<star> (y ; z)"
  assumes while_simulate_left_plus: "x ; z \<le> z ; (y \<star> 1) + w \<longrightarrow> x \<star> (z ; v) \<le> z ; (y \<star> v) + (x \<star> (w ; (y \<star> v)))"
  assumes while_simulate_right_plus: "z ; x \<le> y ; (y \<star> z) + w \<longrightarrow> z ; (x \<star> v) \<le> y \<star> (z ; v + w ; (x \<star> v))"

begin

-- {* Theorem 9.1 *}

lemma while_zero: "0 \<star> x = x"
  by (metis add_right_zero mult_left_zero while_productstar)

-- {* Theorem 9.4 *}

lemma while_mult_increasing: "x ; y \<le> x \<star> y"
  by (metis add_least_upper_bound mult_left_one order_refl while_productstar)

-- {* Theorem 9.2 *}

lemma while_one_increasing: "x \<le> x \<star> 1"
  by (metis mult_right_one while_mult_increasing)

-- {* Theorem 9.3 *}

lemma while_increasing: "y \<le> x \<star> y"
  by (metis add_left_divisibility mult_left_one while_productstar)

-- {* Theorem 9.42 *}

lemma while_right_isotone: "y \<le> z \<longrightarrow> x \<star> y \<le> x \<star> z"
  by (metis less_eq_def while_left_dist_add)

-- {* Theorem 9.41 *}

lemma while_left_isotone: "x \<le> y \<longrightarrow> x \<star> z \<le> y \<star> z"
  by (metis less_eq_def while_increasing while_sumstar)

lemma while_isotone: "w \<le> x \<and> y \<le> z \<longrightarrow> w \<star> y \<le> x \<star> z"
  by (smt order_trans while_left_isotone while_right_isotone)

-- {* Theorem 9.17 *}

lemma while_left_unfold: "x \<star> y = y + x ; (x \<star> y)"
  by (metis mult_left_one mult_right_one while_productstar)

lemma while_simulate_left_plus_1: "x ; z \<le> z ; (y \<star> 1) \<longrightarrow> x \<star> (z ; w) \<le> z ; (y \<star> w) + (x \<star> 0)"
  by (metis add_right_zero mult_left_zero while_simulate_left_plus)

-- {* Theorem 11.1 *}

lemma while_simulate_absorb: "y ; x \<le> x \<longrightarrow> y \<star> x \<le> x + (y \<star> 0)"
  by (metis while_simulate_left_plus_1 while_zero mult_right_one)

-- {* Theorem 9.10 *}

lemma while_transitive: "x \<star> (x \<star> y) = x \<star> y"
  by (metis add_right_upper_bound add_right_zero antisym while_increasing while_left_dist_add while_left_unfold while_simulate_absorb)

-- {* Theorem 9.25 *}

lemma while_slide: "(x ; y) \<star> (x ; z) = x ; ((y ; x) \<star> z)"
  by (metis mult_associative mult_left_dist_add while_left_unfold while_productstar)

-- {* Theorem 9.21 *}

lemma while_zero_2: "(x ; 0) \<star> y = x ; 0 + y"
  by (metis add_commutative mult_associative mult_left_zero while_left_unfold)

-- {* Theorem 9.5 *}

lemma while_mult_star_exchange: "x ; (x \<star> y) = x \<star> (x ; y)"
  by (metis mult_left_one while_slide)

-- {* Theorem 9.18 *}

lemma while_right_unfold: "x \<star> y = y + (x \<star> (x ; y))"
  by (metis while_left_unfold while_mult_star_exchange)

-- {* Theorem 9.7 *}

lemma while_one_mult_below: "(x \<star> 1) ; y \<le> x \<star> y"
  by (metis mult_left_one while_sub_associative)

lemma while_plus_one: "x \<star> y = y + (x \<star> y)"
  by (metis less_eq_def while_increasing)

-- {* Theorem 9.19 *}

lemma while_rtc_2: "y + x ; y + (x \<star> (x \<star> y)) = x \<star> y"
  by (metis add_associative less_eq_def while_mult_increasing while_plus_one while_transitive)

-- {* Theorem 9.6 *}

lemma while_left_plus_below: "x ; (x \<star> y) \<le> x \<star> y"
  by (metis add_right_divisibility while_left_unfold)

lemma while_right_plus_below: "x \<star> (x ; y) \<le> x \<star> y"
  by (metis while_left_plus_below while_mult_star_exchange)

lemma while_right_plus_below_2: "(x \<star> x) ; y \<le> x \<star> y"
  by (smt order_trans while_right_plus_below while_sub_associative)

-- {* Theorem 9.47 *}

lemma while_mult_transitive: "x \<le> z \<star> y \<and> y \<le> z \<star> w \<longrightarrow> x \<le> z \<star> w"
  by (smt order_trans while_right_isotone while_transitive)

-- {* Theorem 9.48 *}

lemma while_mult_upper_bound: "x \<le> z \<star> 1 \<and> y \<le> z \<star> w \<longrightarrow> x ; y \<le> z \<star> w"
  by (metis less_eq_def mult_right_sub_dist_add_left order_trans while_mult_transitive while_one_mult_below)

lemma while_one_mult_while_below: "(y \<star> 1) ; (y \<star> v) \<le> y \<star> v"
  by (metis order_refl while_mult_upper_bound)

-- {* Theorem 9.34 *}

lemma while_sub_dist: "x \<star> z \<le> (x + y) \<star> z"
  by (metis add_left_upper_bound while_left_isotone)

lemma while_sub_dist_1: "x ; z \<le> (x + y) \<star> z"
  by (metis order_trans while_mult_increasing while_sub_dist)

lemma while_sub_dist_2: "x ; y ; z \<le> (x + y) \<star> z"
  by (metis add_commutative mult_associative while_mult_transitive while_sub_dist_1)

-- {* Theorem 9.36 *}

lemma while_sub_dist_3: "x \<star> (y \<star> z) \<le> (x + y) \<star> z"
  by (metis add_right_upper_bound while_left_isotone while_mult_transitive while_sub_dist)

-- {* Theorem 9.44 *}

lemma while_absorb_2: "x \<le> y \<longrightarrow> y \<star> (x \<star> z) = y \<star> z"
  by (metis add_commutative less_eq_def while_left_dist_add while_plus_one while_sub_dist_3)

lemma while_simulate_right_plus_1: "z ; x \<le> y ; (y \<star> z) \<longrightarrow> z ; (x \<star> w) \<le> y \<star> (z ; w)"
  by (metis add_right_zero mult_left_zero while_simulate_right_plus)

-- {* Theorem 9.39 *}

lemma while_sumstar_1_below: "x \<star> ((y ; (x \<star> 1)) \<star> z) \<le> ((x \<star> 1) ; y) \<star> (x \<star> z)"
proof -
  have 1: "x ; (((x \<star> 1) ; y) \<star> (x \<star> z)) \<le> ((x \<star> 1) ; y) \<star> (x \<star> z)"
    by (smt add_isotone add_right_upper_bound mult_associative mult_left_dist_add mult_right_sub_dist_add_right while_left_unfold)
  have "x \<star> ((y ; (x \<star> 1)) \<star> z) \<le> (x \<star> z) + (x \<star> (y ; (((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z))))"
    by (metis eq_refl while_left_dist_add while_productstar)
  also have "... \<le> (x \<star> z) + (x \<star> ((x \<star> 1) ; y ; (((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z))))"
    by (metis add_right_isotone mult_associative mult_left_one mult_right_sub_dist_add_left while_left_unfold while_right_isotone)
  also have "... \<le> (x \<star> z) + (x \<star> (((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z)))"
    by (metis add_right_isotone add_right_upper_bound while_left_unfold while_right_isotone)
  also have "... \<le> x \<star> (((x \<star> 1) ; y) \<star> (x \<star> z))"
    by (smt add_associative add_left_upper_bound less_eq_def mult_left_one while_left_dist_add while_left_unfold while_sub_associative)
  also have "... \<le> (((x \<star> 1) ; y) \<star> (x \<star> z)) + (x \<star> 0)" using 1
    by (metis while_simulate_absorb)
  also have "... = ((x \<star> 1) ; y) \<star> (x \<star> z)"
    by (smt add_associative add_commutative add_left_zero while_left_dist_add while_left_unfold)
  finally show ?thesis
    .
qed

lemma while_sumstar_2_below: "((x \<star> 1) ; y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> (x \<star> z)"
  by (metis mult_left_one while_left_isotone while_sub_associative)

-- {* Theorem 9.38 *}

lemma while_add_1_below: "x \<star> ((y ; (x \<star> 1)) \<star> z) \<le> (x + y) \<star> z"
proof -
  have "((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z) \<le> (x + y) \<star> z"
    by (metis while_isotone while_one_mult_below while_sumstar)
  hence "(y ; (x \<star> 1)) \<star> z \<le> z + y ; ((x + y) \<star> z)"
    by (metis add_right_isotone mult_right_isotone while_productstar)
  also have "... \<le> (x + y) \<star> z"
    by (metis add_right_isotone add_right_upper_bound mult_left_isotone while_left_unfold)
  finally show ?thesis
    by (metis add_commutative add_right_upper_bound while_isotone while_transitive)
qed

-- {* Theorem 9.16 *}

lemma while_while_while: "((x \<star> 1) \<star> 1) \<star> y = (x \<star> 1) \<star> y"
  by (smt add_commutative less_eq_def mult_right_one while_left_plus_below while_mult_star_exchange while_plus_one while_sumstar while_transitive)

lemma while_one: "(1 \<star> 1) \<star> y = 1 \<star> y"
  by (metis while_while_while while_zero)

-- {* Theorem 9.22 *}

lemma while_add_below: "x + y \<le> x \<star> (y \<star> 1)"
  by (smt add_commutative add_isotone case_split_right order_trans while_increasing while_left_plus_below while_mult_increasing while_plus_one)

-- {* Theorem 9.32 *}

lemma while_add_2: "(x + y) \<star> z \<le> (x \<star> (y \<star> 1)) \<star> z"
  by (metis while_add_below while_left_isotone)

-- {* Theorem 9.45 *}

lemma while_sup_one_left_unfold: "1 \<le> x \<longrightarrow> x ; (x \<star> y) = x \<star> y"
  by (metis less_eq_def mult_left_one mult_right_dist_add while_mult_star_exchange while_right_unfold while_transitive)

lemma while_sup_one_right_unfold: "1 \<le> x \<longrightarrow> x \<star> (x ; y) = x \<star> y"
  by (metis while_mult_star_exchange while_sup_one_left_unfold)

-- {* Theorem 9.30 *}

lemma while_decompose_7: "(x + y) \<star> z = x \<star> (y \<star> ((x + y) \<star> z))"
  by (metis eq_iff order_trans while_increasing while_sub_dist_3 while_transitive)

-- {* Theorem 9.31 *}

lemma while_decompose_8: "(x + y) \<star> z = (x + y) \<star> (x \<star> (y \<star> z))"
  by (metis add_commutative while_sumstar while_transitive)

-- {* Theorem 9.27 *}

lemma while_decompose_9: "(x \<star> (y \<star> 1)) \<star> z = x \<star> (y \<star> ((x \<star> (y \<star> 1)) \<star> z))"
  by (smt add_commutative less_eq_def order_trans while_add_below while_increasing while_sub_dist_3)

lemma while_decompose_10: "(x \<star> (y \<star> 1)) \<star> z = (x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z))"
proof -
  have 1: "(x \<star> (y \<star> 1)) \<star> z \<le> (x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z))"
    by (metis add_associative less_eq_def while_left_dist_add while_plus_one)
  have "x + (y \<star> 1) \<le> x \<star> (y \<star> 1)"
    by (metis add_least_upper_bound while_add_below while_increasing)
  hence "(x \<star> (y \<star> 1)) \<star> (x \<star> (y \<star> z)) \<le> (x \<star> (y \<star> 1)) \<star> z"
    by (smt add_least_upper_bound eq_refl order_trans while_absorb_2 while_one_increasing)
  thus ?thesis using 1
    by (metis antisym)
qed

lemma while_back_loop_fixpoint: "z ; (y \<star> (y ; x)) + z ; x = z ; (y \<star> x)"
  by (metis add_commutative mult_left_dist_add while_right_unfold)

lemma while_back_loop_prefixpoint: "z ; (y \<star> 1) ; y + z \<le> z ; (y \<star> 1)"
  by (metis add_least_upper_bound mult_associative mult_right_isotone mult_right_one order_refl while_increasing while_mult_upper_bound while_one_increasing)

-- {* Theorem 9 *}

lemma while_loop_is_fixpoint: "is_fixpoint (\<lambda>x . y ; x + z) (y \<star> z)"
  by (smt add_commutative is_fixpoint_def while_left_unfold)

-- {* Theorem 9 *}

lemma while_back_loop_is_prefixpoint: "is_prefixpoint (\<lambda>x . x ; y + z) (z ; (y \<star> 1))"
  by (metis is_prefixpoint_def while_back_loop_prefixpoint)

-- {* Theorem 9.20 *}

lemma while_while_add: "(1 + x) \<star> y = (x \<star> 1) \<star> y"
  by (metis add_commutative while_decompose_10 while_sumstar while_zero)

lemma while_while_mult_sub: "x \<star> (1 \<star> y) \<le> (x \<star> 1) \<star> y"
  by (metis add_commutative while_sub_dist_3 while_while_add)

-- {* Theorem 9.11 *}

lemma while_right_plus: "(x \<star> x) \<star> y = x \<star> y"
  by (metis add_idempotent while_plus_one while_sumstar while_transitive)

-- {* Theorem 9.12 *}

lemma while_left_plus: "(x ; (x \<star> 1)) \<star> y = x \<star> y"
  by (metis mult_right_one while_mult_star_exchange while_right_plus)

-- {* Theorem 9.9 *}

lemma while_below_while_one: "x \<star> x \<le> x \<star> 1"
  by (metis while_one_increasing while_right_plus)

lemma while_below_while_one_mult: "x ; (x \<star> x) \<le> x ; (x \<star> 1)"
  by (metis mult_right_isotone while_below_while_one)

-- {* Theorem 9.23 *}

lemma while_add_sub_add_one: "x \<star> (x + y) \<le> x \<star> (1 + y)"
  by (metis add_left_isotone while_below_while_one while_left_dist_add)

lemma while_add_sub_add_one_mult: "x ; (x \<star> (x + y)) \<le> x ; (x \<star> (1 + y))"
  by (metis mult_right_isotone while_add_sub_add_one)

lemma while_elimination: "x ; y = 0 \<longrightarrow> x ; (y \<star> z) = x ; z"
  by (metis add_right_zero mult_associative mult_left_dist_add mult_left_zero while_left_unfold)

-- {* Theorem 9.8 *}

lemma while_square: "(x ; x) \<star> y \<le> x \<star> y"
  by (metis while_left_isotone while_mult_increasing while_right_plus)

-- {* Theorem 9.35 *}

lemma while_mult_sub_add: "(x ; y) \<star> z \<le> (x + y) \<star> z"
  by (metis while_increasing while_isotone while_mult_increasing while_sumstar)

-- {* Theorem 9.43 *}

lemma while_absorb_1: "x \<le> y \<longrightarrow> x \<star> (y \<star> z) = y \<star> z"
  by (metis antisym less_eq_def while_increasing while_sub_dist_3)

lemma while_absorb_3: "x \<le> y \<longrightarrow> x \<star> (y \<star> z) = y \<star> (x \<star> z)"
  by (metis while_absorb_1 while_absorb_2)

-- {* Theorem 9.24 *}

lemma while_square_2: "(x ; x) \<star> ((x + 1) ; y) \<le> x \<star> y"
  by (metis add_least_upper_bound while_increasing while_mult_transitive while_mult_upper_bound while_one_increasing while_square)

lemma while_separate_unfold_below: "(y ; (x \<star> 1)) \<star> z \<le> (y \<star> z) + (y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z))))"
proof -
  have "(y ; (x \<star> 1)) \<star> z = (y \<star> (y ; x ; (x \<star> 1))) \<star> (y \<star> z)"
    by (metis mult_associative mult_left_dist_add mult_right_one while_left_unfold while_sumstar)
  hence "(y ; (x \<star> 1)) \<star> z = (y \<star> z) + (y \<star> (y ; x ; (x \<star> 1))) ; ((y ; (x \<star> 1)) \<star> z)"
    by (metis while_left_unfold)
  also have "... \<le> (y \<star> z) + (y \<star> (y ; x ; (x \<star> 1)) ; ((y ; (x \<star> 1)) \<star> z))"
    by (metis add_right_isotone while_sub_associative)
  also have "... \<le> (y \<star> z) + (y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z))))"
    by (smt add_right_isotone mult_associative mult_right_isotone while_one_mult_below while_right_isotone)
  finally show ?thesis
    .
qed

-- {* Theorem 9.33 *}

lemma while_mult_zero_add: "(x + y ; 0) \<star> z = x \<star> ((y ; 0) \<star> z)"
proof -
  have "(x + y ; 0) \<star> z = (x \<star> (y ; 0)) \<star> (x \<star> z)"
    by (metis while_sumstar)
  also have "... = (x \<star> z) + (x \<star> (y ; 0)) ; ((x \<star> (y ; 0)) \<star> (x \<star> z))"
    by (metis while_left_unfold)
  also have "... \<le> (x \<star> z) + (x \<star> (y ; 0))"
    by (metis add_right_isotone mult_associative mult_left_zero while_sub_associative)
  also have "... = x \<star> ((y ; 0) \<star> z)"
    by (metis add_commutative while_left_dist_add while_zero_2)
  finally show ?thesis
    by (metis le_neq_trans less_def while_sub_dist_3)
qed

lemma while_add_mult_zero: "(x + y ; 0) \<star> y = x \<star> y"
  by (metis less_eq_def while_mult_zero_add while_zero_2 zero_right_mult_decreasing)

lemma while_mult_zero_add_2: "(x + y ; 0) \<star> z = (x \<star> z) + (x \<star> (y ; 0))"
  by (metis add_commutative while_left_dist_add while_mult_zero_add while_zero_2)

lemma while_add_zero_star: "(x + y ; 0) \<star> z = x \<star> (y ; 0 + z)"
  by (metis while_mult_zero_add while_zero_2)

lemma while_unfold_sum: "(x + y) \<star> z = (x \<star> z) + (x \<star> (y ; ((x + y) \<star> z)))"
  apply (rule antisym)
  apply (smt add_associative less_eq_def while_absorb_1 while_increasing while_mult_star_exchange while_right_unfold while_sub_associative while_sumstar)
  apply (metis add_least_upper_bound while_decompose_7 while_mult_increasing while_right_isotone while_sub_dist)
  done

lemma while_simulate_left: "x ; z \<le> z ; y + w \<longrightarrow> x \<star> (z ; v) \<le> z ; (y \<star> v) + (x \<star> (w ; (y \<star> v)))"
  by (metis add_left_isotone mult_right_isotone order_trans while_one_increasing while_simulate_left_plus)

lemma while_simulate_right: "z ; x \<le> y ; z + w \<longrightarrow> z ; (x \<star> v) \<le> y \<star> (z ; v + w ; (x \<star> v))"
proof -
  have "y ; z + w \<le> y ; (y \<star> z) + w"
    by (metis add_left_isotone mult_right_isotone while_increasing)
  thus ?thesis
    by (smt order_trans while_simulate_right_plus)
qed

lemma while_simulate: "z ; x \<le> y ; z \<longrightarrow> z ; (x \<star> v) \<le> y \<star> (z ; v)"
  by (metis add_right_zero mult_left_zero while_simulate_right)

-- {* Theorem 9.14 *}

lemma while_while_mult: "1 \<star> (x \<star> y) = (x \<star> 1) \<star> y"
proof -
  have "(x \<star> 1) \<star> y \<le> (x \<star> 1) ; ((x \<star> 1) \<star> y)"
    by (metis order_refl while_increasing while_sup_one_left_unfold)
  also have "... \<le> 1 \<star> ((x \<star> 1) ; y)"
    by (metis mult_left_one order_refl while_mult_upper_bound while_simulate)
  also have "... \<le> 1 \<star> (x \<star> y)"
    by (metis while_one_mult_below while_right_isotone)
  finally show ?thesis
    by (metis antisym while_sub_dist_3 while_while_add)
qed

lemma while_simulate_left_1: "x ; z \<le> z ; y \<longrightarrow> x \<star> (z ; v) \<le> z ; (y \<star> v) + (x \<star> 0)"
  by (metis add_right_zero mult_left_zero while_simulate_left)

-- {* Theorem 9.46 *}

lemma while_associative_1: "1 \<le> z \<longrightarrow> x \<star> (y ; z) = (x \<star> y) ; z"
proof
  assume 1: "1 \<le> z"
  have "x \<star> (y ; z) \<le> x \<star> ((x \<star> y) ; z)"
    by (metis less_eq_def mult_right_dist_add while_plus_one while_right_isotone)
  also have "... \<le> (x \<star> y) ; (0 \<star> z) + (x \<star> 0)"
    by (metis mult_associative mult_right_sub_dist_add_right while_left_unfold while_simulate_absorb while_zero)
  also have "... \<le> (x \<star> y) ; z + (x \<star> 0) ; z" using 1
    by (metis add_least_upper_bound add_left_upper_bound add_right_upper_bound case_split_right while_plus_one while_zero)
  also have "... = (x \<star> y) ; z"
    by (metis add_right_zero mult_right_dist_add while_left_dist_add)
  finally show "x \<star> (y ; z) = (x \<star> y) ; z"
    by (metis antisym while_sub_associative)
qed

-- {* Theorem 9.29 *}

lemma while_associative_while_1: "x \<star> (y ; (z \<star> 1)) = (x \<star> y) ; (z \<star> 1)"
  by (metis while_associative_1 while_increasing)

-- {* Theorem 9.13 *}

lemma while_one_while: "(x \<star> 1) ; (y \<star> 1) = x \<star> (y \<star> 1)"
  by (metis mult_left_one while_associative_while_1)

lemma while_decompose_5_below: "(x \<star> (y \<star> 1)) \<star> z \<le> (y \<star> (x \<star> 1)) \<star> z"
  by (smt add_commutative mult_left_dist_add mult_right_one while_increasing while_left_unfold while_mult_star_exchange while_one_while while_plus_one while_sumstar)

-- {* Theorem 9.26 *}

lemma while_decompose_5: "(x \<star> (y \<star> 1)) \<star> z = (y \<star> (x \<star> 1)) \<star> z"
  by (metis antisym while_decompose_5_below)

lemma while_decompose_4: "(x \<star> (y \<star> 1)) \<star> z = x \<star> ((y \<star> (x \<star> 1)) \<star> z)"
  by (metis while_decompose_5 while_decompose_9 while_transitive)

-- {* Theorem 11.7 *}

lemma while_simulate_2: "y ; (x \<star> 1) \<le> x \<star> (y \<star> 1) \<longleftrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
proof (rule iffI)
  assume "y ; (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  hence "y ; (x \<star> 1) \<le> (x \<star> 1) ; (y \<star> 1)"
    by (metis while_one_while)
  hence "y \<star> ((x \<star> 1) ; 1) \<le> (x \<star> 1) ; (y \<star> 1) + (y \<star> 0)"
    by (metis while_simulate_left_plus_1)
  hence "y \<star> (x \<star> 1) \<le> (x \<star> (y \<star> 1)) + (y \<star> 0)"
    by (metis mult_right_one while_one_while)
  also have "... = x \<star> (y \<star> 1)"
    by (metis add_commutative less_eq_def order_trans while_increasing while_right_isotone zero_least)
  finally show "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
    .
next
  assume "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  thus "y ; (x \<star> 1) \<le> x \<star> (y \<star> 1)"
    by (metis order_trans while_mult_increasing)
qed

lemma while_simulate_1: "y ; x \<le> x ; y \<longrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  by (metis order_trans while_mult_increasing while_right_isotone while_simulate while_simulate_2)

lemma while_simulate_3: "y ; (x \<star> 1) \<le> x \<star> 1 \<longrightarrow> y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1)"
  by (metis add_idempotent case_split_right while_increasing while_mult_upper_bound while_simulate_2)

-- {* Theorem 9.28 *}

lemma while_extra_while: "(y ; (x \<star> 1)) \<star> z = (y ; (y \<star> (x \<star> 1))) \<star> z"
proof -
  have "y ; (y \<star> (x \<star> 1)) \<le> y ; (x \<star> 1) ; (y ; (x \<star> 1) \<star> 1)"
    by (smt add_commutative add_left_upper_bound mult_right_one order_trans while_back_loop_prefixpoint while_left_isotone while_mult_star_exchange)
  hence 1: "(y ; (y \<star> (x \<star> 1))) \<star> z \<le> (y ; (x \<star> 1)) \<star> z"
    by (metis while_simulate_right_plus_1 mult_left_one)
  have "(y ; (x \<star> 1)) \<star> z \<le> (y ; (y \<star> (x \<star> 1))) \<star> z"
    by (metis while_increasing while_left_isotone while_mult_star_exchange)
  thus ?thesis using 1
    by (metis antisym)
qed

-- {* Theorem 11.6 *}

lemma while_separate_4: "y ; x \<le> x ; (x \<star> (1 + y)) \<longrightarrow> (x + y) \<star> z = x \<star> (y \<star> z)"
proof
  assume 1: "y ; x \<le> x ; (x \<star> (1 + y))"
  hence "(1 + y) ; x \<le> x ; (x \<star> (1 + y))"
    by (smt add_associative add_least_upper_bound mult_left_one mult_left_sub_dist_add_left mult_right_dist_add mult_right_one while_left_unfold)
  hence 2: "(1 + y) ; (x \<star> 1) \<le> x \<star> (1 + y)"
    by (metis mult_right_one while_simulate_right_plus_1)
  have "y ; x ; (x \<star> 1) \<le> x ; (x \<star> ((1 + y) ; (x \<star> 1)))" using 1
    by (smt less_eq_def mult_associative mult_right_dist_add while_associative_1 while_increasing)
  also have "... \<le> x ; (x \<star> (1 + y))" using 2
    by (metis mult_right_isotone order_refl while_mult_transitive)
  also have "... \<le> x ; (x \<star> 1) ; (y \<star> 1)"
    by (metis add_least_upper_bound mult_associative mult_right_isotone while_increasing while_one_increasing while_one_while while_right_isotone)
  finally have "y \<star> (x ; (x \<star> 1)) \<le> x ; (x \<star> 1) ; (y \<star> 1) + (y \<star> 0)"
    by (metis mult_associative mult_right_one while_simulate_left_plus_1)
  hence "(y \<star> 1) ; (y \<star> x) \<le> x ; (x \<star> y \<star> 1) + (y \<star> 0)"
    by (smt less_eq_def mult_associative mult_right_one order_refl order_trans while_absorb_2 while_left_dist_add while_mult_star_exchange while_one_mult_below while_one_while while_plus_one)
  hence "(y \<star> 1) ; ((y \<star> x) \<star> (y \<star> z)) \<le> x \<star> ((y \<star> 1) ; (y \<star> z) + (y \<star> 0) ; ((y \<star> x) \<star> (y \<star> z)))"
    by (metis while_simulate_right_plus)
  also have "... \<le> x \<star> ((y \<star> z) + (y \<star> 0))"
    by (metis add_isotone mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x \<star> y \<star> z"
    by (metis add_right_zero while_left_dist_add)
  finally show "(x + y) \<star> z = x \<star> (y \<star> z)"
    by (smt add_commutative less_eq_def mult_left_one mult_right_dist_add while_plus_one while_sub_associative while_sumstar)
qed

lemma while_separate_5: "y ; x \<le> x ; (x \<star> (x + y)) \<longrightarrow> (x + y) \<star> z = x \<star> (y \<star> z)"
  by (smt order_trans while_add_sub_add_one_mult while_separate_4)

lemma while_separate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> (x + y) \<star> z = x \<star> (y \<star> z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_separate_5)

-- {* Theorem 11.4 *}

lemma while_separate_1: "y ; x \<le> x ; y \<longrightarrow> (x + y) \<star> z = x \<star> (y \<star> z)"
  by (metis add_least_upper_bound less_eq_def mult_left_sub_dist_add_right while_separate_6)

-- {* Theorem 11.2 *}

lemma while_separate_mult_1: "y ; x \<le> x ; y \<longrightarrow> (x ; y) \<star> z \<le> x \<star> (y \<star> z)"
  by (metis while_mult_sub_add while_separate_1)

-- {* Theorem 11.5 *}

lemma separation: "y ; x \<le> x ; (y \<star> 1) \<longrightarrow> (x + y) \<star> z = x \<star> (y \<star> z)"
proof
  assume "y ; x \<le> x ; (y \<star> 1)"
  hence "y \<star> x \<le> x ; (y \<star> 1) + (y \<star> 0)"
    by (metis mult_right_one while_simulate_left_plus_1)
  also have "... \<le> x ; (x \<star> y \<star> 1) + (y \<star> 0)"
    by (metis add_left_isotone while_increasing while_mult_star_exchange)
  finally have "(y \<star> 1) ; (y \<star> x) \<le> x ; (x \<star> y \<star> 1) + (y \<star> 0)"
    by (metis order_refl order_trans while_absorb_2 while_one_mult_below)
  hence "(y \<star> 1) ; ((y \<star> x) \<star> (y \<star> z)) \<le> x \<star> ((y \<star> 1) ; (y \<star> z) + (y \<star> 0) ; ((y \<star> x) \<star> (y \<star> z)))"
    by (metis while_simulate_right_plus)
  also have "... \<le> x \<star> ((y \<star> z) + (y \<star> 0))"
    by (metis add_isotone mult_left_zero order_refl while_absorb_2 while_one_mult_below while_right_isotone while_sub_associative)
  also have "... = x \<star> y \<star> z"
    by (metis add_right_zero while_left_dist_add)
  finally show "(x + y) \<star> z = x \<star> (y \<star> z)"
    by (smt add_commutative less_eq_def mult_left_one mult_right_dist_add while_plus_one while_sub_associative while_sumstar)
qed

-- {* Theorem 11.5 *}

lemma while_separate_left: "y ; x \<le> x ; (y \<star> 1) \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (metis add_commutative separation while_sub_dist_3)

-- {* Theorem 11.6 *}

lemma while_simulate_4: "y ; x \<le> x ; (x \<star> (1 + y)) \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (metis add_commutative while_separate_4 while_sub_dist_3)

lemma while_simulate_5: "y ; x \<le> x ; (x \<star> (x + y)) \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (smt order_trans while_add_sub_add_one_mult while_simulate_4)

lemma while_simulate_6: "y ; x \<le> x ; (x + y) \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (smt order_trans while_increasing while_mult_star_exchange while_simulate_5)

-- {* Theorem 11.3 *}

lemma while_simulate_7: "y ; x \<le> x ; y \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)"
  by (metis add_commutative mult_left_sub_dist_add_left order_trans while_simulate_6)

lemma while_while_mult_1: "x \<star> (1 \<star> y) = 1 \<star> (x \<star> y)"
  by (metis add_commutative mult_left_one mult_right_one order_refl while_separate_1)

-- {* Theorem 9.15 *}

lemma while_while_mult_2: "x \<star> (1 \<star> y) = (x \<star> 1) \<star> y"
  by (metis while_while_mult while_while_mult_1)

-- {* Theorem 11.8 *}

lemma while_import: "p \<le> p ; p \<and> p \<le> 1 \<and> p ; x \<le> x ; p \<longrightarrow> p ; (x \<star> y) = p ; ((p ; x) \<star> y)"
proof
  assume 1: "p \<le> p ; p \<and> p \<le> 1 \<and> p ; x \<le> x ; p"
  hence "p ; (x \<star> y) \<le> (p ; x) \<star> (p ; y)"
    by (smt add_commutative less_eq_def mult_associative mult_left_dist_add mult_right_one while_simulate)
  also have "... \<le> (p ; x) \<star> y" using 1
    by (metis less_eq_def mult_left_one mult_right_dist_add while_right_isotone)
  finally have 2: "p ; (x \<star> y) \<le> p ; ((p ; x) \<star> y)" using 1
    by (smt add_commutative less_eq_def mult_associative mult_left_dist_add mult_right_one)
  have "p ; ((p ; x) \<star> y) \<le> p ; (x \<star> y)" using 1
    by (metis mult_left_isotone mult_left_one mult_right_isotone while_left_isotone)
  thus "p ; (x \<star> y) = p ; ((p ; x) \<star> y)" using 2
    by (metis antisym)
qed

-- {* Theorem 11.8 *}

lemma while_preserve: "p \<le> p ; p \<and> p \<le> 1 \<and> p ; x \<le> x ; p \<longrightarrow> p ; (x \<star> y) = p ; (x \<star> (p ; y))"
  apply rule
  apply (rule antisym)
  apply (metis mult_associative mult_left_isotone mult_right_isotone order_trans while_simulate)
  apply (metis mult_left_isotone mult_left_one mult_right_isotone while_right_isotone)
  done

lemma while_plus_below_while: "(x \<star> 1) ; x \<le> x \<star> 1"
  by (metis order_refl while_mult_upper_bound while_one_increasing)

-- {* Theorem 9.40 *}

lemma while_01: "(w ; (x \<star> 1)) \<star> (y ; z) \<le> (x \<star> w) \<star> ((x \<star> y) ; z)"
proof -
  have "(w ; (x \<star> 1)) \<star> (y ; z) = y ; z + w ; (((x \<star> 1) ; w) \<star> ((x \<star> 1) ; y ; z))"
    by (metis mult_associative while_productstar)
  also have "... \<le> y ; z + w ; ((x \<star> w) \<star> ((x \<star> y) ; z))"
    by (metis add_right_isotone mult_left_isotone mult_right_isotone while_isotone while_one_mult_below)
  also have "... \<le> (x \<star> y) ; z + (x \<star> w) ; ((x \<star> w) \<star> ((x \<star> y) ; z))"
    by (metis add_isotone mult_right_sub_dist_add_left while_left_unfold)
  finally show ?thesis
    by (metis while_left_unfold)
qed

-- {* Theorem 9.37 *}

lemma while_while_sub_associative: "x \<star> (y \<star> z) \<le> ((x \<star> y) \<star> z) + (x \<star> z)"
proof -
  have 1: "x ; (x \<star> 1) \<le> (x \<star> 1) ; ((x \<star> y) \<star> 1)"
    by (metis add_least_upper_bound order_trans while_back_loop_prefixpoint while_left_plus_below)
  have "x \<star> (y \<star> z) \<le> x \<star> ((x \<star> 1) ; (y \<star> z))"
    by (metis mult_left_isotone mult_left_one while_increasing while_right_isotone)
  also have "... \<le> (x \<star> 1) ; ((x \<star> y) \<star> (y \<star> z)) + (x \<star> 0)" using 1
    by (metis while_simulate_left_plus_1)
  also have "... \<le> (x \<star> 1) ; ((x \<star> y) \<star> z) + (x \<star> z)"
    by (metis add_isotone order_refl while_absorb_2 while_increasing while_right_isotone zero_least)
  also have "... = (x \<star> 1) ; z + (x \<star> 1) ; (x \<star> y) ; ((x \<star> y) \<star> z) + (x \<star> z)"
    by (metis mult_associative mult_left_dist_add while_left_unfold)
  also have "... = (x \<star> y) ; ((x \<star> y) \<star> z) + (x \<star> z)"
    by (smt add_associative add_commutative less_eq_def mult_left_one mult_right_dist_add order_refl while_absorb_1 while_plus_one while_sub_associative)
  also have "... \<le> ((x \<star> y) \<star> z) + (x \<star> z)"
    by (metis add_left_isotone while_left_plus_below)
  finally show ?thesis
    .
qed

lemma while_induct: "x ; z \<le> z \<and> y \<le> z \<and> x \<star> 1 \<le> z \<longrightarrow> x \<star> y \<le> z"
  by (metis add_commutative add_least_upper_bound add_left_zero less_eq_def while_right_isotone while_simulate_absorb)

lemma while_sumstar_4_below: "(x \<star> y) \<star> ((x \<star> 1) ; z) \<le> x \<star> ((y ; (x \<star> 1)) \<star> z)" oops
lemma while_sumstar_2: "(x + y) \<star> z = x \<star> ((y ; (x \<star> 1)) \<star> z)" oops
lemma while_sumstar_3: "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> (x \<star> z)" oops
lemma while_decompose_6: "x \<star> ((y ; (x \<star> 1)) \<star> z) = y \<star> ((x ; (y \<star> 1)) \<star> z)" oops
lemma while_finite_associative: "x \<star> 0 = 0 \<longrightarrow> (x \<star> y) ; z = x \<star> (y ; z)" oops
lemma atomicity_refinement: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r \<star> q \<le> q ; (r \<star> 1) \<and> q \<le> 1 \<longrightarrow> s ; ((x + b + r + l) \<star> (q ; z)) \<le> s ; ((x ; (b \<star> q) + r + l) \<star> z)" oops

lemma while_separate_right_plus: "y ; x \<le> x ; (x \<star> (1 + y)) + 1 \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)" oops
lemma while_square_1: "x \<star> 1 = (x ; x) \<star> (x + 1)" oops
lemma while_absorb_below_one: "y ; x \<le> x \<longrightarrow> y \<star> x \<le> 1 \<star> x" oops
lemma "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops
lemma "y ; x \<le> (1 + x) ; (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops

end

class bounded_binary_itering = bounded_idempotent_left_zero_semiring + binary_itering

begin

-- {* Theorem 9 *}

lemma while_right_top: "x \<star> T = T"
  by (metis add_left_top while_left_unfold)

-- {* Theorem 9 *}

lemma while_left_top: "T ; (x \<star> 1) = T"
  by (metis add_right_top antisym top_greatest while_back_loop_prefixpoint)

-- {* Theorem 10.10 counterexamples *}

lemma while_sum_below_one: "y ; ((x + y) \<star> z) \<le> (y ; (x \<star> 1)) \<star> z" nitpick [expect=genuine] oops
lemma while_denest_1: "w ; (x \<star> (y ; z)) \<le> (w ; (x \<star> y)) \<star> z" nitpick [expect=genuine] oops
lemma while_denest_2: "w ; ((x \<star> (y ; w)) \<star> z) = w ; (((x \<star> y) ; w) \<star> z)" nitpick [expect=genuine] oops
lemma while_denest_4: "(x \<star> w) \<star> (x \<star> (y ; z)) = (x \<star> w) \<star> ((x \<star> y) ; z)" nitpick [expect=genuine] oops
lemma while_denest_6: "(w ; (x \<star> y)) \<star> z = z + w ; ((x + y ; w) \<star> (y ; z))" nitpick [expect=genuine] oops
lemma while_decompose_6: "x \<star> ((y ; (x \<star> 1)) \<star> z) = y \<star> ((x ; (y \<star> 1)) \<star> z)" oops
lemma while_finite_associative: "x \<star> 0 = 0 \<longrightarrow> (x \<star> y) ; z = x \<star> (y ; z)" oops
lemma while_sumstar_2: "(x + y) \<star> z = x \<star> ((y ; (x \<star> 1)) \<star> z)" oops
lemma while_sumstar_3: "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> (x \<star> z)" oops
lemma while_sumstar_1: "(x + y) \<star> z = (x \<star> y) \<star> ((x \<star> 1) ; z)" nitpick [expect=genuine] oops
lemma while_mult_zero_zero: "(x ; (y \<star> 0)) \<star> 0 = x ; (y \<star> 0)" nitpick [expect=genuine] oops
lemma while_denest_3: "(x \<star> w) \<star> (x \<star> 0) = (x \<star> w) \<star> 0" nitpick [expect=genuine] oops
lemma while_denest_5: "w ; ((x \<star> (y ; w)) \<star> (x \<star> (y ; z))) = w ; (((x \<star> y) ; w) \<star> ((x \<star> y) ; z))" nitpick [expect=genuine] oops
lemma while_separate_unfold: "(y ; (x \<star> 1)) \<star> z = (y \<star> z) + (y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z))))" nitpick [expect=genuine] oops
lemma while_02: "x \<star> ((x \<star> w) \<star> ((x \<star> y) ; z)) = (x \<star> w) \<star> ((x \<star> y) ; z)" nitpick [expect=genuine] oops

lemma while_denest_0: "w ; (x \<star> (y ; z)) \<le> (w ; (x \<star> y)) \<star> (w ; (x \<star> y) ; z)" nitpick [expect=genuine] oops
lemma while_mult_sub_while_while: "x \<star> (y ; z) \<le> (x \<star> y) \<star> z" nitpick [expect=genuine] oops
lemma while_zero_zero: "(x \<star> 0) \<star> 0 = x \<star> 0" nitpick [expect=genuine] oops
lemma while_sumstar_3_below: "(x \<star> y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> ((x \<star> 1) ; z)" nitpick [expect=genuine] oops

end

class extended_binary_itering = binary_itering +
  assumes while_denest_0: "w ; (x \<star> (y ; z)) \<le> (w ; (x \<star> y)) \<star> (w ; (x \<star> y) ; z)"

begin

-- {* Theorem 10.2 *}

lemma while_denest_1: "w ; (x \<star> (y ; z)) \<le> (w ; (x \<star> y)) \<star> z"
  by (metis order_trans while_denest_0 while_right_plus_below)

lemma while_mult_sub_while_while: "x \<star> (y ; z) \<le> (x \<star> y) \<star> z"
  by (metis mult_left_one while_denest_1)

lemma while_zero_zero: "(x \<star> 0) \<star> 0 = x \<star> 0"
  by (smt less_eq_def mult_left_zero while_left_dist_add while_mult_star_exchange while_mult_sub_while_while while_mult_zero_add_2 while_plus_one while_sumstar)

-- {* Theorem 10.11 *}

lemma while_mult_zero_zero: "(x ; (y \<star> 0)) \<star> 0 = x ; (y \<star> 0)"
  apply (rule antisym)
  apply (metis add_least_upper_bound add_right_zero mult_left_zero mult_right_isotone while_left_dist_add while_slide while_sub_associative)
  apply (metis mult_left_zero while_denest_1)
  done

-- {* Theorem 10.3 *}

lemma while_denest_2: "w ; ((x \<star> (y ; w)) \<star> z) = w ; (((x \<star> y) ; w) \<star> z)"
  apply (rule antisym)
  apply (metis mult_associative while_denest_0 while_simulate_right_plus_1 while_slide)
  apply (metis mult_right_isotone while_left_isotone while_sub_associative)
  done

-- {* Theorem 10.12 *}

lemma while_denest_3: "(x \<star> w) \<star> (x \<star> 0) = (x \<star> w) \<star> 0"
  by (metis while_absorb_2 while_right_isotone while_zero_zero zero_least)

-- {* Theorem 10.15 *}

lemma while_02: "x \<star> ((x \<star> w) \<star> ((x \<star> y) ; z)) = (x \<star> w) \<star> ((x \<star> y) ; z)"
proof -
  have "x ; ((x \<star> w) \<star> ((x \<star> y) ; z)) = x ; (x \<star> y) ; z + x ; (x \<star> w) ; ((x \<star> w) \<star> ((x \<star> y) ; z))"
    by (metis mult_associative mult_left_dist_add while_left_unfold)
  also have "... \<le> (x \<star> w) \<star> ((x \<star> y) ; z)"
    by (metis add_isotone mult_right_sub_dist_add_right while_left_unfold)
  finally have "x \<star> ((x \<star> w) \<star> ((x \<star> y) ; z)) \<le> ((x \<star> w) \<star> ((x \<star> y) ; z)) + (x \<star> 0)"
    by (metis while_simulate_absorb)
  also have "... = (x \<star> w) \<star> ((x \<star> y) ; z)"
    by (metis add_commutative less_eq_def order_trans while_mult_sub_while_while while_right_isotone zero_least)
  finally show ?thesis
    by (metis antisym while_increasing)
qed

lemma while_sumstar_3_below: "(x \<star> y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> ((x \<star> 1) ; z)"
proof -
  have "(x \<star> y) \<star> (x \<star> z) = (x \<star> z) + ((x \<star> y) \<star> ((x \<star> y) ; (x \<star> z)))"
    by (metis while_right_unfold)
  also have "... \<le> (x \<star> z) + ((x \<star> y) \<star> (x \<star> (y ; (x \<star> z))))"
    by (metis add_right_isotone while_right_isotone while_sub_associative)
  also have "... \<le> (x \<star> z) + ((x \<star> y) \<star> (x \<star> ((x \<star> y) \<star> (x \<star> z))))"
    by (smt add_right_isotone order_trans while_increasing while_mult_upper_bound while_one_increasing while_right_isotone)
  also have "... \<le> (x \<star> z) + ((x \<star> y) \<star> (x \<star> ((x \<star> y) \<star> ((x \<star> 1) ; z))))"
    by (metis add_right_isotone mult_left_isotone mult_left_one order_trans while_increasing while_right_isotone while_sumstar while_transitive)
  also have "... = (x \<star> z) + ((x \<star> y) \<star> ((x \<star> 1) ; z))"
    by (metis while_02 while_transitive)
  also have "... = (x \<star> y) \<star> ((x \<star> 1) ; z)"
    by (smt add_associative mult_left_one mult_right_dist_add while_02 while_left_dist_add while_plus_one)
  finally show ?thesis
    .
qed

lemma while_sumstar_4_below: "(x \<star> y) \<star> ((x \<star> 1) ; z) \<le> x \<star> ((y ; (x \<star> 1)) \<star> z)"
proof -
  have "(x \<star> y) \<star> ((x \<star> 1) ; z) = (x \<star> 1) ; z + (x \<star> y) ; ((x \<star> y) \<star> ((x \<star> 1) ; z))"
    by (metis while_left_unfold)
  also have "... \<le> (x \<star> z) + (x \<star> (y ; ((x \<star> y) \<star> ((x \<star> 1) ; z))))"
    by (metis add_isotone while_one_mult_below while_sub_associative)
  also have "... = (x \<star> z) + (x \<star> (y ; (((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z))))"
    by (metis mult_left_one while_denest_2)
  also have "... = x \<star> ((y ; (x \<star> 1)) \<star> z)"
    by (metis while_left_dist_add while_productstar)
  finally show ?thesis
    .
qed

-- {* Theorem 10.10 *}

lemma while_sumstar_1: "(x + y) \<star> z = (x \<star> y) \<star> ((x \<star> 1) ; z)"
  by (smt eq_iff order_trans while_add_1_below while_sumstar while_sumstar_3_below while_sumstar_4_below)

-- {* Theorem 10.8 *}

lemma while_sumstar_2: "(x + y) \<star> z = x \<star> ((y ; (x \<star> 1)) \<star> z)"
  by (metis eq_iff while_add_1_below while_sumstar_1 while_sumstar_4_below)

-- {* Theorem 10.9 *}

lemma while_sumstar_3: "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> (x \<star> z)"
  by (metis eq_iff while_sumstar while_sumstar_1_below while_sumstar_2 while_sumstar_2_below)

-- {* Theorem 10.6 *}

lemma while_decompose_6: "x \<star> ((y ; (x \<star> 1)) \<star> z) = y \<star> ((x ; (y \<star> 1)) \<star> z)"
  by (metis add_commutative while_sumstar_2)

-- {* Theorem 10.4 *}

lemma while_denest_4: "(x \<star> w) \<star> (x \<star> (y ; z)) = (x \<star> w) \<star> ((x \<star> y) ; z)"
proof -
  have "(x \<star> w) \<star> (x \<star> (y ; z)) = x \<star> ((w ; (x \<star> 1)) \<star> (y ; z))"
    by (metis while_sumstar while_sumstar_2)
  also have "... \<le> (x \<star> w) \<star> ((x \<star> y) ; z)"
    by (smt antisym while_01 while_02 while_increasing while_right_isotone)
  finally show ?thesis
    by (metis antisym while_right_isotone while_sub_associative)
qed

-- {* Theorem 10.13 *}

lemma while_denest_5: "w ; ((x \<star> (y ; w)) \<star> (x \<star> (y ; z))) = w ; (((x \<star> y) ; w) \<star> ((x \<star> y) ; z))"
  by (metis while_denest_2 while_denest_4)

-- {* Theorem 10.5 *}

lemma while_denest_6: "(w ; (x \<star> y)) \<star> z = z + w ; ((x + y ; w) \<star> (y ; z))"
  by (metis while_denest_5 while_productstar while_sumstar)

-- {* Theorem 10.1 *}

lemma while_sum_below_one: "y ; ((x + y) \<star> z) \<le> (y ; (x \<star> 1)) \<star> z"
  by (metis add_right_divisibility mult_left_one while_denest_6)

-- {* Theorem 10.14 *}

lemma while_separate_unfold: "(y ; (x \<star> 1)) \<star> z = (y \<star> z) + (y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z))))"
proof -
  have "y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z))) \<le> y \<star> (y ; ((x + y) \<star> z))"
    by (metis mult_associative mult_right_isotone while_sumstar_2 while_left_plus_below while_right_isotone)
  also have "... \<le> (y ; (x \<star> 1)) \<star> z"
    by (metis add_commutative add_left_upper_bound while_absorb_1 while_mult_star_exchange while_sum_below_one)
  finally have "(y \<star> z) + (y \<star> (y ; x ; (x \<star> ((y ; (x \<star> 1)) \<star> z)))) \<le> (y ; (x \<star> 1)) \<star> z"
    by (metis add_least_upper_bound mult_left_sub_dist_add_left mult_right_one while_left_isotone while_left_unfold)
  thus ?thesis
    by (metis antisym while_separate_unfold_below)
qed

-- {* Theorem 10.7 *}

lemma while_finite_associative: "x \<star> 0 = 0 \<longrightarrow> (x \<star> y) ; z = x \<star> (y ; z)"
  by (metis while_denest_4 while_zero)

-- {* Theorem 12 *}

lemma atomicity_refinement: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r \<star> q \<le> q ; (r \<star> 1) \<and> q \<le> 1 \<longrightarrow> s ; ((x + b + r + l) \<star> (q ; z)) \<le> s ; ((x ; (b \<star> q) + r + l) \<star> z)"
proof
  assume 1: "s = s ; q \<and> x = q ; x \<and> q ; b = 0 \<and> r ; b \<le> b ; r \<and> r ; l \<le> l ; r \<and> x ; l \<le> l ; x \<and> b ; l \<le> l ; b \<and> q ; l \<le> l ; q \<and> r \<star> q \<le> q ; (r \<star> 1) \<and> q \<le> 1"
  hence 2: "(x + b + r) ; l \<le> l ; (x + b + r)"
    by (smt add_commutative add_least_upper_bound mult_left_sub_dist_add_right mult_right_dist_add order_trans)
  have "q ; ((x ; (b \<star> r \<star> 1) ; q) \<star> z) \<le> (x ; (b \<star> r \<star> 1) ; q) \<star> z" using 1
    by (smt eq_refl order_trans while_increasing while_mult_upper_bound)
  also have "... \<le> (x ; (b \<star> ((r \<star> 1) ; q))) \<star> z"
    by (metis mult_associative mult_right_isotone while_left_isotone while_sub_associative)
  also have "... \<le> (x ; (b \<star> r \<star> q)) \<star> z"
    by (metis mult_right_isotone while_left_isotone while_one_mult_below while_right_isotone)
  also have "... \<le> (x ; (b \<star> (q ; (r \<star> 1)))) \<star> z" using 1
    by (metis mult_right_isotone while_left_isotone while_right_isotone)
  finally have 3: "q ; ((x ; (b \<star> r \<star> 1) ; q) \<star> z) \<le> (x ; (b \<star> q) ; (r \<star> 1)) \<star> z"
    by (metis mult_associative while_associative_while_1)
  have "s ; ((x + b + r + l) \<star> (q ; z)) = s ; (l \<star> (x + b + r) \<star> (q ; z))" using 2
    by (metis add_commutative while_separate_1)
  also have "... = s ; q ; (l \<star> b \<star> r \<star> (q ; x ; (b \<star> r \<star> 1)) \<star> (q ; z))" using 1
    by (smt add_associative add_commutative while_sumstar_2 while_separate_1)
  also have "... = s ; q ; (l \<star> b \<star> r \<star> (q ; ((x ; (b \<star> r \<star> 1) ; q) \<star> z)))"
    by (smt mult_associative while_slide)
  also have "... \<le> s ; q ; (l \<star> b \<star> r \<star> (x ; (b \<star> q) ; (r \<star> 1)) \<star> z)" using 3
    by (metis mult_right_isotone while_right_isotone)
  also have "... \<le> s ; (l \<star> q ; (b \<star> r \<star> (x ; (b \<star> q) ; (r \<star> 1)) \<star> z))" using 1
    by (smt mult_associative mult_right_isotone while_simulate)
  also have "... = s ; (l \<star> q ; (r \<star> (x ; (b \<star> q) ; (r \<star> 1)) \<star> z))" using 1
    by (metis while_elimination)
  also have "... \<le> s ; (l \<star> r \<star> (x ; (b \<star> q) ; (r \<star> 1)) \<star> z)" using 1
    by (metis add_left_divisibility mult_left_one mult_right_dist_add mult_right_isotone while_right_isotone)
  also have "... = s ; (l \<star> (r + x ; (b \<star> q)) \<star> z)"
    by (metis while_sumstar_2)
  also have "... \<le> s ; ((x ; (b \<star> q) + r + l) \<star> z)"
    by (metis add_commutative mult_right_isotone while_sub_dist_3)
  finally show "s ; ((x + b + r + l) \<star> (q ; z)) \<le> s ; ((x ; (b \<star> q) + r + l) \<star> z)"
    .
qed

end

class bounded_extended_binary_itering = bounded_binary_itering + extended_binary_itering

begin

lemma while_unfold_below: "x = z + y ; x \<longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine] oops
lemma while_unfold_below_1: "x = y ; x \<longrightarrow> x \<le> y \<star> 1" nitpick [expect=genuine] oops
lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_sub_mult_one: "x ; (1 \<star> y) \<le> 1 \<star> x" nitpick [expect=genuine] oops
lemma while_sub_while_zero: "x \<star> z \<le> (x \<star> y) \<star> z" nitpick [expect=genuine] oops
lemma while_while_sub_associative: "x \<star> (y \<star> z) \<le> (x \<star> y) \<star> z" nitpick [expect=genuine] oops
lemma while_top: "T \<star> x = T" nitpick [expect=genuine] oops
lemma while_one_top: "1 \<star> x = T" nitpick [expect=genuine] oops
lemma while_mult_top: "(x ; T) \<star> z = z + x ; T" nitpick [expect=genuine] oops
lemma tarski: "x \<le> x ; T ; x ; T" nitpick [expect=genuine] oops
lemma tarski_mult_top_idempotent: "x ; T = x ; T ; x ; T" nitpick [expect=genuine] oops
lemma tarski_top_omega_below: "x ; T \<le> (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski_top_omega: "x ; T = (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski_below_top_omega: "x \<le> (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski: "x = 0 \<or> T ; x ; T = T" nitpick [expect=genuine] oops
lemma "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z)" nitpick [expect=genuine] oops
lemma "1 = (x ; 0) \<star> 1" nitpick [expect=genuine] oops
lemma while_top_2: "T \<star> z = T ; z" nitpick [expect=genuine] oops
lemma while_mult_top_2: "(x ; T) \<star> z = z + x ; T ; z" nitpick [expect=genuine] oops
lemma while_one_mult: "(x \<star> 1) ; x = x \<star> x" nitpick [expect=genuine] oops
lemma "(x \<star> 1) ; y = x \<star> y" nitpick [expect=genuine] oops
lemma while_associative: "(x \<star> y) ; z = x \<star> (y ; z)" nitpick [expect=genuine] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x ; y + z) (z ; (y \<star> 1))" nitpick [expect=genuine] oops
lemma "1 + x ; 0 = x \<star> 1" nitpick [expect=genuine] oops
lemma "x = x ; (x \<star> 1)" nitpick [expect=genuine] oops
lemma "x ; (x \<star> 1) = x \<star> 1" nitpick [expect=genuine] oops
lemma "x \<star> 1 = x \<star> (1 \<star> 1)" nitpick [expect=genuine] oops
lemma "(x + y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" nitpick [expect=genuine] oops
lemma "z + y ; x = x \<longrightarrow> y \<star> z \<le> x" nitpick [expect=genuine] oops
lemma "y ; x = x \<longrightarrow> y \<star> x \<le> x" nitpick [expect=genuine] oops
lemma "z + x ; y = x \<longrightarrow> z ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; y = x \<longrightarrow> x ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; z = z ; y \<longrightarrow> x \<star> z \<le> z ; (y \<star> 1)" nitpick [expect=genuine] oops
lemma "x ; ((y ; x) \<star> y) \<le> x ; ((y ; x) \<star> 1) ; y" nitpick [expect=genuine] oops

end

(*
end


theory BinaryIteringStrict

imports BinaryItering Itering

begin
*)

class strict_itering = itering + while +
  assumes while_def: "x \<star> y = x\<^sup>\<circ> ; y"

begin

-- {* Theorem 8.1 *}

subclass extended_binary_itering
  apply unfold_locales
  apply (metis add_commutative circ_loop_fixpoint circ_slide mult_associative while_def)
  apply (metis circ_add mult_associative while_def)
  apply (metis mult_left_dist_add while_def)
  apply (metis mult_associative order_refl while_def)
  apply (metis circ_simulate_left_plus mult_associative mult_left_isotone mult_right_dist_add mult_right_one while_def)
  apply (metis circ_simulate_right_plus mult_associative mult_left_isotone mult_right_dist_add while_def)
  apply (metis add_right_divisibility circ_loop_fixpoint mult_associative while_def)
  done

-- {* Theorem 13.1 *}

lemma while_associative: "(x \<star> y) ; z = x \<star> (y ; z)"
  by (metis mult_associative while_def)

-- {* Theorem 13.3 *}

lemma while_one_mult: "(x \<star> 1) ; x = x \<star> x"
  by (metis mult_right_one while_def)

lemma while_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x ; y + z) (z ; (y \<star> 1))"
  by (metis circ_back_loop_is_fixpoint mult_right_one while_def)

-- {* Theorem 13.4 *}

lemma "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z)"
  by (metis mult_right_one while_def while_sumstar)

-- {* Theorem 13.2 *}

lemma "(x \<star> 1) ; y = x \<star> y"
  by (metis mult_left_one while_associative)

lemma "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops
lemma "y ; x \<le> (1 + x) ; (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops
lemma while_square_1: "x \<star> 1 = (x ; x) \<star> (x + 1)" oops
lemma while_absorb_below_one: "y ; x \<le> x \<longrightarrow> y \<star> x \<le> 1 \<star> x" oops

end

class bounded_strict_itering = bounded_itering + strict_itering

begin

subclass bounded_extended_binary_itering ..

-- {* Theorem 13.6 *}

lemma while_top_2: "T \<star> z = T ; z"
  by (metis circ_top while_def)

-- {* Theorem 13.5 *}

lemma while_mult_top_2: "(x ; T) \<star> z = z + x ; T ; z"
  by (metis circ_left_top mult_associative while_def while_left_unfold)

-- {* Theorem 13 counterexamples *}

lemma while_one_top: "1 \<star> x = T" nitpick [expect=genuine] oops
lemma while_top: "T \<star> x = T" nitpick [expect=genuine] oops
lemma while_sub_mult_one: "x ; (1 \<star> y) \<le> 1 \<star> x" nitpick [expect=genuine] oops
lemma while_unfold_below_1: "x = y ; x \<longrightarrow> x \<le> y \<star> 1" nitpick [expect=genuine] oops
lemma while_unfold_below: "x = z + y ; x \<longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine] oops
lemma while_unfold_below: "x \<le> z + y ; x \<longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine] oops
lemma while_mult_top: "(x ; T) \<star> z = z + x ; T" nitpick [expect=genuine] oops
lemma tarski_mult_top_idempotent: "x ; T = x ; T ; x ; T" nitpick [expect=genuine] oops

lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_sub_while_zero: "x \<star> z \<le> (x \<star> y) \<star> z" nitpick [expect=genuine] oops
lemma while_while_sub_associative: "x \<star> (y \<star> z) \<le> (x \<star> y) \<star> z" nitpick [expect=genuine] oops
lemma tarski: "x \<le> x ; T ; x ; T" nitpick [expect=genuine] oops
lemma tarski_top_omega_below: "x ; T \<le> (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski_top_omega: "x ; T = (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski_below_top_omega: "x \<le> (x ; T) \<star> 0" nitpick [expect=genuine] oops
lemma tarski: "x = 0 \<or> T ; x ; T = T" nitpick [expect=genuine] oops
lemma "1 = (x ; 0) \<star> 1" nitpick [expect=genuine] oops
lemma "1 + x ; 0 = x \<star> 1" nitpick [expect=genuine] oops
lemma "x = x ; (x \<star> 1)" nitpick [expect=genuine] oops
lemma "x ; (x \<star> 1) = x \<star> 1" nitpick [expect=genuine] oops
lemma "x \<star> 1 = x \<star> (1 \<star> 1)" nitpick [expect=genuine] oops
lemma "(x + y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" nitpick [expect=genuine] oops
lemma "z + y ; x = x \<longrightarrow> y \<star> z \<le> x" nitpick [expect=genuine] oops
lemma "y ; x = x \<longrightarrow> y \<star> x \<le> x" nitpick [expect=genuine] oops
lemma "z + x ; y = x \<longrightarrow> z ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; y = x \<longrightarrow> x ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; z = z ; y \<longrightarrow> x \<star> z \<le> z ; (y \<star> 1)" nitpick [expect=genuine] oops

end

class binary_itering_unary = extended_binary_itering + circ +
  assumes circ_def: "x\<^sup>\<circ> = x \<star> 1"

begin

-- {* Theorem 50.7 *}

subclass left_conway_semiring
  apply unfold_locales
  apply (metis circ_def while_left_unfold)
  apply (metis circ_def mult_right_one while_one_mult_below while_slide)
  apply (metis circ_def while_one_while while_sumstar_2)
  done

end

class strict_binary_itering = binary_itering + circ +
  assumes while_associative: "(x \<star> y) ; z = x \<star> (y ; z)"
  assumes circ_def: "x\<^sup>\<circ> = x \<star> 1"

begin

-- {* Theorem 2.8 *}

subclass itering
  apply unfold_locales
  apply (metis circ_def mult_left_one_1 while_associative while_sumstar)
  apply (metis circ_def mult_right_one while_associative while_productstar while_slide)
  apply (metis circ_def mult_right_one while_associative mult_left_one_1 while_slide while_simulate_right_plus)
  apply (metis circ_def mult_right_one while_associative mult_left_one_1 while_simulate_left_plus mult_right_dist_add)
  done

-- {* Theorem 8.5 *}

subclass extended_binary_itering
  apply unfold_locales
  apply (metis mult_associative while_associative while_increasing)
  done

end

(*
end


theory Approximation

imports Semiring

begin
*)

class apx =
  fixes apx :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)

class apx_order = apx +
  assumes apx_reflexive: "x \<sqsubseteq> x"
  assumes apx_antisymmetric: "x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> x = y"
  assumes apx_transitive: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"

sublocale apx_order < apx!: order where less_eq = apx and less = "\<lambda>x y . x \<sqsubseteq> y \<and> \<not>  y \<sqsubseteq> x"
  apply unfold_locales
  apply rule
  apply (rule apx_reflexive)
  apply (metis apx_transitive)
  apply (metis apx_antisymmetric)
  done

context apx_order

begin

abbreviation the_apx_least_fixpoint    :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("\<kappa> _" [201] 200)  where "\<kappa>  f \<equiv> apx.the_least_fixpoint f"
abbreviation the_apx_least_prefixpoint :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a" ("p\<kappa> _" [201] 200) where "p\<kappa> f \<equiv> apx.the_least_prefixpoint f"

definition is_apx_meet  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"          where "is_apx_meet x y z \<longleftrightarrow> z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<and> (\<forall>w . w \<sqsubseteq> x \<and> w \<sqsubseteq> y \<longrightarrow> w \<sqsubseteq> z)"
definition has_apx_meet :: "'a \<Rightarrow> 'a \<Rightarrow> bool"               where "has_apx_meet x y \<longleftrightarrow> (\<exists>z . is_apx_meet x y z)"
definition the_apx_meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<triangle>" 66) where "x \<triangle> y = (THE z . is_apx_meet x y z)"

lemma apx_meet_unique: "has_apx_meet x y \<longrightarrow> (\<exists>!z . is_apx_meet x y z)"
  by (smt apx_antisymmetric has_apx_meet_def is_apx_meet_def)

lemma apx_meet: "has_apx_meet x y \<longrightarrow> is_apx_meet x y (x \<triangle> y)"
proof
  assume "has_apx_meet x y"
  hence "is_apx_meet x y (THE z . is_apx_meet x y z)"
    by (smt apx_meet_unique theI')
  thus "is_apx_meet x y (x \<triangle> y)"
    by (simp add: is_apx_meet_def the_apx_meet_def)
qed

lemma apx_greatest_lower_bound: "has_apx_meet x y \<longrightarrow> (w \<sqsubseteq> x \<and> w \<sqsubseteq> y \<longleftrightarrow> w \<sqsubseteq> x \<triangle> y)"
  by (smt apx_meet apx_transitive is_apx_meet_def)

lemma apx_meet_same: "is_apx_meet x y z \<longrightarrow> z = x \<triangle> y"
  by (metis apx_meet apx_meet_unique has_apx_meet_def)

lemma apx_meet_char: "is_apx_meet x y z \<longleftrightarrow> has_apx_meet x y \<and> z = x \<triangle> y"
  by (metis apx_meet_same has_apx_meet_def)

end

class apx_biorder = apx_order + order

begin

lemma mu_below_kappa: "has_least_fixpoint f \<and> apx.has_least_fixpoint f \<longrightarrow> \<mu> f \<le> \<kappa> f"
  by (metis apx.least_fixpoint apx.is_least_fixpoint_def is_least_fixpoint_def least_fixpoint)

lemma kappa_below_nu: "has_greatest_fixpoint f \<and> apx.has_least_fixpoint f \<longrightarrow> \<kappa> f \<le> \<nu> f"
  by (metis apx.least_fixpoint greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def)

lemma kappa_apx_below_mu: "has_least_fixpoint f \<and> apx.has_least_fixpoint f \<longrightarrow> \<kappa> f \<sqsubseteq> \<mu> f"
  by (metis apx.least_fixpoint apx.is_least_fixpoint_def is_least_fixpoint_def least_fixpoint)

lemma kappa_apx_below_nu: "has_greatest_fixpoint f \<and> apx.has_least_fixpoint f \<longrightarrow> \<kappa> f \<sqsubseteq> \<nu> f"
  by (metis apx.least_fixpoint greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def)

end

class apx_semiring = apx_biorder + idempotent_left_semiring + L +
  assumes apx_L_least: "L \<sqsubseteq> x"
  assumes add_apx_left_isotone: "x \<sqsubseteq> y \<longrightarrow> x + z \<sqsubseteq> y + z"
  assumes mult_apx_left_isotone: "x \<sqsubseteq> y \<longrightarrow> x ; z \<sqsubseteq> y ; z"
  assumes mult_apx_right_isotone: "x \<sqsubseteq> y \<longrightarrow> z ; x \<sqsubseteq> z ; y"

begin

lemma add_apx_right_isotone: "x \<sqsubseteq> y \<longrightarrow> z + x \<sqsubseteq> z + y"
  by (metis add_apx_left_isotone add_commutative)

lemma add_apx_isotone: "w \<sqsubseteq> y \<and> x \<sqsubseteq> z \<longrightarrow> w + x \<sqsubseteq> y + z"
  by (metis add_apx_left_isotone add_apx_right_isotone apx_transitive)

lemma mult_apx_isotone: "w \<sqsubseteq> y \<and> x \<sqsubseteq> z \<longrightarrow> w ; x \<sqsubseteq> y ; z"
  by (metis apx_transitive mult_apx_left_isotone mult_apx_right_isotone)

lemma affine_apx_isotone: "apx.isotone (\<lambda>x . y ; x + z)"
  by (smt add_apx_left_isotone apx.isotone_def mult_apx_right_isotone)

end

(*
end


theory LatticeOrderedSemiring

imports Semiring

begin
*)

-- {* Many results in this theory are taken from a joint paper with Rudolf Berghammer. *}

-- {* M0-algebra *}

class lattice_ordered_pre_left_semiring = pre_left_semiring + bounded_distributive_lattice

begin

subclass bounded_pre_left_semiring
  apply unfold_locales
  apply (metis add_right_top_1)
  done

lemma top_mult_right_one: "x ; T = x ; T ; 1"
  by (metis add_commutative add_left_top less_eq_def mult_semi_associative mult_sub_right_one)

lemma mult_left_sub_dist_meet_left: "x ; (y \<frown> z) \<le> x ; y"
  by (metis meet.add_left_upper_bound mult_right_isotone)

lemma mult_left_sub_dist_meet_right: "x ; (y \<frown> z) \<le> x ; z"
  by (metis meet_commutative mult_left_sub_dist_meet_left)

lemma mult_right_sub_dist_meet_left: "(x \<frown> y) ; z \<le> x ; z"
  by (metis meet.add_left_upper_bound mult_left_isotone)

lemma mult_right_sub_dist_meet_right: "(x \<frown> y) ; z \<le> y ; z"
  by (metis meet.add_right_upper_bound mult_left_isotone)

lemma mult_right_sub_dist_meet: "(x \<frown> y) ; z \<le> x ; z \<frown> y ; z"
  by (metis meet.add_least_upper_bound mult_right_sub_dist_meet_left mult_right_sub_dist_meet_right)

-- {* Figure 1: fundamental properties *}

definition total             :: "'a \<Rightarrow> bool" where "total x \<longleftrightarrow> x ; T = T"
definition co_total          :: "'a \<Rightarrow> bool" where "co_total x \<longleftrightarrow> x ; 0 = 0"
definition transitive        :: "'a \<Rightarrow> bool" where "transitive x \<longleftrightarrow> x ; x \<le> x"
definition dense             :: "'a \<Rightarrow> bool" where "dense x \<longleftrightarrow> x \<le> x ; x"
definition reflexive         :: "'a \<Rightarrow> bool" where "reflexive x \<longleftrightarrow> 1 \<le> x"
definition co_reflexive      :: "'a \<Rightarrow> bool" where "co_reflexive x \<longleftrightarrow> x \<le> 1"
definition idempotent        :: "'a \<Rightarrow> bool" where "idempotent x \<longleftrightarrow> x ; x = x"
definition up_closed         :: "'a \<Rightarrow> bool" where "up_closed x \<longleftrightarrow> x ; 1 = x"
definition add_distributive  :: "'a \<Rightarrow> bool" where "add_distributive x \<longleftrightarrow> (\<forall>y z . x ; (y + z) = x ; y + x ; z)"
definition meet_distributive :: "'a \<Rightarrow> bool" where "meet_distributive x \<longleftrightarrow> (\<forall>y z . x ; (y \<frown> z) = x ; y \<frown> x ; z)"
definition contact           :: "'a \<Rightarrow> bool" where "contact x \<longleftrightarrow> x ; x + 1 = x"
definition kernel            :: "'a \<Rightarrow> bool" where "kernel x \<longleftrightarrow> x ; x \<frown> 1 = x ; 1"
definition add_dist_contact  :: "'a \<Rightarrow> bool" where "add_dist_contact x \<longleftrightarrow> add_distributive x \<and> contact x"
definition meet_dist_kernel  :: "'a \<Rightarrow> bool" where "meet_dist_kernel x \<longleftrightarrow> meet_distributive x \<and> kernel x"
definition test              :: "'a \<Rightarrow> bool" where "test x \<longleftrightarrow> x ; T \<frown> 1 = x"
definition co_test           :: "'a \<Rightarrow> bool" where "co_test x \<longleftrightarrow> x ; 0 + 1 = x"
definition co_vector         :: "'a \<Rightarrow> bool" where "co_vector x \<longleftrightarrow> x ; 0 = x"

-- {* CPCP Theorem 5 / Figure 2: relations between properties *}

lemma reflexive_total: "reflexive x \<longrightarrow> total x"
  by (metis eq_iff mult_isotone mult_left_one meet.zero_least reflexive_def total_def)

lemma reflexive_dense: "reflexive x \<longrightarrow> dense x"
  by (metis mult_left_isotone mult_left_one reflexive_def dense_def)

lemma reflexive_transitive_up_closed: "reflexive x \<and> transitive x \<longrightarrow> up_closed x"
  by (metis antisym_conv mult_isotone mult_sub_right_one reflexive_def reflexive_dense transitive_def dense_def up_closed_def)

lemma co_reflexive_co_total: "co_reflexive x \<longrightarrow> co_total x"
  by (metis co_reflexive_def co_total_def eq_iff mult_left_isotone mult_left_one zero_least)

lemma co_reflexive_transitive: "co_reflexive x \<longrightarrow> transitive x"
  by (metis co_reflexive_def mult_left_isotone mult_left_one transitive_def)

lemma idempotent_transitive_dense: "idempotent x \<longleftrightarrow> transitive x \<and> dense x"
  by (metis eq_iff transitive_def dense_def idempotent_def)

lemma contact_reflexive: "contact x \<longrightarrow> reflexive x"
  by (metis contact_def add_right_upper_bound reflexive_def)

lemma contact_transitive: "contact x \<longrightarrow> transitive x"
  by (metis contact_def add_left_upper_bound transitive_def)

lemma contact_dense: "contact x \<longrightarrow> dense x"
  by (metis contact_reflexive reflexive_dense)

lemma contact_idempotent: "contact x \<longrightarrow> idempotent x"
  by (metis contact_transitive contact_dense idempotent_transitive_dense)

lemma contact_up_closed: "contact x \<longrightarrow> up_closed x"
  by (metis contact_def contact_idempotent dual_order.antisym mult_left_sub_dist_add_right mult_sub_right_one idempotent_def up_closed_def)

lemma contact_reflexive_idempotent_up_closed: "contact x \<longleftrightarrow> reflexive x \<and> idempotent x \<and> up_closed x"
  by (metis contact_def contact_idempotent contact_up_closed add_commutative less_eq_def reflexive_def idempotent_def)

lemma kernel_co_reflexive: "kernel x \<longrightarrow> co_reflexive x"
  by (metis co_reflexive_def kernel_def meet.add_least_upper_bound mult_sub_right_one)

lemma kernel_transitive: "kernel x \<longrightarrow> transitive x"
  by (metis co_reflexive_transitive kernel_co_reflexive)

lemma kernel_dense: "kernel x \<longrightarrow> dense x"
  by (metis kernel_def meet.add_least_upper_bound mult_sub_right_one dense_def)

lemma kernel_idempotent: "kernel x \<longrightarrow> idempotent x"
  by (metis kernel_transitive kernel_dense idempotent_transitive_dense)

lemma kernel_up_closed: "kernel x \<longrightarrow> up_closed x"
  by (metis co_reflexive_def kernel_co_reflexive kernel_def kernel_idempotent meet_less_eq_def idempotent_def up_closed_def)

lemma kernel_co_reflexive_idempotent_up_closed: "kernel x \<longleftrightarrow> co_reflexive x \<and> idempotent x \<and> up_closed x"
  by (metis co_reflexive_def kernel_def kernel_idempotent kernel_up_closed meet.less_eq_def meet_commutative idempotent_def up_closed_def)

lemma test_co_reflexive: "test x \<longrightarrow> co_reflexive x"
  by (metis co_reflexive_def meet.add_right_upper_bound test_def)

lemma test_up_closed: "test x \<longrightarrow> up_closed x"
  by (metis eq_iff mult_left_one mult_sub_right_one mult_right_sub_dist_meet test_def top_mult_right_one up_closed_def)

lemma co_test_reflexive: "co_test x \<longrightarrow> reflexive x"
  by (metis co_test_def add_right_upper_bound reflexive_def)

lemma co_test_transitive: "co_test x \<longrightarrow> transitive x"
  by (smt2 co_test_def add_associative less_eq_def mult_left_one mult_left_zero mult_right_dist_add mult_semi_associative transitive_def)

lemma co_test_idempotent: "co_test x \<longrightarrow> idempotent x"
  by (metis co_test_reflexive co_test_transitive reflexive_dense idempotent_transitive_dense)

lemma co_test_up_closed: "co_test x \<longrightarrow> up_closed x"
  by (metis co_test_reflexive co_test_idempotent contact_def contact_up_closed add_commutative less_eq_def reflexive_def idempotent_def)

lemma co_test_contact: "co_test x \<longrightarrow> contact x"
  by (metis co_test_reflexive co_test_idempotent co_test_up_closed contact_reflexive_idempotent_up_closed)

lemma vector_transitive: "vector x \<longrightarrow> transitive x"
  by (metis mult_right_isotone meet.zero_least vector_def transitive_def)

lemma vector_up_closed: "vector x \<longrightarrow> up_closed x"
  by (metis vector_def top_mult_right_one up_closed_def)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

-- {* total *}

lemma one_total: "total 1"
  by (metis mult_left_one total_def)

lemma top_total: "total T"
  by (metis top_mult_top total_def)

lemma add_total: "total x \<and> total y \<longrightarrow> total (x + y)"
  by (metis add_left_top mult_right_dist_add total_def)

-- {* co-total *}

lemma zero_co_total: "co_total 0"
  by (metis co_total_def mult_left_zero)

lemma one_co_total: "co_total 1"
  by (metis co_total_def mult_left_one)

lemma add_co_total: "co_total x \<and> co_total y \<longrightarrow> co_total (x + y)"
  by (metis co_total_def add_right_zero mult_right_dist_add)

lemma meet_co_total: "co_total x \<and> co_total y \<longrightarrow> co_total (x \<frown> y)"
  by (metis co_total_def add_left_zero antisym_conv less_eq_def mult_right_sub_dist_meet_left)

lemma comp_co_total: "co_total x \<and> co_total y \<longrightarrow> co_total (x ; y)"
  by (metis co_total_def eq_iff mult_semi_associative zero_least)

-- {* sub-transitive *}

lemma zero_transitive: "transitive 0"
  by (metis mult_left_zero zero_least transitive_def)

lemma one_transitive: "transitive 1"
  by (metis mult_left_one order_refl transitive_def)

lemma top_transitive: "transitive T"
  by (metis meet.zero_least transitive_def)

lemma meet_transitive: "transitive x \<and> transitive y \<longrightarrow> transitive (x \<frown> y)"
  by (smt2 meet.less_eq_def meet_associative meet_commutative mult_left_sub_dist_meet_left mult_right_sub_dist_meet_left transitive_def)

-- {* dense *}

lemma zero_dense: "dense 0"
  by (metis zero_least dense_def)

lemma one_dense: "dense 1"
  by (metis mult_sub_right_one dense_def)

lemma top_dense: "dense T"
  by (metis top_left_mult_increasing dense_def)

lemma add_dense: "dense x \<and> dense y \<longrightarrow> dense (x + y)"
proof
  assume "dense x \<and> dense y"
  hence "x \<le> x ; x \<and> y \<le> y ; y"
    by (metis dense_def)
  hence "x \<le> (x + y) ; (x + y) \<and> y \<le> (x + y) ; (x + y)"
    by (metis add_left_upper_bound dual_order.trans mult_isotone add_right_upper_bound)
  hence "x + y \<le> (x + y) ; (x + y)"
    by (metis add_least_upper_bound)
  thus "dense (x + y)"
    by (metis dense_def)
qed

-- {* reflexive *}

lemma one_reflexive: "reflexive 1"
  by (metis order_refl reflexive_def)

lemma top_reflexive: "reflexive T"
  by (metis meet.zero_least reflexive_def)

lemma add_reflexive: "reflexive x \<and> reflexive y \<longrightarrow> reflexive (x + y)"
  by (metis add_associative less_eq_def reflexive_def)

lemma meet_reflexive: "reflexive x \<and> reflexive y \<longrightarrow> reflexive (x \<frown> y)"
  by (metis meet.add_least_upper_bound reflexive_def)

lemma comp_reflexive: "reflexive x \<and> reflexive y \<longrightarrow> reflexive (x ; y)"
  by (metis mult_left_isotone mult_left_one order_trans reflexive_def)

-- {* co-reflexive *}

lemma zero_co_reflexive: "co_reflexive 0"
  by (metis co_reflexive_def zero_least)

lemma one_co_reflexive: "co_reflexive 1"
  by (metis co_reflexive_def order_refl)

lemma add_co_reflexive: "co_reflexive x \<and> co_reflexive y \<longrightarrow> co_reflexive (x + y)"
  by (metis co_reflexive_def add_least_upper_bound)

lemma meet_co_reflexive: "co_reflexive x \<and> co_reflexive y \<longrightarrow> co_reflexive (x \<frown> y)"
  by (metis co_reflexive_def meet.less_eq_def meet_associative)

lemma comp_co_reflexive: "co_reflexive x \<and> co_reflexive y \<longrightarrow> co_reflexive (x ; y)"
  by (metis co_reflexive_def mult_isotone mult_left_one)

-- {* idempotent *}

lemma zero_idempotent: "idempotent 0"
  by (metis mult_left_zero idempotent_def)

lemma one_idempotent: "idempotent 1"
  by (metis mult_left_one idempotent_def)

lemma top_idempotent: "idempotent T"
  by (metis top_mult_top idempotent_def)

-- {* up-closed *}

lemma zero_up_closed: "up_closed 0"
  by (metis mult_left_zero up_closed_def)

lemma one_up_closed: "up_closed 1"
  by (metis mult_left_one up_closed_def)

lemma top_up_closed: "up_closed T"
  by (metis top_mult_top vector_def vector_up_closed)

lemma add_up_closed: "up_closed x \<and> up_closed y \<longrightarrow> up_closed (x + y)"
  by (metis mult_right_dist_add up_closed_def)

lemma meet_up_closed: "up_closed x \<and> up_closed y \<longrightarrow> up_closed (x \<frown> y)"
  by (metis dual_order.antisym mult_sub_right_one mult_right_sub_dist_meet up_closed_def)

lemma comp_up_closed: "up_closed x \<and> up_closed y \<longrightarrow> up_closed (x ; y)"
  by (metis dual_order.antisym mult_semi_associative mult_sub_right_one up_closed_def)

-- {* add-distributive *}

lemma zero_add_distributive: "add_distributive 0"
  by (metis add_distributive_def add_idempotent mult_left_zero)

lemma one_add_distributive: "add_distributive 1"
  by (metis add_distributive_def mult_left_one)

lemma add_add_distributive: "add_distributive x \<and> add_distributive y \<longrightarrow> add_distributive (x + y)"
  by (smt2 add_distributive_def add_associative add_commutative mult_right_dist_add)

-- {* meet-distributive *}

lemma zero_meet_distributive: "meet_distributive 0"
  by (metis meet_left_zero mult_left_zero meet_distributive_def)

lemma one_meet_distributive: "meet_distributive 1"
  by (metis mult_left_one meet_distributive_def)

-- {* contact *}

lemma one_contact: "contact 1"
  by (metis contact_def add_idempotent mult_left_one)

lemma top_contact: "contact T"
  by (metis contact_def add_left_top top_mult_top)

lemma meet_contact: "contact x \<and> contact y \<longrightarrow> contact (x \<frown> y)"
  by (smt2 contact_def contact_reflexive contact_transitive contact_up_closed meet.less_eq_def meet_commutative meet_left_dist_add mult_left_sub_dist_add_right meet_transitive meet_up_closed reflexive_def transitive_def up_closed_def)

-- {* kernel *}

lemma zero_kernel: "kernel 0"
  by (metis kernel_co_reflexive_idempotent_up_closed zero_co_reflexive zero_idempotent zero_up_closed)

lemma one_kernel: "kernel 1"
  by (metis kernel_def meet_idempotent mult_left_one)

lemma add_kernel: "kernel x \<and> kernel y \<longrightarrow> kernel (x + y)"
  by (metis add_co_reflexive add_dense add_up_closed co_reflexive_transitive kernel_co_reflexive_idempotent_up_closed idempotent_transitive_dense)

-- {* add-distributive contact *}

lemma one_add_dist_contact: "add_dist_contact 1"
  by (metis add_dist_contact_def one_add_distributive one_contact)

-- {* meet-distributive kernel *}

lemma zero_meet_dist_kernel: "meet_dist_kernel 0"
  by (metis meet_dist_kernel_def zero_kernel zero_meet_distributive)

lemma one_meet_dist_kernel: "meet_dist_kernel 1"
  by (metis meet_dist_kernel_def one_kernel one_meet_distributive)

-- {* test *}

lemma zero_test: "test 0"
  by (metis meet_commutative meet_right_zero mult_left_zero test_def)

lemma one_test: "test 1"
  by (metis meet_left_top mult_left_one test_def)

lemma add_test: "test x \<and> test y \<longrightarrow> test (x + y)"
  by (metis (no_types, lifting) meet_commutative meet_left_dist_add mult_right_dist_add test_def)

lemma meet_test: "test x \<and> test y \<longrightarrow> test (x \<frown> y)"
  by (smt2 test_def meet_commutative meet.add_least_upper_bound meet.add_right_isotone mult_right_sub_dist_meet_left meet.add_left_upper_bound top_right_mult_increasing antisym)

-- {* co-test *}

lemma one_co_test: "co_test 1"
  by (metis co_test_def co_total_def add_left_zero one_co_total)

lemma add_co_test: "co_test x \<and> co_test y \<longrightarrow> co_test (x + y)"
  by (smt2 co_test_contact co_test_def contact_def add_associative add_commutative add_left_zero mult_left_one mult_right_dist_add)

-- {* vector *}

lemma zero_vector: "vector 0"
  by (metis mult_left_zero vector_def)

lemma top_vector: "vector T"
  by (metis top_mult_top vector_def)

lemma add_vector: "vector x \<and> vector y \<longrightarrow> vector (x + y)"
  by (metis mult_right_dist_add vector_def)

lemma meet_vector: "vector x \<and> vector y \<longrightarrow> vector (x \<frown> y)"
  by (metis antisym meet.add_least_upper_bound mult_right_sub_dist_meet_left mult_right_sub_dist_meet_right top_right_mult_increasing vector_def)

lemma comp_vector: "vector y \<longrightarrow> vector (x ; y)"
  by (metis antisym_conv mult_semi_associative top_right_mult_increasing vector_def)

end

class lattice_ordered_pre_left_semiring_1 = non_associative_left_semiring + bounded_distributive_lattice +
  assumes mult_associative_one: "x ; (y ; z) = (x ; (y ; 1)) ; z"
  assumes mult_right_dist_meet_one: "(x ; 1 \<frown> y ; 1) ; z = x ; z \<frown> y ; z"

begin

subclass pre_left_semiring
  apply unfold_locales
  apply (metis mult_associative_one mult_left_isotone mult_right_isotone mult_sub_right_one)
  done

subclass lattice_ordered_pre_left_semiring
  ..

lemma mult_zero_associative: "x ; 0 ; y = x ; 0"
  by (smt mult_left_zero mult_associative_one)

lemma mult_zero_add_one_dist: "(x ; 0 + 1) ; z = x ; 0 + z"
  by (metis mult_left_one mult_right_dist_add mult_zero_associative)

lemma mult_zero_add_dist: "(x ; 0 + y) ; z = x ; 0 + y ; z"
  by (metis mult_right_dist_add mult_zero_associative)

lemma vector_zero_meet_one_comp: "(x ; 0 \<frown> 1) ; y = x ; 0 \<frown> y"
  by (metis mult_left_one mult_right_dist_meet_one mult_zero_associative)

-- {* CPCP Theorem 5 / Figure 2: relations between properties *}

lemma co_test_meet_distributive: "co_test x \<longrightarrow> meet_distributive x"
  by (metis add_left_dist_meet co_test_def meet_distributive_def mult_zero_add_one_dist)

lemma co_test_add_distributive: "co_test x \<longrightarrow> add_distributive x"
  by (smt2 add_associative add_commutative add_distributive_def add_left_upper_bound co_test_def less_eq_def mult_zero_add_one_dist)

lemma co_test_add_dist_contact: "co_test x \<longrightarrow> add_dist_contact x"
  by (metis co_test_add_distributive add_dist_contact_def co_test_contact)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

-- {* co-test *}

lemma meet_co_test: "co_test x \<and> co_test y \<longrightarrow> co_test (x \<frown> y)"
  by (smt2 add_commutative add_left_dist_meet co_test_def co_test_up_closed up_closed_def mult_right_dist_meet_one)

lemma comp_co_test: "co_test x \<and> co_test y \<longrightarrow> co_test (x ; y)"
  by (metis add_associative co_test_def mult_zero_add_dist mult_zero_add_one_dist)

end

class lattice_ordered_pre_left_semiring_2 = lattice_ordered_pre_left_semiring +
  assumes mult_sub_associative_one: "x ; (y ; z) \<le> (x ; (y ; 1)) ; z"
  assumes mult_right_dist_meet_one_sub: "x ; z \<frown> y ; z \<le> (x ; 1 \<frown> y ; 1) ; z"

begin

subclass lattice_ordered_pre_left_semiring_1
  apply unfold_locales
  apply (metis meet.eq_iff mult_sub_associative_one mult_sup_associative_one)
  apply (metis meet.antisym_conv mult_one_associative mult_right_dist_meet_one_sub mult_right_sub_dist_meet)
  done

end

class multirelation_algebra_1 = lattice_ordered_pre_left_semiring +
  assumes mult_left_top: "T ; x = T"

begin

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

lemma top_add_distributive: "add_distributive T"
  by (metis add_distributive_def add_left_top mult_left_top)

lemma top_meet_distributive: "meet_distributive T"
  by (metis meet_idempotent meet_distributive_def mult_left_top)

lemma top_add_dist_contact: "add_dist_contact T"
  by (metis add_dist_contact_def top_add_distributive top_contact)

lemma top_co_test: "co_test T"
  by (metis co_test_def add_left_top mult_left_top)

end

-- {* M1-algebra *}

class multirelation_algebra_2 = multirelation_algebra_1 + lattice_ordered_pre_left_semiring_2

begin

lemma mult_top_associative: "x ; T ; y = x ; T"
  by (metis mult_left_top mult_associative_one)

lemma vector_meet_one_comp: "(x ; T \<frown> 1) ; y = x ; T \<frown> y"
  by (metis mult_left_one mult_left_top mult_associative_one mult_right_dist_meet_one)

lemma vector_left_annihilator: "vector x \<longrightarrow> x ; y = x"
  by (metis mult_left_top vector_def mult_associative_one)

-- {* properties *}

lemma test_comp_meet: "test x \<and> test y \<longrightarrow> x ; y = x \<frown> y"
  by (smt2 meet_associative meet_commutative meet_idempotent test_def vector_meet_one_comp)

-- {* CPCP Theorem 5 / Figure 2: relations between properties *}

lemma test_add_distributive: "test x \<longrightarrow> add_distributive x"
  by (metis add_distributive_def meet_left_dist_add test_def vector_meet_one_comp)

lemma test_meet_distributive: "test x \<longrightarrow> meet_distributive x"
  by (smt2 meet.less_eq_def meet_associative meet_commutative meet_distributive_def meet.add_right_upper_bound mult_left_one test_def vector_meet_one_comp)

lemma test_meet_dist_kernel: "test x \<longrightarrow> meet_dist_kernel x"
  by (metis kernel_co_reflexive_idempotent_up_closed meet_associative meet_dist_kernel_def meet_idempotent test_co_reflexive test_def test_up_closed idempotent_def vector_meet_one_comp test_meet_distributive)

lemma vector_idempotent: "vector x \<longrightarrow> idempotent x"
  by (metis idempotent_def vector_left_annihilator)

lemma vector_add_distributive: "vector x \<longrightarrow> add_distributive x"
  by (metis add_distributive_def add_idempotent vector_left_annihilator)

lemma vector_meet_distributive: "vector x \<longrightarrow> meet_distributive x"
  by (metis meet_distributive_def meet_idempotent vector_left_annihilator)

lemma vector_co_vector: "vector x \<longleftrightarrow> co_vector x"
  by (metis co_vector_def vector_def mult_zero_associative vector_left_annihilator)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

-- {* test *}

lemma comp_test: "test x \<and> test y \<longrightarrow> test (x ; y)"
  by (metis meet_associative meet_distributive_def meet.add_right_zero test_def test_up_closed up_closed_def mult_associative_one test_meet_distributive)

end

class dual =
  fixes dual :: "'a \<Rightarrow> 'a" ("_\<^sup>d" [100] 100)

class multirelation_algebra_3 = lattice_ordered_pre_left_semiring + dual +
  assumes dual_involutive: "x\<^sup>d\<^sup>d = x"
  assumes dual_dist_add: "(x + y)\<^sup>d = x\<^sup>d \<frown> y\<^sup>d"
  assumes dual_one: "1\<^sup>d = 1"

begin

lemma dual_dist_meet: "(x \<frown> y)\<^sup>d = x\<^sup>d + y\<^sup>d"
  by (metis dual_dist_add dual_involutive)

lemma dual_antitone: "x \<le> y \<longrightarrow> y\<^sup>d \<le> x\<^sup>d"
  by (metis dual_dist_meet add_left_divisibility meet.add_left_divisibility)

lemma dual_zero: "0\<^sup>d = T"
  by (metis dual_dist_meet add_right_top dual_involutive meet_left_zero)

lemma dual_top: "T\<^sup>d = 0"
  by (metis dual_zero dual_involutive)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

lemma reflexive_co_reflexive_dual: "reflexive x \<longleftrightarrow> co_reflexive (x\<^sup>d)"
  by (metis co_reflexive_def dual_antitone dual_involutive dual_one reflexive_def)

end

class multirelation_algebra_4 = multirelation_algebra_3 +
  assumes dual_sub_dist_comp: "(x ; y)\<^sup>d \<le> x\<^sup>d ; y\<^sup>d"

begin

subclass multirelation_algebra_1
  apply unfold_locales
  apply (metis dual_zero dual_sub_dist_comp dual_involutive meet.less_eq_def meet_commutative meet_left_top mult_left_zero)
  done

lemma dual_sub_dist_comp_one: "(x ; y)\<^sup>d \<le> (x ; 1)\<^sup>d ; y\<^sup>d"
  by (metis dual_sub_dist_comp mult_one_associative)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

lemma co_total_total_dual: "co_total x \<longrightarrow> total (x\<^sup>d)"
  by (metis co_total_def dual_sub_dist_comp dual_zero meet.less_eq_def meet_commutative meet_left_top total_def)

lemma transitive_dense_dual: "transitive x \<longrightarrow> dense (x\<^sup>d)"
  by (metis dual_antitone dual_sub_dist_comp order_trans transitive_def dense_def)

end

-- {* M2-algebra *}

class multirelation_algebra_5 = multirelation_algebra_3 +
  assumes dual_dist_comp_one: "(x ; y)\<^sup>d = (x ; 1)\<^sup>d ; y\<^sup>d"

begin

subclass multirelation_algebra_4
  apply unfold_locales
  apply (metis dual_antitone mult_sub_right_one mult_left_isotone dual_dist_comp_one)
  done

lemma strong_up_closed: "x ; 1 \<le> x \<longrightarrow> x\<^sup>d ; y\<^sup>d \<le> (x ; y)\<^sup>d"
  by (metis dual_dist_comp_one eq_iff mult_sub_right_one)

lemma strong_up_closed_2: "up_closed x \<longrightarrow> (x ; y)\<^sup>d = x\<^sup>d ; y\<^sup>d"
  by (metis dual_sub_dist_comp eq_iff strong_up_closed up_closed_def)

subclass lattice_ordered_pre_left_semiring_2
  apply unfold_locales
  apply (smt2 comp_up_closed dual_antitone dual_dist_comp_one dual_involutive dual_one mult_left_one mult_one_associative mult_semi_associative up_closed_def strong_up_closed_2)
  apply (smt2 dual_dist_comp_one dual_dist_meet dual_involutive eq_refl mult_one_associative mult_right_dist_add)
  done

-- {* CPCP Theorem 6 *}

subclass multirelation_algebra_2
  ..

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

-- {* up-closed *}

lemma up_closed_dual: "up_closed x \<longleftrightarrow> up_closed (x\<^sup>d)"
  by (metis dual_involutive dual_one up_closed_def strong_up_closed_2)

-- {* contact *}

lemma contact_kernel_dual: "contact x \<longleftrightarrow> kernel (x\<^sup>d)"
  by (metis contact_def contact_up_closed dual_dist_add dual_involutive dual_one kernel_def kernel_up_closed up_closed_def strong_up_closed_2)

-- {* add-distributive contact *}

lemma add_dist_contact_meet_dist_kernel_dual: "add_dist_contact x \<longleftrightarrow> meet_dist_kernel (x\<^sup>d)"
proof
  assume 1: "add_dist_contact x"
  hence 2: "up_closed x"
    by (metis add_dist_contact_def contact_up_closed)
  have "add_distributive x" using 1
    by (metis add_dist_contact_def)
  hence "meet_distributive (x\<^sup>d)" using 2
    by (smt2 meet_distributive_def add_distributive_def dual_dist_add dual_involutive strong_up_closed_2)
  thus "meet_dist_kernel (x\<^sup>d)" using 1
    by (metis contact_kernel_dual add_dist_contact_def meet_dist_kernel_def)
next
  assume 3: "meet_dist_kernel (x\<^sup>d)"
  hence 2: "up_closed (x\<^sup>d)"
    by (metis kernel_up_closed meet_dist_kernel_def)
  have "meet_distributive (x\<^sup>d)" using 3
    by (metis meet_dist_kernel_def)
  hence "add_distributive (x\<^sup>d\<^sup>d)" using 2
    by (smt2 meet_distributive_def add_distributive_def dual_dist_add dual_involutive strong_up_closed_2)
  thus "add_dist_contact x" using 3
    by (metis contact_kernel_dual add_dist_contact_def meet_dist_kernel_def dual_involutive)
qed

-- {* test *}

lemma test_co_test_dual: "test x \<longleftrightarrow> co_test (x\<^sup>d)"
  by (smt2 co_test_def co_test_up_closed dual_dist_meet dual_involutive dual_one dual_top test_def test_up_closed strong_up_closed_2)

-- {* vector *}

lemma vector_dual: "vector x \<longleftrightarrow> vector (x\<^sup>d)"
  by (metis dual_dist_comp_one comp_vector dual_involutive dual_top vector_def zero_vector)

end

class multirelation_algebra_6 = multirelation_algebra_4 +
  assumes dual_sub_dist_comp_one: "(x ; 1)\<^sup>d ; y\<^sup>d \<le> (x ; y)\<^sup>d"

begin

subclass multirelation_algebra_5
  apply unfold_locales
  apply (metis dual_sub_dist_comp dual_sub_dist_comp_one meet.eq_iff mult_one_associative)
  done

lemma "dense x \<and> co_reflexive x \<longrightarrow> up_closed x" nitpick [expect=genuine] oops
lemma "x ; T \<frown> y ; z \<le> (x ; T \<frown> y) ; z" nitpick [expect=genuine,card=8] oops

end

-- {* M3-algebra *}

class up_closed_multirelation_algebra = multirelation_algebra_3 +
  assumes dual_dist_comp: "(x ; y)\<^sup>d = x\<^sup>d ; y\<^sup>d"

begin

lemma mult_right_dist_meet: "(x \<frown> y) ; z = x ; z \<frown> y ; z"
  by (metis dual_dist_add dual_dist_comp dual_involutive mult_right_dist_add)

-- {* CPCP Theorem 7 *}

subclass idempotent_left_semiring
  apply unfold_locales
  apply (metis antisym dual_antitone dual_dist_comp dual_involutive mult_semi_associative)
  apply (metis mult_left_one)
  apply (metis dual_dist_add dual_dist_comp dual_involutive dual_one less_eq_def meet_absorb mult_sub_right_one)
  done

subclass multirelation_algebra_6
  apply unfold_locales
  apply (metis dual_dist_comp eq_iff)
  apply (metis dual_dist_comp eq_iff mult_right_one)
  done

lemma vector_meet_comp: "(x ; T \<frown> y) ; z = x ; T \<frown> y ; z"
  by (metis mult_associative mult_left_top mult_right_dist_meet)

lemma vector_zero_meet_comp: "(x ; 0 \<frown> y) ; z = x ; 0 \<frown> y ; z"
  by (metis mult_associative mult_left_zero mult_right_dist_meet)

-- {* CPCP Theorem 8 / Figure 3: closure properties *}

-- {* total *}

lemma meet_total: "total x \<and> total y \<longrightarrow> total (x \<frown> y)"
  by (metis meet_left_top total_def mult_right_dist_meet)

lemma comp_total: "total x \<and> total y \<longrightarrow> total (x ; y)"
  by (metis mult_associative total_def)

lemma total_co_total_dual: "total x \<longleftrightarrow> co_total (x\<^sup>d)"
  by (metis co_total_def dual_dist_comp dual_involutive dual_top total_def)

-- {* dense *}

lemma transitive_iff_dense_dual: "transitive x \<longleftrightarrow> dense (x\<^sup>d)"
  by (metis dense_def dual_antitone dual_dist_comp dual_involutive transitive_def)

-- {* idempotent *}

lemma idempotent_dual: "idempotent x \<longleftrightarrow> idempotent (x\<^sup>d)"
  by (metis dual_involutive idempotent_transitive_dense transitive_iff_dense_dual)

-- {* add-distributive *}

lemma comp_add_distributive: "add_distributive x \<and> add_distributive y \<longrightarrow> add_distributive (x ; y)"
  by (metis add_distributive_def mult_associative)

lemma add_meet_distributive_dual: "add_distributive x \<longleftrightarrow> meet_distributive (x\<^sup>d)"
  by (metis (no_types, hide_lams) add_distributive_def dual_dist_add dual_dist_comp dual_involutive meet_distributive_def)

-- {* meet-distributive *}

lemma meet_meet_distributive: "meet_distributive x \<and> meet_distributive y \<longrightarrow> meet_distributive (x \<frown> y)"
  by (smt2 meet_distributive_def meet_associative meet_commutative mult_right_dist_meet)

lemma comp_meet_distributive: "meet_distributive x \<and> meet_distributive y \<longrightarrow> meet_distributive (x ; y)"
  by (metis meet_distributive_def mult_associative)

lemma "co_total x \<and> transitive x \<and> up_closed x \<longrightarrow> co_reflexive x" nitpick [expect=genuine] oops
lemma "total x \<and> dense x \<and> up_closed x \<longrightarrow> reflexive x" nitpick [expect=genuine] oops
lemma "x ; T \<frown> x\<^sup>d ; 0 = 0" nitpick [expect=genuine] oops

end

class multirelation_algebra_7 = multirelation_algebra_4 +
  assumes vector_meet_comp: "(x ; T \<frown> y) ; z = x ; T \<frown> y ; z"

begin

lemma vector_zero_meet_comp: "(x ; 0 \<frown> y) ; z = x ; 0 \<frown> y ; z"
  by (metis vector_def comp_vector vector_meet_comp zero_vector)

lemma test_add_distributive: "test x \<longrightarrow> add_distributive x"
  by (metis add_distributive_def meet_left_dist_add mult_left_one test_def vector_meet_comp)

lemma test_meet_distributive: "test x \<longrightarrow> meet_distributive x"
  by (smt2 meet.less_eq_def meet_associative meet_commutative meet_distributive_def meet.add_right_upper_bound mult_left_one test_def vector_meet_comp)

lemma test_meet_dist_kernel: "test x \<longrightarrow> meet_dist_kernel x"
  by (metis kernel_co_reflexive_idempotent_up_closed meet_associative meet_dist_kernel_def meet_idempotent mult_left_one test_co_reflexive test_def test_up_closed idempotent_def vector_meet_comp test_meet_distributive)

lemma co_test_meet_distributive: "co_test x \<longrightarrow> meet_distributive x"
proof
  assume "co_test x"
  hence "x = x ; 0 + 1"
    by (metis co_test_def)
  hence "\<forall>y z . x ; y \<frown> x ; z = x ; (y \<frown> z)"
    by (metis mult_left_one mult_left_top mult_right_dist_add meet.add_right_zero vector_zero_meet_comp add_left_dist_meet)
  thus "meet_distributive x"
    by (metis meet_distributive_def)
qed

lemma co_test_add_distributive: "co_test x \<longrightarrow> add_distributive x"
proof
  assume "co_test x"
  hence 1: "x = x ; 0 + 1"
    by (metis co_test_def)
  hence "\<forall>y z . x ; (y + z) = x ; y + x ; z"
    by (metis add_associative add_commutative add_idempotent mult_left_one mult_left_top mult_right_dist_add meet.add_right_zero vector_zero_meet_comp)
  thus "add_distributive x"
    by (metis add_distributive_def)
qed

lemma co_test_add_dist_contact: "co_test x \<longrightarrow> add_dist_contact x"
  by (metis co_test_add_distributive add_dist_contact_def co_test_contact)

end

(*
end


theory NAlgebra

imports LatticeOrderedSemiring

begin
*)

class C_left_n_algebra = bounded_idempotent_left_semiring + bounded_distributive_lattice + n + L

begin

abbreviation C :: "'a \<Rightarrow> 'a" where "C x \<equiv> n(L) ; T \<frown> x"

-- {* AACP Theorem 3.38 *}

lemma C_isotone: "x \<le> y \<longrightarrow> C x \<le> C y"
  by (metis meet.add_right_isotone)

-- {* AACP Theorem 3.40 *}

lemma C_decreasing: "C x \<le> x"
  by (metis meet.add_right_upper_bound)

end

class left_n_algebra = C_left_n_algebra +
  assumes n_dist_n_add            : "n(x) + n(y) = n(n(x) ; T + y)"
  assumes n_export                : "n(x) ; n(y) = n(n(x) ; y)"
  assumes n_left_upper_bound      : "n(x) \<le> n(x + y)"
  assumes n_nL_meet_L_nL0         : "n(L) ; x = (x \<frown> L) + n(L ; 0) ; x"
  assumes n_n_L_split_n_n_L_L     : "x ; n(y) ; L = x ; 0 + n(x ; n(y) ; L) ; L"
  assumes n_sub_nL                : "n(x) \<le> n(L)"
  assumes n_L_decreasing          : "n(x) ; L \<le> x"
  assumes n_L_T_meet_mult_combined: "C (x ; y) ; z \<le> C x ; y ; C z"
  assumes n_n_top_split_n_top     : "x ; n(y) ; T \<le> x ; 0 + n(x ; y) ; T"
  assumes n_top_meet_L_below_L    : "x ; T ; y \<frown> L \<le> x ; L ; y"

begin

subclass lattice_ordered_pre_left_semiring ..

lemma n_L_T_meet_mult_below: "C (x ; y) \<le> C x ; y"
proof -
  have "C (x ; y) \<le> C x ; y ; C 1"
    by (metis mult_right_one mult_associative n_L_T_meet_mult_combined)
  also have "... \<le> C x ; y"
    by (metis mult_right_one C_decreasing mult_right_isotone mult_associative)
  finally show ?thesis
    .
qed

-- {* AACP Theorem 3.41 *}

lemma n_L_T_meet_mult_propagate: "C x ; y \<le> x ; C y"
proof -
  have "C x ; y \<le> C x ; 1 ; C y"
    by (metis mult_right_one mult_associative n_L_T_meet_mult_combined mult_right_one)
  also have "... \<le> x ; C y"
    by (metis mult_right_one mult_associative mult_right_one C_decreasing mult_left_isotone)
  finally show ?thesis
    .
qed

-- {* AACP Theorem 3.43 *}

lemma C_n_mult_closed: "C (n(x) ; y) = n(x) ; y"
  by (metis meet.less_eq_def mult_isotone n_sub_nL top_greatest)

-- {* AACP Theorem 3.40 *}

lemma meet_L_below_C: "x \<frown> L \<le> C x"
  by (metis add_left_upper_bound meet.add_left_isotone meet_commutative meet_left_top n_nL_meet_L_nL0)

-- {* AACP Theorem 3.42 *}

lemma n_L_T_meet_mult: "C (x ; y) = C x ; y"
  apply (rule antisym)
  apply (rule n_L_T_meet_mult_below)
  apply (metis meet.add_least_upper_bound meet.add_left_upper_bound mult_associative mult_isotone mult_right_sub_dist_meet_right top_greatest top_mult_top)
  done

-- {* AACP Theorem 3.42 *}

lemma C_mult_propagate: "C x ; y = C x ; C y"
  by (smt2 C_n_mult_closed meet.less_eq_def meet_associative meet_less_eq_def mult_left_sub_dist_meet_right n_L_T_meet_mult_propagate)

-- {* AACP Theorem 3.32 *}

lemma meet_L_below_n_L: "x \<frown> L \<le> n(L) ; x"
  by (metis add_left_divisibility n_nL_meet_L_nL0)

-- {* AACP Theorem 3.27 *}

lemma n_vector_meet_L: "x ; T \<frown> L \<le> x ; L"
  by (metis mult_right_one n_top_meet_L_below_L)

lemma n_right_upper_bound: "n(x) \<le> n(y + x)"
  by (metis add_commutative n_left_upper_bound)

-- {* AACP Theorem 3.1 *}

lemma n_isotone: "x \<le> y \<longrightarrow> n(x) \<le> n(y)"
  by (metis less_eq_def n_left_upper_bound)

lemma n_add_left_zero: "n(0) + n(x) = n(x)"
  by (metis less_eq_def n_isotone zero_least)

-- {* AACP Theorem 3.13 *}

lemma n_mult_right_zero_L: "n(x) ; 0 \<le> L"
  by (metis dual_order.trans mult_isotone n_L_decreasing n_sub_nL zero_least)

lemma n_add_left_top: "n(T) + n(x) = n(T)"
  by (metis add_commutative add_right_top_1 n_dist_n_add)

-- {* AACP Theorem 3.18 *}

lemma n_n_L: "n(n(x) ; L) = n(x)"
  by (metis add_commutative add_right_zero less_eq_def n_dist_n_add n_export n_sub_nL n_add_left_top n_add_left_zero)

lemma n_mult_transitive : "n(x) ; n(x) \<le> n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

lemma n_mult_left_absorb_add_sub: "n(x) ; (n(x) + n(y)) \<le> n(x)"
  by (metis add_associative less_eq_def mult_left_sub_dist_add_left n_export n_sub_nL n_n_L)

-- {* AACP Theorem 3.21 *}

lemma n_mult_left_lower_bound: "n(x) ; n(y) \<le> n(x)"
  by (metis mult_right_isotone n_export n_sub_nL n_n_L)

-- {* AACP Theorem 3.20 *}

lemma n_mult_left_zero: "n(0) ; n(x) = n(0)"
  by (metis add_commutative less_eq_def n_export n_add_left_zero n_mult_left_lower_bound)

lemma n_mult_right_one: "n(x) ; n(T) = n(x)"
  by (metis add_left_upper_bound add_right_zero meet.eq_iff n_dist_n_add n_export n_mult_left_lower_bound)

lemma n_L_increasing: "n(x) \<le> n(n(x) ; L)"
  by (metis order_refl n_n_L)

-- {* AACP Theorem 3.2 *}

lemma n_galois: "n(x) \<le> n(y) \<longleftrightarrow> n(x) ; L \<le> y"
  by (metis mult_left_isotone n_L_decreasing n_L_increasing n_isotone order_trans)

lemma n_add_n_top: "n(x + n(x) ; T) = n(x)"
  by (metis add_commutative add_idempotent n_dist_n_add)

-- {* AACP Theorem 3.6 *}

lemma n_L_below_nL_top: "L \<le> n(L) ; T"
  by (metis meet.add_right_zero meet_L_below_C meet_left_top)

-- {* AACP Theorem 3.4 *}

lemma n_less_eq_char_n: "x \<le> y \<longleftrightarrow> x \<le> y + L \<and> C x \<le> y + n(y) ; T"
proof
  assume "x \<le> y"
  thus "x \<le> y + L \<and> C x \<le> y + n(y) ; T"
    by (metis add_left_upper_bound dual_order.trans meet.add_right_upper_bound)
next
  assume 1: "x \<le> y + L \<and> C x \<le> y + n(y) ; T"
  hence "x \<le> y + (x \<frown> L)"
    by (metis meet_less_eq_def add_left_dist_meet add_right_upper_bound meet.add_left_isotone)
  also have "... \<le> y + C x"
    by (metis add_right_isotone less_eq_def meet_left_dist_add n_L_below_nL_top meet_commutative)
  also have "... \<le> y + n(y) ; T" using 1
    by (metis add_least_upper_bound add_left_upper_bound)
  finally have "x \<le> y + (L \<frown> n(y) ; T)" using 1
    by (metis meet.add_least_upper_bound add_left_dist_meet)
  thus "x \<le> y"
    by (metis add_idempotent add_least_upper_bound n_vector_meet_L less_eq_def meet_commutative n_L_decreasing)
qed

-- {* AACP Theorem 3.31 *}

lemma n_L_decreasing_meet_L: "n(x) ; L \<le> x \<frown> L"
  by (metis meet.add_least_upper_bound n_L_decreasing n_sub_nL n_galois)

-- {* AACP Theorem 3.5 *}

lemma n_zero_L_zero: "n(0) ; L = 0"
  by (metis antisym n_L_decreasing zero_least)

lemma n_L_top_below_L: "L ; T \<le> L"
proof -
  have "n(L ; 0) ; L ; T \<le> L ; 0"
    by (metis mult_associative mult_left_isotone n_L_decreasing vector_def zero_vector)
  hence "n(L ; 0) ; L ; T \<le> L"
    by (metis order_trans zero_right_mult_decreasing)
  hence "n(L) ; L ; T \<le> L"
    by (metis add_least_upper_bound meet.add_right_upper_bound mult_associative n_nL_meet_L_nL0)
  thus "L ; T \<le> L"
    by (metis add_least_upper_bound eq_iff meet_idempotent n_nL_meet_L_nL0 top_right_mult_increasing)
qed

-- {* AACP Theorem 3.9 *}

lemma n_L_top_L: "L ; T = L"
  by (metis antisym n_L_top_below_L top_right_mult_increasing)

-- {* AACP Theorem 3.10 *}

lemma n_L_below_L: "L ; x \<le> L"
  by (metis add_right_top n_L_top_below_L mult_left_sub_dist_add_left order_trans)

-- {* AACP Theorem 3.7 *}

lemma n_nL_nT: "n(L) = n(T)"
  by (metis antisym n_isotone n_sub_nL top_greatest)

-- {* AACP Theorem 3.8 *}

lemma n_L_L: "n(L) ; L = L"
  by (metis meet.less_eq_def meet_absorb meet_idempotent n_L_decreasing n_nL_meet_L_nL0)

lemma n_top_L: "n(T) ; L = L"
  by (metis n_L_L n_nL_nT)

-- {* AACP Theorem 3.23 *}

lemma n_n_L_split_n_L: "x ; n(y) ; L \<le> x ; 0 + n(x ; y) ; L"
  by (metis n_n_L_split_n_n_L_L n_L_decreasing mult_associative mult_left_isotone mult_right_isotone n_isotone add_right_isotone)

-- {* AACP Theorem 3.12 *}

lemma n_L_split_n_L_L: "x ; L = x ; 0 + n(x ; L) ; L"
  apply (rule antisym)
  apply (metis mult_associative n_n_L_split_n_L n_L_L)
  apply (metis add_least_upper_bound mult_right_isotone n_L_decreasing zero_least)
  done

-- {* AACP Theorem 3.11 *}

lemma n_L_split_L: "x ; L \<le> x ; 0 + L"
  by (metis add_commutative add_left_isotone meet.add_least_upper_bound n_L_decreasing_meet_L n_L_split_n_L_L)

-- {* AACP Theorem 3.24 *}

lemma n_split_top: "x ; n(y) ; T \<le> x ; y + n(x ; y) ; T"
proof -
  have "x ; 0 + n(x ; y) ; T \<le> x ; y + n(x ; y) ; T"
    by (metis add_left_isotone mult_right_isotone zero_least)
  thus ?thesis
    by (smt n_n_top_split_n_top order_trans)
qed

-- {* AACP Theorem 3.9 *}

lemma n_L_L_L: "L ; L = L"
  by (metis antisym n_vector_meet_L n_L_below_L meet_idempotent n_L_top_L)

-- {* AACP Theorem 3.9 *}

lemma n_L_top_L_L: "L ; T ; L = L"
  by (metis n_L_L_L n_L_top_L)

-- {* AACP Theorem 3.19 *}

lemma n_n_nL: "n(x) = n(x) ; n(L)"
  by (metis n_export n_n_L)

lemma n_L_mult_idempotent: "n(L) ; n(L) = n(L)"
  by (metis n_n_nL)

-- {* AACP Theorem 3.22 *}

lemma n_n_L_n: "n(x ; n(y) ; L) \<le> n(x ; y)"
  by (metis mult_associative mult_right_isotone n_L_decreasing n_isotone)

-- {* AACP Theorem 3.3 *}

lemma n_less_eq_char: "x \<le> y \<longleftrightarrow> x \<le> y + L \<and> x \<le> y + n(y) ; T"
  by (smt add_absorb add_associative add_idempotent n_less_eq_char_n meet_less_eq_def meet_left_dist_add n_add_n_top)

-- {* AACP Theorem 3.28 *}

lemma n_top_meet_L_split_L: "x ; T ; y \<frown> L \<le> x ; 0 + L ; y"
proof -
  have "x ; T ; y \<frown> L \<le> x ; 0 + n(x ; L) ; L ; y"
    by (smt n_top_meet_L_below_L mult_associative n_L_L_L n_L_split_n_L_L mult_right_dist_add mult_left_zero)
  also have "... \<le> x ; 0 + x ; L ; y"
    by (metis add_right_isotone mult_right_sub_dist_add_right n_L_split_n_L_L)
  also have "... \<le> x ; 0 + (x ; 0 + L) ; y"
    by (metis add_right_isotone mult_left_isotone n_L_split_L)
  also have "... = x ; 0 + x ; 0 ; y + L ; y"
    by (metis add_associative mult_right_dist_add)
  also have "... = x ; 0 + L ; y"
    by (metis add_idempotent mult_associative mult_left_zero)
  finally show ?thesis
    .
qed

-- {* AACP Theorem 3.29 *}

lemma n_top_meet_L_L_meet_L: "x ; T ; y \<frown> L = x ; L ; y \<frown> L"
  apply (rule antisym)
  apply (metis meet.add_least_upper_bound meet.add_right_upper_bound n_top_meet_L_below_L)
  apply (metis meet.add_left_isotone mult_left_isotone mult_right_isotone top_greatest)
  done

lemma n_n_top_below_n_L: "n(x ; T) \<le> n(x ; L)"
  by (metis n_vector_meet_L n_L_decreasing_meet_L n_galois order_trans)

-- {* AACP Theorem 3.14 *}

lemma n_n_top_n_L: "n(x ; T) = n(x ; L)"
  by (metis antisym mult_right_isotone n_isotone n_n_top_below_n_L top_greatest)

-- {* AACP Theorem 3.30 *}

lemma n_meet_L_0_below_0_meet_L: "(x \<frown> L) ; 0 \<le> x ; 0 \<frown> L"
  by (metis meet.add_least_upper_bound mult_isotone order.refl zero_right_mult_decreasing)

-- {* AACP Theorem 3.15 *}

lemma n_n_L_below_L: "n(x) ; L \<le> x ; L"
  by (metis mult_associative mult_left_isotone n_L_L_L n_L_decreasing)

lemma n_n_L_below_n_L_L: "n(x) ; L \<le> n(x ; L) ; L"
  by (metis n_n_L_below_L mult_left_isotone n_galois)

-- {* AACP Theorem 3.16 *}

lemma n_below_n_L: "n(x) \<le> n(x ; L)"
  by (metis n_n_L_below_L n_galois)

-- {* AACP Theorem 3.17 *}

lemma n_below_n_L_mult: "n(x) \<le> n(L) ; n(x)"
  by (metis n_export order_trans meet_L_below_n_L n_L_decreasing_meet_L n_isotone n_n_L)

-- {* AACP Theorem 3.33 *}

lemma n_meet_L_below: "n(x) \<frown> L \<le> x"
  by (metis meet.add_left_isotone n_L_decreasing n_vector_meet_L order_trans top_right_mult_increasing)

-- {* AACP Theorem 3.35 *}

lemma n_meet_L_top_below_n_L: "(n(x) \<frown> L) ; T \<le> n(x) ; L"
proof -
  have "(n(x) \<frown> L) ; T \<le> n(x) ; T \<frown> L ; T"
    by (metis meet.add_least_upper_bound meet.add_left_upper_bound meet_commutative mult_left_isotone)
  thus ?thesis
    by (metis n_L_top_L n_vector_meet_L order_trans)
qed

-- {* AACP Theorem 3.34 *}

lemma n_meet_L_top_below: "(n(x) \<frown> L) ; T \<le> x"
  by (metis n_L_decreasing n_meet_L_top_below_n_L order_trans)

-- {* AACP Theorem 3.36 *}

lemma n_n_meet_L: "n(x) = n(x \<frown> L)"
  by (metis add_absorb add_commutative less_eq_def n_L_decreasing_meet_L n_n_L n_right_upper_bound)

lemma n_T_below_n_meet: "n(x) ; T = n(C x) ; T"
  by (metis C_n_mult_closed meet_associative meet_commutative n_L_L n_n_meet_L)

-- {* AACP Theorem 3.44 *}

lemma n_C: "n(C x) = n(x)"
  by (metis n_T_below_n_meet n_export n_mult_right_one)

-- {* AACP Theorem 3.37 *}

lemma n_T_meet_L: "n(x) ; T \<frown> L = n(x) ; L"
  by (metis antisym_conv n_L_decreasing_meet_L n_n_L n_n_top_n_L n_vector_meet_L)

-- {* AACP Theorem 3.39 *}

lemma n_L_top_meet_L: "C L = L"
  by (metis meet_less_eq_def n_L_below_nL_top meet_commutative)

end

class n_algebra = left_n_algebra + idempotent_left_zero_semiring

begin

(* independence of axioms, checked in n_algebra without the respective axiom:
  lemma n_dist_n_add            : "n(x) + n(y) = n(n(x) ; T + y)" nitpick [expect=genuine,card=5] oops
  lemma n_export                : "n(x) ; n(y) = n(n(x) ; y)" nitpick [expect=genuine,card=4] oops
  lemma n_left_upper_bound      : "n(x) \<le> n(x + y)" nitpick [expect=genuine,card=5] oops
  lemma n_nL_meet_L_nL0         : "n(L) ; x = (x \<frown> L) + n(L ; 0) ; x" nitpick [expect=genuine,card=2] oops
  lemma n_n_L_split_n_n_L_L     : "x ; n(y) ; L = x ; 0 + n(x ; n(y) ; L) ; L" nitpick [expect=genuine,card=6] oops
  lemma n_sub_nL                : "n(x) \<le> n(L)" nitpick [expect=genuine,card=2] oops
  lemma n_L_decreasing          : "n(x) ; L \<le> x" nitpick [expect=genuine,card=3] oops
  lemma n_L_T_meet_mult_combined: "C (x ; y) ; z \<le> C x ; y ; C z" nitpick [expect=genuine,card=4] oops
  lemma n_n_top_split_n_top     : "x ; n(y) ; T \<le> x ; 0 + n(x ; y) ; T" nitpick [expect=genuine,card=4] oops
  lemma n_top_meet_L_below_L    : "x ; T ; y \<frown> L \<le> x ; L ; y" nitpick [expect=genuine,card=5] oops
*)

-- {* AACP Theorem 3.25 *}

lemma n_top_split_0: "n(x) ; T ; y \<le> x ; y + n(x ; 0) ; T"
proof -
  have 1: "n(x) ; T ; y \<frown> L \<le> x ; y"
    by (metis mult_left_isotone n_L_decreasing n_top_meet_L_below_L order_trans)
  have "n(x) ; T ; y = n(x) ; n(L) ; T ; y"
    by (metis n_export n_n_L)
  also have "... = n(x) ; ((T ; y \<frown> L) + n(L ; 0) ; T ; y)"
    by (metis mult_associative n_nL_meet_L_nL0)
  also have "... \<le> n(x) ; (T ; y \<frown> L) + n(x) ; n(L ; 0) ; T"
    by (metis add_right_isotone mult_associative mult_left_dist_add mult_right_isotone top_greatest)
  also have "... \<le> (n(x) ; T ; y \<frown> L) + n(n(x) ; L ; 0) ; T"
    by (metis add_left_isotone dual_order.trans meet.add_least_upper_bound mult_associative mult_left_sub_dist_meet_left mult_left_sub_dist_meet_right n_export n_galois n_sub_nL)
  also have "... \<le> x ; y + n(n(x) ; L ; 0) ; T" using 1
    by (metis add_left_isotone)
  also have "... \<le> x ; y + n(x ; 0) ; T"
    by (metis add_right_isotone mult_left_isotone n_L_decreasing n_isotone)
  finally show ?thesis
    .
qed

-- {* AACP Theorem 3.26 *}

lemma n_top_split: "n(x) ; T ; y \<le> x ; y + n(x ; y) ; T"
  by (metis add_right_isotone add_right_zero meet.order_trans mult_left_isotone mult_left_sub_dist_add_right n_isotone n_top_split_0)

lemma n_n_meet_L_n_zero: "n(x) = (n(x) \<frown> L) + n(x ; 0)" oops

lemma n_below_n_zero: "n(x) \<le> x + n(x ; 0)" oops

lemma n_n_top_split_n_L_n_zero_top: "n(x) ; T = n(x) ; L + n(x ; 0) ; T" oops

lemma n_zero: "n(0) = 0" nitpick [expect=genuine] oops
lemma n_one: "n(1) = 0" nitpick [expect=genuine] oops
lemma n_nL_one: "n(L) = 1" nitpick [expect=genuine] oops
lemma n_nT_one: "n(T) = 1" nitpick [expect=genuine] oops
lemma n_n_zero: "n(x) = n(x ; 0)" nitpick [expect=genuine] oops
lemma n_dist_add: "n(x) + n(y) = n(x + y)" nitpick [expect=genuine] oops
lemma n_L_split: "x ; n(y) ; L = x ; 0 + n(x ; y) ; L" nitpick [expect=genuine] oops
lemma n_split: "x \<le> x ; 0 + n(x ; L) ; T" nitpick [expect=genuine] oops
lemma n_mult_top_1: "n(x ; y) \<le> n(x ; n(y) ; T)" nitpick [expect=genuine] oops
lemma l91_1: "n(L) ; x \<le> n(x ; T) ; T" nitpick [expect=genuine] oops
lemma meet_domain_top: "x \<frown> n(y) ; T = n(y) ; x" nitpick [expect=genuine] oops
lemma meet_domain_2: "x \<frown> n(y) ; T \<le> n(L) ; x" nitpick [expect=genuine] oops
lemma n_nL_top_n_top_meet_L_top_2: "n(L) ; x ; T \<le> n(x ; T \<frown> L) ; T" nitpick [expect=genuine] oops
lemma n_nL_top_n_top_meet_L_top_1: "n(x ; T \<frown> L) ; T \<le> n(L) ; x ; T" nitpick [expect=genuine] oops
lemma l9: "x ; 0 \<frown> L \<le> n(x ; L) ; L" nitpick [expect=genuine] oops
lemma l18_2: "n(x ; L) ; L \<le> n(x) ; L" nitpick [expect=genuine] oops
lemma l51_1: "n(x) ; L \<le> (x \<frown> L) ; 0" nitpick [expect=genuine] oops
lemma l51_2: "(x \<frown> L) ; 0 \<le> n(x) ; L" nitpick [expect=genuine] oops

lemma n_split_equal: "x + n(x ; L) ; T = x ; 0 + n(x ; L) ; T" nitpick [expect=genuine] oops
lemma n_split_top: "x ; T \<le> x ; 0 + n(x ; L) ; T" nitpick [expect=genuine] oops
lemma n_mult: "n(x ; n(y) ; L) = n(x ; y)" nitpick [expect=genuine] oops
lemma n_mult_1: "n(x ; y) \<le> n(x ; n(y) ; L)" nitpick [expect=genuine] oops
lemma n_mult_top: "n(x ; n(y) ; T) = n(x ; y)" nitpick [expect=genuine] oops
lemma n_mult_right_upper_bound: "n(x ; y) \<le> n(z) \<longleftrightarrow> n(x) \<le> n(z) \<and> x ; n(y) ; L \<le> x ; 0 + n(z) ; L" nitpick [expect=genuine] oops
lemma meet_domain: "x \<frown> n(y) ; z = n(y) ; (x \<frown> z)" nitpick [expect=genuine] oops
lemma meet_domain_1: "x \<frown> n(y) ; z \<le> n(y) ; x" nitpick [expect=genuine] oops
lemma meet_domain_top_3: "x \<frown> n(y) ; T \<le> n(y) ; x" nitpick [expect=genuine] oops
lemma n_n_top_n_top_split_n_n_top_top: "n(x) ; T + x ; n(y) ; T = x ; 0 + n(x ; n(y) ; T) ; T" nitpick [expect=genuine] oops
lemma n_n_top_n_top_split_n_n_top_top_1: "x ; 0 + n(x ; n(y) ; T) ; T \<le> n(x) ; T + x ; n(y) ; T" nitpick [expect=genuine] oops
lemma n_n_top_n_top_split_n_n_top_top_2: "n(x) ; T + x ; n(y) ; T \<le> x ; 0 + n(x ; n(y) ; T) ; T" nitpick [expect=genuine] oops
lemma n_nL_top_n_top_meet_L_top: "n(L) ; x ; T = n(x ; T \<frown> L) ; T" nitpick [expect=genuine] oops
lemma l18: "n(x) ; L = n(x ; L) ; L" nitpick [expect=genuine] oops
lemma l22: "x ; 0 \<frown> L = n(x) ; L" nitpick [expect=genuine] oops
lemma l22_1: "x ; 0 \<frown> L = n(x ; L) ; L" nitpick [expect=genuine] oops
lemma l22_2: "x \<frown> L = n(x) ; L" nitpick [expect=genuine] oops
lemma l22_3: "x \<frown> L = n(x ; L) ; L" nitpick [expect=genuine] oops
lemma l22_4: "x \<frown> L \<le> n(x) ; L" nitpick [expect=genuine] oops
lemma l22_5: "x ; 0 \<frown> L \<le> n(x) ; L" nitpick [expect=genuine] oops
lemma l23: "x ; T \<frown> L = n(x) ; L" nitpick [expect=genuine] oops
lemma l51: "n(x) ; L = (x \<frown> L) ; 0" nitpick [expect=genuine] oops
lemma l91: "x = x ; T \<longrightarrow> n(L) ; x \<le> n(x) ; T" nitpick [expect=genuine] oops
lemma l92: "x = x ; T \<longrightarrow> n(L) ; x \<le> n(x \<frown> L) ; T" nitpick [expect=genuine] oops
lemma "x \<frown> L \<le> n(x) ; T" nitpick [expect=genuine] oops
lemma n_meet_comp: "n(x) \<frown> n(y) \<le> n(x) ; n(y)" nitpick [expect=genuine] oops

lemma n_meet_L_0_0_meet_L: "(x \<frown> L) ; 0 = x ; 0 \<frown> L" oops

end

(*
end


theory Recursion

imports Approximation NAlgebra

begin
*)

class n_algebra_apx = n_algebra + apx +
  assumes apx_def: "x \<sqsubseteq> y \<longleftrightarrow> x \<le> y + L \<and> C y \<le> x + n(x) ; T"

begin

lemma apx_transitive_2: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"
proof
  assume 1: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z"
  hence "C z \<le> C (y + n(y) ; T)"
    by (metis apx_def meet.add_least_upper_bound meet.add_left_upper_bound)
  also have "... = C y + n(y) ; T"
    by (metis add_commutative add_left_dist_meet mult_right_dist_add n_add_left_top n_nL_nT)
  also have "... \<le> x + n(x) ; T + n(y) ; T" using 1
    by (metis add_left_isotone apx_def)
  also have "... = x + n(x) ; T + n(C y) ; T"
    by (metis n_T_below_n_meet)
  also have "... \<le> x + n(x) ; T" using 1
    by (metis add_associative add_idempotent add_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show "x \<sqsubseteq> z" using 1
    by (smt add_associative add_commutative apx_def less_eq_def)
qed

lemma apx_meet_L: "y \<sqsubseteq> x \<longrightarrow> x \<frown> L \<le> y \<frown> L"
proof
  assume 1: "y \<sqsubseteq> x"
  have "x \<frown> L = C x \<frown> L"
    by (metis meet_associative meet_commutative n_L_top_meet_L)
  also have "... \<le> (y + n(y) ; T) \<frown> L" using 1
    by (metis apx_def meet.add_left_isotone)
  also have "... = (y \<frown> L) + (n(y) ; T \<frown> L)" using 1
    by (metis meet_commutative meet_left_dist_add)
  also have "... \<le> (y \<frown> L) + n(y \<frown> L) ; T"
    by (metis add_least_upper_bound n_vector_meet_L meet.add_least_upper_bound n_L_decreasing order_refl order_trans)
  finally show "x \<frown> L \<le> y \<frown> L"
    by (metis less_eq_def meet.add_right_upper_bound n_less_eq_char)
qed

-- {* AACP Theorem 4.1 *}

subclass apx_biorder
  apply unfold_locales
  apply (metis add_absorb add_least_upper_bound add_left_upper_bound apx_def meet_commutative)
  apply (metis add_same_context antisym apx_def apx_meet_L relative_equality)
  apply (metis apx_transitive_2)
  done

lemma add_apx_left_isotone_2: "x \<sqsubseteq> y \<longrightarrow> x + z \<sqsubseteq> y + z"
proof
  assume 1: "x \<sqsubseteq> y"
  hence 2: "x + z \<le> y + z + L"
    by (smt add_associative add_commutative add_left_isotone apx_def)
  have "C (y + z) \<le> x + n(x) ; T + C z" using 1
    by (metis add_left_isotone apx_def meet_left_dist_add meet_commutative)
  also have "... \<le> x + z + n(x) ; T"
    by (smt2 add_associative add_commutative add_right_isotone meet.add_right_upper_bound)
  also have "... \<le> x + z + n(x + z) ; T" 
    by (metis add_commutative add_right_isotone mult_left_isotone n_right_upper_bound)
  finally show "x + z \<sqsubseteq> y + z" using 2
    by (metis apx_def)
qed

lemma mult_apx_left_isotone_2: "x \<sqsubseteq> y \<longrightarrow> x ; z \<sqsubseteq> y ; z"
proof
  assume 1: "x \<sqsubseteq> y"
  hence "x ; z \<le> y ; z + L ; z"
    by (metis apx_def mult_left_isotone mult_right_dist_add)
  hence 2: "x ; z \<le> y ; z + L"
    by (metis add_commutative add_left_isotone n_L_below_L order_trans)
  have "C (y ; z) = C y ; z"
    by (metis meet_commutative n_L_T_meet_mult)
  also have "... \<le> x ; z + n(x) ; T ; z" using 1
    by (metis apx_def mult_left_isotone mult_right_dist_add)
  also have "... \<le> x ; z + n(x ; z) ; T"
    by (metis add_least_upper_bound add_left_upper_bound n_top_split)
  finally show "x ; z \<sqsubseteq> y ; z" using 2
    by (metis apx_def)
qed

lemma mult_apx_right_isotone_2: "x \<sqsubseteq> y \<longrightarrow> z ; x \<sqsubseteq> z ; y"
proof
  assume 1: "x \<sqsubseteq> y"
  hence "z ; x \<le> z ; y + z ; L"
    by (metis apx_def mult_left_dist_add mult_right_isotone)
  also have "... \<le> z ; y + z ; 0 + L"
    by (metis add_associative add_right_isotone n_L_split_L)
  finally have 2: "z ; x \<le> z ; y + L"
    by (metis add_right_zero mult_left_dist_add)
  have "C (z ; y) \<le> z ; C y"
    by (metis meet_commutative n_L_T_meet_mult n_L_T_meet_mult_propagate)
  also have "... \<le> z ; (x + n(x) ; T)" using 1
    by (metis apx_def mult_right_isotone)
  also have "... = z ; x + z ; n(x) ; T"
    by (metis mult_associative mult_left_dist_add)
  also have "... \<le> z ; x + n(z ; x) ; T"
    by (metis add_least_upper_bound add_left_upper_bound n_split_top)
  finally show "z ; x \<sqsubseteq> z ; y" using 2
    by (metis apx_def)
qed

-- {* AACP Theorem 4.1 and Theorem 4.2 *}

subclass apx_semiring
  apply unfold_locales
  apply (metis add_commutative add_left_upper_bound apx_def less_eq_def meet.add_left_upper_bound n_L_below_nL_top)
  apply (rule add_apx_left_isotone_2)
  apply (rule mult_apx_left_isotone_2)
  apply (rule mult_apx_right_isotone_2)
  done

-- {* AACP Theorem 4.2 *}

lemma meet_L_apx_isotone: "x \<sqsubseteq> y \<longrightarrow> x \<frown> L \<sqsubseteq> y \<frown> L"
  by (smt add_commutative add_idempotent add_left_dist_meet apx_def apx_meet_L n_less_eq_char_n meet_commutative meet.add_right_isotone)

-- {* AACP Theorem 4.2 *}

lemma n_L_apx_isotone: "x \<sqsubseteq> y \<longrightarrow> n(x) ; L \<sqsubseteq> n(y) ; L"
proof
  assume 1: "x \<sqsubseteq> y"
  have "C (n(y) ; L) \<le> n(C y) ; L"
    by (metis meet.add_left_upper_bound n_T_below_n_meet n_n_L n_n_top_n_L meet_commutative)
  also have "... \<le> n(x) ; L + n(n(x) ; L) ; T" using 1
    by (metis add_left_upper_bound apx_def mult_left_isotone n_add_n_top n_export n_isotone order_trans)
  finally show "n(x) ; L \<sqsubseteq> n(y) ; L"
    by (metis apx_def less_eq_def meet.add_least_upper_bound n_L_decreasing_meet_L)
qed

definition kappa_apx_meet :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_apx_meet f \<longleftrightarrow> apx.has_least_fixpoint f \<and> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<kappa> f = \<mu> f \<triangle> \<nu> f"

definition kappa_mu_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_mu_nu f \<longleftrightarrow> apx.has_least_fixpoint f \<and> \<kappa> f = \<mu> f + (\<nu> f \<frown> L)"

definition nu_below_mu_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "nu_below_mu_nu f \<longleftrightarrow> C (\<nu> f) \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<nu> f) ; T"

definition nu_below_mu_nu_2 :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "nu_below_mu_nu_2 f \<longleftrightarrow> C (\<nu> f) \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<mu> f + (\<nu> f \<frown> L)) ; T"

definition mu_nu_apx_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_nu f \<longleftrightarrow> \<mu> f + (\<nu> f \<frown> L) \<sqsubseteq> \<nu> f"

definition mu_nu_apx_meet :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_meet f \<longleftrightarrow> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<mu> f \<triangle> \<nu> f = \<mu> f + (\<nu> f \<frown> L)"

definition apx_meet_below_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "apx_meet_below_nu f \<longleftrightarrow> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<mu> f \<triangle> \<nu> f \<le> \<nu> f"

lemma mu_below_l: "\<mu> f \<le> \<mu> f + (\<nu> f \<frown> L)"
  by (metis add_left_upper_bound)

lemma l_below_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<longrightarrow> \<mu> f + (\<nu> f \<frown> L) \<le> \<nu> f"
  by (metis add_least_upper_bound meet.add_left_upper_bound mu_below_nu)

lemma n_l_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<longrightarrow> (\<mu> f + (\<nu> f \<frown> L)) \<frown> L = \<nu> f \<frown> L"
  by (smt add_commutative add_left_dist_meet less_eq_def meet_absorb meet_associative meet_commutative mu_below_nu)

lemma l_apx_mu: "\<mu> f + (\<nu> f \<frown> L) \<sqsubseteq> \<mu> f"
proof -
  have 1: "\<mu> f + (\<nu> f \<frown> L) \<le> \<mu> f + L"
    by (metis add_right_isotone meet.add_right_upper_bound)
  have "C (\<mu> f) \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<mu> f + (\<nu> f \<frown> L)) ; T"
    by (metis add_left_upper_bound n_less_eq_char_n meet_commutative)
  thus ?thesis using 1
    by (metis apx_def)
qed

-- {* AACP Theorem 4.8 implies Theorem 4.9 *}

lemma nu_below_mu_nu_nu_below_mu_nu_2: "nu_below_mu_nu f \<longrightarrow> nu_below_mu_nu_2 f"
proof
  assume 1: "nu_below_mu_nu f"
  have "C (\<nu> f) = C (C (\<nu> f))"
    by (metis meet_associative meet_idempotent)
  also have "... \<le> C (\<mu> f + (\<nu> f \<frown> L) + n(\<nu> f) ; T)" using 1
    by (metis calculation meet.add_least_upper_bound meet.add_left_upper_bound nu_below_mu_nu_def)
  also have "... = C (\<mu> f + (\<nu> f \<frown> L)) + C (n(\<nu> f) ; T)"
    by (metis meet_left_dist_add)
  also have "... = C (\<mu> f + (\<nu> f \<frown> L)) + n(\<nu> f) ; T"
    by (metis C_n_mult_closed)
  also have "... \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<nu> f) ; T"
    by (metis add_left_isotone meet.add_right_upper_bound)
  also have "... = \<mu> f + (\<nu> f \<frown> L) + n(\<nu> f \<frown> L) ; T"
    by (metis n_n_meet_L)
  also have "... \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<mu> f + (\<nu> f \<frown> L)) ; T"
    by (metis add_right_isotone mult_left_isotone n_right_upper_bound)
  finally show "nu_below_mu_nu_2 f"
    by (metis nu_below_mu_nu_2_def)
qed

-- {* AACP Theorem 4.9 implies Theorem 4.8 *}

lemma nu_below_mu_nu_2_nu_below_mu_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_2 f \<longrightarrow> nu_below_mu_nu f"
proof
  assume 1: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_2 f"
  hence "C (\<nu> f) \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<mu> f + (\<nu> f \<frown> L)) ; T"
    by (metis nu_below_mu_nu_2_def)
  also have "... \<le> \<mu> f + (\<nu> f \<frown> L) + n(\<nu> f) ; T" using 1
    by (metis add_right_isotone l_below_nu mult_left_isotone n_isotone)
  finally show "nu_below_mu_nu f"
    by (metis nu_below_mu_nu_def)
qed

lemma nu_below_mu_nu_equivalent: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<longrightarrow> (nu_below_mu_nu f \<longleftrightarrow> nu_below_mu_nu_2 f)"
  by (metis nu_below_mu_nu_2_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2)

-- {* AACP Theorem 4.9 implies Theorem 4.10 *}

lemma nu_below_mu_nu_2_mu_nu_apx_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_2 f \<longrightarrow> mu_nu_apx_nu f"
proof
  assume 1: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_2 f"
  hence "\<mu> f + (\<nu> f \<frown> L) \<le> \<nu> f + L"
    by (metis add_commutative add_right_upper_bound l_below_nu order_trans)
  thus "mu_nu_apx_nu f" using 1
    by (metis apx_def mu_nu_apx_nu_def nu_below_mu_nu_2_def)
qed

-- {* AACP Theorem 4.10 implies Theorem 4.11 *}

lemma mu_nu_apx_nu_mu_nu_apx_meet: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> mu_nu_apx_nu f \<longrightarrow> mu_nu_apx_meet f"
proof
  let ?l = "\<mu> f + (\<nu> f \<frown> L)"
  assume "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> mu_nu_apx_nu f"
  hence "is_apx_meet (\<mu> f) (\<nu> f) ?l"
    by (smt add_apx_left_isotone add_commutative apx_meet_L is_apx_meet_def l_apx_mu less_eq_def meet.add_least_upper_bound mu_nu_apx_nu_def)
  thus "mu_nu_apx_meet f"
    by (smt apx_meet_char mu_nu_apx_meet_def)
qed

-- {* AACP Theorem 4.11 implies Theorem 4.12 *}

lemma mu_nu_apx_meet_apx_meet_below_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> mu_nu_apx_meet f \<longrightarrow> apx_meet_below_nu f"
  by (metis apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def)

-- {* AACP Theorem 4.12 implies Theorem 4.9 *}

lemma apx_meet_below_nu_nu_below_mu_nu_2: "apx_meet_below_nu f \<longrightarrow> nu_below_mu_nu_2 f"
proof -
  let ?l = "\<mu> f + (\<nu> f \<frown> L)"
  have "\<forall>m . m \<sqsubseteq> \<mu> f \<and> m \<sqsubseteq> \<nu> f \<and> m \<le> \<nu> f \<longrightarrow> C (\<nu> f) \<le> ?l + n(?l) ; T"
  proof
    fix m
    show "m \<sqsubseteq> \<mu> f \<and> m \<sqsubseteq> \<nu> f \<and> m \<le> \<nu> f \<longrightarrow> C (\<nu> f) \<le> ?l + n(?l) ; T"
    proof
      assume 1: "m \<sqsubseteq> \<mu> f \<and> m \<sqsubseteq> \<nu> f \<and> m \<le> \<nu> f"
      hence "m \<le> ?l"
        by (smt add_commutative add_left_dist_meet add_left_upper_bound apx_def meet_less_eq_def meet.add_least_upper_bound)
      hence "m + n(m) ; T \<le> ?l + n(?l) ; T"
        by (metis add_isotone mult_left_isotone n_isotone)
      thus "C (\<nu> f) \<le> ?l + n(?l) ; T" using 1
        by (smt apx_def order_trans)
    qed
  qed
  thus ?thesis
    by (smt apx_meet_below_nu_def apx_meet_same apx_meet_unique is_apx_meet_def nu_below_mu_nu_2_def)
qed

-- {* AACP Theorem 4.5 implies Theorem 4.6 *}

lemma has_apx_least_fixpoint_kappa_apx_meet: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> apx.has_least_fixpoint f \<longrightarrow> kappa_apx_meet f"
proof
  assume 1: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> apx.has_least_fixpoint f"
  hence 2: "\<forall>w . w \<sqsubseteq> \<mu> f \<and> w \<sqsubseteq> \<nu> f \<longrightarrow> C (\<kappa> f) \<le> w + n(w) ; T"
    by (metis apx_def meet.add_right_isotone order_trans kappa_below_nu)
  have "\<forall>w . w \<sqsubseteq> \<mu> f \<and> w \<sqsubseteq> \<nu> f \<longrightarrow> w \<le> \<kappa> f + L" using 1
    by (metis add_left_isotone apx_def mu_below_kappa order_trans)
  hence "\<forall>w . w \<sqsubseteq> \<mu> f \<and> w \<sqsubseteq> \<nu> f \<longrightarrow> w \<sqsubseteq> \<kappa> f" using 2
    by (metis apx_def)
  hence "is_apx_meet (\<mu> f) (\<nu> f) (\<kappa> f)" using 1
    by (smt apx_meet_char is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu kappa_apx_meet_def)
  thus "kappa_apx_meet f" using 1
    by (metis apx_meet_char kappa_apx_meet_def)
qed

-- {* AACP Theorem 4.6 implies Theorem 4.12 *}

lemma kappa_apx_meet_apx_meet_below_nu: "has_greatest_fixpoint f \<and> kappa_apx_meet f \<longrightarrow> apx_meet_below_nu f"
  by (metis apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu)

-- {* AACP Theorem 4.12 implies Theorem 4.7 *}

lemma apx_meet_below_nu_kappa_mu_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> isotone f \<and> apx.isotone f \<and> apx_meet_below_nu f \<longrightarrow> kappa_mu_nu f"
proof
  let ?l = "\<mu> f + (\<nu> f \<frown> L)"
  let ?m = "\<mu> f \<triangle> \<nu> f"
  assume 1: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> isotone f \<and> apx.isotone f \<and> apx_meet_below_nu f"
  hence 2: "?m = ?l"
    by (metis apx_meet_below_nu_nu_below_mu_nu_2 mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_2_mu_nu_apx_nu)
  have 3: "?l \<le> f(?l) + L"
  proof -
    have "?l \<le> \<mu> f + L"
      by (metis add_right_isotone meet.add_right_upper_bound)
    also have "... = f(\<mu> f) + L" using 1
      by (metis is_least_fixpoint_def least_fixpoint)
    also have "... \<le> f(?l) + L" using 1
      by (metis add_left_isotone add_left_upper_bound isotone_def)
    finally show "?l \<le> f(?l) + L"
      by metis
  qed
  have "C (f(?l)) \<le> ?l + n(?l) ; T"
  proof -
    have "C (f(?l)) \<le> C (f(\<nu> f))" using 1 2
      by (metis apx_meet_below_nu_def isotone_def meet.add_right_isotone)
    also have "... = C (\<nu> f)" using 1
      by (metis greatest_fixpoint is_greatest_fixpoint_def)
    also have "... \<le> ?l + n(?l) ; T" using 1
      by (metis apx_meet_below_nu_nu_below_mu_nu_2 nu_below_mu_nu_2_def)
    finally show "C (f(?l)) \<le> ?l + n(?l) ; T"
      by metis
  qed
  hence 4: "?l \<sqsubseteq> f(?l)" using 3
    by (metis apx_def)
  have 5: "f(?l) \<sqsubseteq> \<mu> f"
  proof -
    have "?l \<sqsubseteq> \<mu> f"
      by (metis l_apx_mu)
    thus "f(?l) \<sqsubseteq> \<mu> f" using 1
      by (metis apx.isotone_def is_least_fixpoint_def least_fixpoint)
  qed
  have 6: "f(?l) \<sqsubseteq> \<nu> f"
  proof -
    have "?l \<sqsubseteq> \<nu> f" using 1 2
      by (metis apx_greatest_lower_bound apx_meet_below_nu_def apx_reflexive)
    thus "f(?l) \<sqsubseteq> \<nu> f" using 1
      by (metis apx.isotone_def greatest_fixpoint is_greatest_fixpoint_def)
  qed
  hence "f(?l) \<sqsubseteq> ?l" using 1 2 5
    by (metis apx_greatest_lower_bound apx_meet_below_nu_def)
  hence 7: "f(?l) = ?l" using 4
    by (metis apx_antisymmetric)
  have "\<forall>y . f(y) = y \<longrightarrow> ?l \<sqsubseteq> y"
  proof
    fix y
    show "f(y) = y \<longrightarrow> ?l \<sqsubseteq> y"
    proof
      assume 8: "f(y) = y"
      hence 9: "?l \<le> y + L" using 1
        by (metis add_isotone is_least_fixpoint_def least_fixpoint meet.add_right_upper_bound)
      have "y \<le> \<nu> f" using 1 8
        by (metis greatest_fixpoint is_greatest_fixpoint_def)
      hence "C y \<le> ?l + n(?l) ; T" using 1 4 6
        by (smt apx_meet_below_nu_nu_below_mu_nu_2 meet.add_right_isotone nu_below_mu_nu_2_def order_trans)
      thus "?l \<sqsubseteq> y" using 9
        by (metis apx_def)
    qed
  qed
  thus "kappa_mu_nu f" using 1 2 7
    by (smt apx.least_fixpoint_same apx.has_least_fixpoint_def apx.is_least_fixpoint_def kappa_mu_nu_def)
qed

-- {* AACP Theorem 4.7 implies Theorem 4.5 *}

lemma kappa_mu_nu_has_apx_least_fixpoint: "kappa_mu_nu f \<longrightarrow> apx.has_least_fixpoint f"
  by (metis kappa_mu_nu_def)

-- {* AACP Theorem 4.8 implies Theorem 4.7 *}

lemma nu_below_mu_nu_kappa_mu_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> isotone f \<and> apx.isotone f \<and> nu_below_mu_nu f \<longrightarrow> kappa_mu_nu f"
  by (metis apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_nu_below_mu_nu_2 nu_below_mu_nu_2_mu_nu_apx_nu)

-- {* AACP Theorem 4.7 implies Theorem 4.8 *}

lemma kappa_mu_nu_nu_below_mu_nu: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> kappa_mu_nu f \<longrightarrow> nu_below_mu_nu f"
  by (metis apx_meet_below_nu_nu_below_mu_nu_2 has_apx_least_fixpoint_kappa_apx_meet nu_below_mu_nu_2_nu_below_mu_nu kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_has_apx_least_fixpoint)

definition kappa_mu_nu_L :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_mu_nu_L f \<longleftrightarrow> apx.has_least_fixpoint f \<and> \<kappa> f = \<mu> f + n(\<nu> f) ; L"

definition nu_below_mu_nu_L :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "nu_below_mu_nu_L f \<longleftrightarrow> C (\<nu> f) \<le> \<mu> f + n(\<nu> f) ; T"

definition mu_nu_apx_nu_L :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_nu_L f \<longleftrightarrow> \<mu> f + n(\<nu> f) ; L \<sqsubseteq> \<nu> f"

definition mu_nu_apx_meet_L :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_meet_L f \<longleftrightarrow> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<mu> f \<triangle> \<nu> f = \<mu> f + n(\<nu> f) ; L"

lemma n_below_l: "x + n(y) ; L \<le> x + (y \<frown> L)"
  by (metis add_right_isotone n_L_decreasing_meet_L)

lemma n_equal_l: "nu_below_mu_nu_L f \<longrightarrow> \<mu> f + n(\<nu> f) ; L = \<mu> f + (\<nu> f \<frown> L)"
proof
  assume "nu_below_mu_nu_L f"
  hence "\<nu> f \<frown> L \<le> (\<mu> f + n(\<nu> f) ; T) \<frown> L"
    by (metis meet_L_below_C meet.add_least_upper_bound meet.add_right_upper_bound nu_below_mu_nu_L_def order_trans)
  also have "... \<le> \<mu> f + (n(\<nu> f) ; T \<frown> L)"
    by (metis add_left_dist_meet add_right_upper_bound meet.add_right_isotone)
  also have "... \<le> \<mu> f + n(\<nu> f) ; L"
    by (metis add_right_isotone n_vector_meet_L)
  finally have "\<mu> f + (\<nu> f \<frown> L) \<le> \<mu> f + n(\<nu> f) ; L"
    by (metis add_least_upper_bound add_left_upper_bound)
  thus "\<mu> f + n(\<nu> f) ; L = \<mu> f + (\<nu> f \<frown> L)"
    by (metis antisym n_below_l)
qed

-- {* AACP Theorem 4.14 implies Theorem 4.8 *}

lemma nu_below_mu_nu_L_nu_below_mu_nu: "nu_below_mu_nu_L f \<longrightarrow> nu_below_mu_nu f"
  by (metis add_associative add_right_top mult_left_dist_add n_equal_l nu_below_mu_nu_L_def nu_below_mu_nu_def)

-- {* AACP Theorem 4.14 implies Theorem 4.13 *}

lemma nu_below_mu_nu_L_kappa_mu_nu_L: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> isotone f \<and> apx.isotone f \<and> nu_below_mu_nu_L f \<longrightarrow> kappa_mu_nu_L f"
  by (metis n_equal_l nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_kappa_mu_nu kappa_mu_nu_L_def kappa_mu_nu_def)

-- {* AACP Theorem 4.14 implies Theorem 4.15 *}

lemma nu_below_mu_nu_L_mu_nu_apx_nu_L: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_L f \<longrightarrow> mu_nu_apx_nu_L f"
  by (metis mu_nu_apx_nu_L_def mu_nu_apx_nu_def n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2)

-- {* AACP Theorem 4.14 implies Theorem 4.16 *}

lemma nu_below_mu_nu_L_mu_nu_apx_meet_L: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> nu_below_mu_nu_L f \<longrightarrow> mu_nu_apx_meet_L f"
  by (metis mu_nu_apx_meet_L_def mu_nu_apx_meet_def mu_nu_apx_nu_mu_nu_apx_meet n_equal_l nu_below_mu_nu_2_mu_nu_apx_nu nu_below_mu_nu_L_nu_below_mu_nu nu_below_mu_nu_nu_below_mu_nu_2)

-- {* AACP Theorem 4.15 implies Theorem 4.14 *}

lemma mu_nu_apx_nu_L_nu_below_mu_nu_L: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> mu_nu_apx_nu_L f \<longrightarrow> nu_below_mu_nu_L f"
proof
  let ?n = "\<mu> f + n(\<nu> f) ; L"
  let ?l = "\<mu> f + (\<nu> f \<frown> L)"
  assume 1: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> mu_nu_apx_nu_L f"
  hence "C (\<nu> f) \<le> ?n + n(?n) ; T"
    by (metis apx_def mu_nu_apx_nu_L_def)
  also have "... \<le> ?n + n(?l) ; T"
    by (metis add_right_isotone n_isotone mult_left_isotone n_below_l)
  also have "... \<le> ?n + n(\<nu> f) ; T" using 1
    by (metis add_right_isotone n_isotone l_below_nu mult_left_isotone)
  finally show "nu_below_mu_nu_L f"
    by (metis add_associative add_right_top mult_left_dist_add nu_below_mu_nu_L_def)
qed

-- {* AACP Theorem 4.13 implies Theorem 4.15 *}

lemma kappa_mu_nu_L_mu_nu_apx_nu_L: "has_greatest_fixpoint f \<and> kappa_mu_nu_L f \<longrightarrow> mu_nu_apx_nu_L f"
  by (metis mu_nu_apx_nu_L_def kappa_apx_below_nu kappa_mu_nu_L_def)

-- {* AACP Theorem 4.16 implies Theorem 4.15 *}

lemma mu_nu_apx_meet_L_mu_nu_apx_nu_L: "mu_nu_apx_meet_L f \<longrightarrow> mu_nu_apx_nu_L f"
  by (smt apx_meet_same has_apx_meet_def is_apx_meet_def mu_nu_apx_meet_L_def mu_nu_apx_nu_L_def)

-- {* AACP Theorem 4.13 implies Theorem 4.14 *}

lemma kappa_mu_nu_L_nu_below_mu_nu_L: "has_least_fixpoint f \<and> has_greatest_fixpoint f \<and> kappa_mu_nu_L f \<longrightarrow> nu_below_mu_nu_L f"
  by (metis mu_nu_apx_nu_L_nu_below_mu_nu_L kappa_mu_nu_L_mu_nu_apx_nu_L)

lemma nu_below_mu_nu_nu_below_mu_nu_L: "nu_below_mu_nu f \<longrightarrow> nu_below_mu_nu_L f" nitpick [expect=genuine] oops

lemma unfold_fold_1: "isotone f \<and> has_least_prefixpoint f \<and> apx.has_least_fixpoint f \<and> f(x) \<le> x \<longrightarrow> \<kappa> f \<le> x + L"
  by (metis add_left_isotone apx_def has_least_fixpoint_def is_least_prefixpoint_def least_prefixpoint_char least_prefixpoint_fixpoint order_trans pmu_mu kappa_apx_below_mu)

lemma unfold_fold_2: "isotone f \<and> apx.isotone f \<and> has_least_prefixpoint f \<and> has_greatest_fixpoint f \<and> apx.has_least_fixpoint f \<and> f(x) \<le> x \<and> \<kappa> f \<frown> L \<le> x \<frown> L \<longrightarrow> \<kappa> f \<le> x"
proof
  assume 1: "isotone f \<and> apx.isotone f \<and> has_least_prefixpoint f \<and> has_greatest_fixpoint f \<and> apx.has_least_fixpoint f \<and> f(x) \<le> x \<and> \<kappa> f \<frown> L \<le> x \<frown> L"
  hence "\<kappa> f \<frown> L = \<nu> f \<frown> L"
    by (metis apx_meet_L meet.add_left_isotone meet.antisym kappa_apx_below_nu kappa_below_nu)
  hence "\<kappa> f = (\<kappa> f \<frown> L) + \<mu> f" using 1
    by (metis apx_meet_below_nu_kappa_mu_nu has_apx_least_fixpoint_kappa_apx_meet add_commutative least_fixpoint_char least_prefixpoint_fixpoint kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)
  thus "\<kappa> f \<le> x" using 1
    by (metis add_least_upper_bound is_least_prefixpoint_def least_prefixpoint meet.add_least_upper_bound pmu_mu)
qed

end

class n_algebra_apx_2 = n_algebra + apx +
  assumes apx_def: "x \<sqsubseteq> y \<longleftrightarrow> x \<le> y + L \<and> y \<le> x + n(x) ; T"

begin

lemma apx_transitive_2: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"
proof
  assume 1: "x \<sqsubseteq> y \<and> y \<sqsubseteq> z"
  hence "z \<le> y + n(y) ; T"
    by (metis apx_def)
  also have "... \<le> x + n(x) ; T + n(y) ; T" using 1
    by (metis add_left_isotone apx_def)
  also have "... \<le> x + n(x) ; T" using 1
    by (metis add_associative add_idempotent add_right_isotone apx_def mult_left_isotone n_add_n_top n_isotone)
  finally show "x \<sqsubseteq> z" using 1
    by (smt add_associative add_commutative apx_def less_eq_def)
qed

lemma apx_meet_L: "y \<sqsubseteq> x \<longrightarrow> x \<frown> L \<le> y \<frown> L"
proof
  assume 1: "y \<sqsubseteq> x"
  have "x \<frown> L \<le> (y \<frown> L) + (n(y) ; T \<frown> L)" using 1
    by (metis apx_def meet_commutative meet_left_dist_add meet.add_left_isotone)
  also have "... \<le> (y \<frown> L) + n(y \<frown> L) ; T"
    by (metis add_least_upper_bound n_vector_meet_L meet.add_least_upper_bound n_L_decreasing order_refl order_trans)
  finally show "x \<frown> L \<le> y \<frown> L"
    by (metis less_eq_def meet.add_right_upper_bound n_less_eq_char)
qed

-- {* AACP Theorem 4.1 *}

subclass apx_biorder
  apply unfold_locales
  apply (metis add_left_upper_bound apx_def)
  apply (metis add_same_context antisym apx_def apx_meet_L relative_equality)
  apply (metis apx_transitive_2)
  done

lemma add_apx_left_isotone_2: "x \<sqsubseteq> y \<longrightarrow> x + z \<sqsubseteq> y + z"
proof
  assume 1: "x \<sqsubseteq> y"
  hence 2: "x + z \<le> y + z + L"
    by (smt add_associative add_commutative add_left_isotone apx_def)
  have "y + z \<le> x + n(x) ; T + z" using 1
    by (metis add_left_isotone apx_def)
  also have "... \<le> x + z + n(x + z) ; T"
    by (metis add_associative add_commutative add_right_isotone mult_left_isotone n_right_upper_bound)
  finally show "x + z \<sqsubseteq> y + z" using 2
    by (metis apx_def)
qed

lemma mult_apx_left_isotone_2: "x \<sqsubseteq> y \<longrightarrow> x ; z \<sqsubseteq> y ; z"
proof
  assume 1: "x \<sqsubseteq> y"
  hence "x ; z \<le> y ; z + L ; z"
    by (metis apx_def mult_left_isotone mult_right_dist_add)
  hence 2: "x ; z \<le> y ; z + L"
    by (metis add_commutative add_left_isotone n_L_below_L order_trans)
  have "y ; z \<le> x ; z + n(x) ; T ; z" using 1
    by (metis apx_def mult_left_isotone mult_right_dist_add)
  also have "... \<le> x ; z + n(x ; z) ; T"
    by (metis add_least_upper_bound add_left_upper_bound n_top_split)
  finally show "x ; z \<sqsubseteq> y ; z" using 2
    by (metis apx_def)
qed

lemma mult_apx_right_isotone_2: "x \<sqsubseteq> y \<longrightarrow> z ; x \<sqsubseteq> z ; y"
proof
  assume 1: "x \<sqsubseteq> y"
  hence "z ; x \<le> z ; y + z ; L"
    by (metis apx_def mult_left_dist_add mult_right_isotone)
  also have "... \<le> z ; y + z ; 0 + L"
    by (metis add_associative add_right_isotone n_L_split_L)
  finally have 2: "z ; x \<le> z ; y + L"
    by (metis add_right_zero mult_left_dist_add)
  have "z ; y \<le> z ; (x + n(x) ; T)" using 1
    by (metis apx_def mult_right_isotone)
  also have "... = z ; x + z ; n(x) ; T"
    by (metis mult_associative mult_left_dist_add)
  also have "... \<le> z ; x + n(z ; x) ; T"
    by (metis add_least_upper_bound add_left_upper_bound n_split_top)
  finally show "z ; x \<sqsubseteq> z ; y" using 2
    by (metis apx_def)
qed

end

(*
end


theory NOmegaAlgebra

imports OmegaAlgebra Recursion

begin
*)

class itering_apx = bounded_itering + n_algebra_apx

begin

lemma circ_L: "L\<^sup>\<circ> = L + 1"
  by (metis add_commutative mult_top_circ n_L_top_L)

lemma C_circ_import: "C (x\<^sup>\<circ>) \<le> (C x)\<^sup>\<circ>"
proof -
  have 1: "C x ; x\<^sup>\<circ> \<le> (C x)\<^sup>\<circ> ; C x"
    by (metis C_mult_propagate circ_simulate eq_refl)
  have "C (x\<^sup>\<circ>) = C (1 + x ; x\<^sup>\<circ>)"
    by (metis circ_left_unfold)
  also have "... = C 1 + C (x ; x\<^sup>\<circ>)"
    by (metis meet_left_dist_add)
  also have "... \<le> 1 + C (x ; x\<^sup>\<circ>)"
    by (metis add_left_isotone meet.add_right_upper_bound)
  also have "... = 1 + C x ; x\<^sup>\<circ>"
    by (metis n_L_T_meet_mult)
  also have "... \<le> (C x)\<^sup>\<circ>" using 1
    by (metis add_right_isotone circ_left_unfold circ_plus_same)
  finally show ?thesis
    .
qed

-- {* AACP Theorem 4.3 and Theorem 4.4 *}

lemma circ_apx_isotone: "x \<sqsubseteq> y \<longrightarrow> x\<^sup>\<circ> \<sqsubseteq> y\<^sup>\<circ>"
proof
  assume "x \<sqsubseteq> y"
  hence 1: "x \<le> y + L \<and> C y \<le> x + n(x) ; T"
    by (metis apx_def)
  have "C (y\<^sup>\<circ>) \<le> (C y)\<^sup>\<circ>"
    by (metis C_circ_import)
  also have "... \<le> x\<^sup>\<circ> + x\<^sup>\<circ> ; n(x) ; T" using 1
    by (metis circ_isotone circ_left_top circ_unfold_sum mult_associative)
  also have "... \<le> x\<^sup>\<circ> + (x\<^sup>\<circ> ; 0 + n(x\<^sup>\<circ> ; x) ; T)"
    by (smt add_right_isotone n_n_top_split_n_top)
  also have "... \<le> x\<^sup>\<circ> + (x\<^sup>\<circ> ; 0 + n(x\<^sup>\<circ>) ; T)"
    by (metis add_right_isotone mult_left_isotone n_isotone right_plus_below_circ)
  also have "... = x\<^sup>\<circ> + n(x\<^sup>\<circ>) ; T"
    by (smt add_associative add_commutative less_eq_def zero_right_mult_decreasing)
  finally have 2: "C (y\<^sup>\<circ>) \<le> x\<^sup>\<circ> + n(x\<^sup>\<circ>) ; T"
    by metis
  have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> ; L\<^sup>\<circ>" using 1
    by (metis circ_add_1 circ_back_loop_fixpoint circ_isotone n_L_below_L less_eq_def mult_associative)
  also have "... = y\<^sup>\<circ> + y\<^sup>\<circ> ; L"
    by (metis add_commutative circ_L mult_left_dist_add mult_right_one)
  also have "... \<le> y\<^sup>\<circ> + y\<^sup>\<circ> ; 0 + L"
    by (metis add_associative add_right_isotone n_L_split_L)
  finally have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> + L"
    by (metis add_commutative less_eq_def zero_right_mult_decreasing)
  thus "x\<^sup>\<circ> \<sqsubseteq> y\<^sup>\<circ>" using 2
    by (metis apx_def)
qed

end

class n_omega_algebra_1 = bounded_left_zero_omega_algebra + n_algebra_apx + Omega +
  assumes Omega_def: "x\<^sup>\<Omega> = n(x\<^sup>\<omega>) ; L + x\<^sup>\<star>"

begin

-- {* AACP Theorem 8.13 *}

lemma C_omega_export: "C (x\<^sup>\<omega>) = (C x)\<^sup>\<omega>"
proof -
  have "C (x\<^sup>\<omega>) = C x ; C (x\<^sup>\<omega>)"
    by (metis C_mult_propagate n_L_T_meet_mult omega_unfold)
  hence 1: "C (x\<^sup>\<omega>) \<le> (C x)\<^sup>\<omega>"
    by (metis omega_induct_mult order.refl)
  have "(C x)\<^sup>\<omega> = C (x ; (C x)\<^sup>\<omega>)"
    by (metis n_L_T_meet_mult omega_unfold)
  also have "... \<le> C (x\<^sup>\<omega>)"
    by (metis calculation meet.add_least_upper_bound meet.add_left_upper_bound meet_commutative omega_isotone)
  finally show ?thesis using 1
    by (metis antisym)
qed  

-- {* AACP Theorem 8.2 *}

lemma L_mult_star: "L ; x\<^sup>\<star> = L"
  by (metis less_eq_def mult_associative n_L_below_L star.circ_back_loop_fixpoint)

-- {* AACP Theorem 8.3 *}

lemma mult_L_star: "(x ; L)\<^sup>\<star> = 1 + x ; L"
  by (smt L_mult_star mult_associative star.circ_mult)

lemma mult_L_omega_below: "(x ; L)\<^sup>\<omega> \<le> x ; L"
  by (metis mult_right_isotone n_L_below_L omega_slide)

-- {* AACP Theorem 8.5 *}

lemma mult_L_add_star: "(x ; L + y)\<^sup>\<star> = y\<^sup>\<star> + y\<^sup>\<star> ; x ; L"
  by (metis L_mult_star mult_associative star.circ_add_1 star.circ_decompose_6 star.circ_unfold_sum)

lemma mult_L_add_omega_below: "(x ; L + y)\<^sup>\<omega> \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; x ; L"
proof -
  have "(x ; L + y)\<^sup>\<omega> \<le> y\<^sup>\<star> ; x ; L + (y\<^sup>\<star> ; x ; L)\<^sup>\<star> ; y\<^sup>\<omega>"
    by (metis add_commutative mult_associative omega_decompose add_left_isotone mult_L_omega_below)
  also have "... \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; x ; L"
    by (smt add_associative add_commutative less_eq_def mult_L_star mult_associative mult_left_dist_add mult_left_one mult_right_dist_add n_L_below_L order_refl)
  finally show ?thesis
    by metis
qed

lemma n_Omega_isotone: "x \<le> y \<longrightarrow> x\<^sup>\<Omega> \<le> y\<^sup>\<Omega>"
  by (metis Omega_def add_isotone mult_left_isotone n_isotone omega_isotone star_isotone)

lemma n_star_below_Omega: "x\<^sup>\<star> \<le> x\<^sup>\<Omega>"
  by (metis add_right_upper_bound Omega_def)

lemma mult_L_star_mult_below: "(x ; L)\<^sup>\<star> ; y \<le> y + x ; L"
  by (metis add_right_isotone mult_associative mult_right_isotone n_L_below_L star_left_induct)

end

sublocale n_omega_algebra_1 < star!: itering_apx where circ = star ..

class n_omega_algebra = n_omega_algebra_1 + n_algebra_apx +
  assumes n_split_omega_mult: "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> ; n(x\<^sup>\<omega>) ; T"
  assumes tarski: "x ; L \<le> x ; L ; x ; L"

begin

-- {* AACP Theorem 8.4 *}

lemma mult_L_omega: "(x ; L)\<^sup>\<omega> = x ; L"
  apply (rule antisym)
  apply (rule mult_L_omega_below)
  apply (metis mult_associative omega_induct_mult tarski)
  done

-- {* AACP Theorem 8.6 *}

lemma mult_L_add_omega: "(x ; L + y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> ; x ; L"
  apply (rule antisym)
  apply (rule mult_L_add_omega_below)
  apply (metis add_right_isotone add_right_upper_bound less_eq_def mult_L_omega mult_associative mult_isotone omega_sub_dist star.circ_sub_dist star_mult_omega)
  done

-- {* AACP Theorem 8.1 *}

lemma tarski_mult_top_idempotent: "x ; L = x ; L ; x ; L"
  by (metis mult_L_omega mult_associative omega_unfold)

-- {* AACP Theorem 8.7 *}

lemma n_below_n_omega: "n(x) \<le> n(x\<^sup>\<omega>)"
proof -
  have "n(x) ; L \<le> n(x) ; L ; n(x) ; L"
    by (metis tarski)
  also have "... \<le> x ; n(x) ; L"
    by (metis mult_left_isotone n_L_decreasing)
  finally have "n(x) ; L \<le> x\<^sup>\<omega>"
    by (metis mult_associative omega_induct_mult)
  thus ?thesis
    by (metis n_galois)
qed

-- {* AACP Theorem 8.14 *}

lemma n_split_omega_add_zero: "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T"
proof -
  have "n(x\<^sup>\<omega>) ; T + x ; (x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T) = n(x\<^sup>\<omega>) ; T + x ; x\<^sup>\<star> ; 0 + x ; n(x\<^sup>\<omega>) ; T"
    by (metis add_associative mult_associative mult_left_dist_add)
  also have "... \<le> n(x\<^sup>\<omega>) ; T + x ; x\<^sup>\<star> ; 0 + x ; 0 + n(x\<^sup>\<omega>) ; T"
    by (metis add_associative add_right_isotone n_n_top_split_n_top omega_unfold)
  also have "... = x ; x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T"
    by (smt add_associative add_commutative add_left_top add_right_zero mult_associative mult_left_dist_add)
  also have "... \<le> x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T"
    by (metis add_left_isotone mult_left_isotone star.left_plus_below_circ)
  finally have "x\<^sup>\<star> ; n(x\<^sup>\<omega>) ; T \<le> x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T"
    by (metis mult_associative star_left_induct)
  thus ?thesis
    by (metis n_split_omega_mult order_trans)
qed

lemma n_split_omega_add: "C (x\<^sup>\<omega>) \<le> x\<^sup>\<star> + n(x\<^sup>\<omega>) ; T"
  by (metis add_left_isotone n_split_omega_add_zero order_trans zero_right_mult_decreasing)

-- {* AACP Theorem 8.12 *}

lemma n_dist_omega_star: "n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) = n(y\<^sup>\<omega>) + n(y\<^sup>\<star> ; z)"
proof -
  have "n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) = n(C (y\<^sup>\<omega>) + C (y\<^sup>\<star> ; z))"
    by (metis meet_left_dist_add n_C)
  also have "... \<le> n(C (y\<^sup>\<omega>) + y\<^sup>\<star> ; z)"
    by (smt2 add_least_upper_bound add_left_upper_bound add_right_upper_bound meet.add_left_upper_bound meet_commutative n_isotone order_trans)
  also have "... \<le> n(y\<^sup>\<star> ; 0 + n(y\<^sup>\<omega>) ; T + y\<^sup>\<star> ; z)"
    by (metis add_commutative add_right_isotone n_isotone n_split_omega_add_zero)
  also have "... = n(y\<^sup>\<omega>) + n(y\<^sup>\<star> ; z)"
    by (smt add_associative add_commutative add_right_zero mult_left_dist_add n_dist_n_add)
  finally show ?thesis
    by (metis add_least_upper_bound n_left_upper_bound n_right_upper_bound antisym)
qed

lemma mult_L_add_circ_below: "(x ; L + y)\<^sup>\<Omega> \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> + y\<^sup>\<star> ; x ; L"
proof -
  have "(x ; L + y)\<^sup>\<Omega> \<le> n(y\<^sup>\<omega> + y\<^sup>\<star> ; x ; L) ; L + (x ; L + y)\<^sup>\<star>"
    by (metis add_left_isotone mult_L_add_omega_below mult_left_isotone n_isotone Omega_def)
  also have "... = n(y\<^sup>\<omega>) ; L + n(y\<^sup>\<star> ; x ; L) ; L + (x ; L + y)\<^sup>\<star>"
    by (metis mult_associative mult_right_dist_add n_dist_omega_star)
  also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> + y\<^sup>\<star> ; x ; L"
    by (smt add_associative add_commutative add_idempotent add_right_isotone mult_L_add_star n_L_decreasing)
  finally show ?thesis
    by metis
qed

lemma n_mult_omega_L_below_zero: "n(y ; x\<^sup>\<omega>) ; L \<le> y ; x\<^sup>\<star> ; 0 + y ; n(x\<^sup>\<omega>) ; L"
proof -
  have "n(y ; x\<^sup>\<omega>) ; L \<le> C (y ; x\<^sup>\<omega>) \<frown> L"
    by (metis n_C n_L_increasing n_galois n_n_L n_n_meet_L)
  also have "... \<le> y ; C (x\<^sup>\<omega>) \<frown> L"
    by (metis meet.add_left_isotone n_L_T_meet_mult n_L_T_meet_mult_propagate)
  also have "... \<le> y ; (x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; T) \<frown> L"
    by (metis meet_commutative meet.add_right_isotone mult_right_isotone n_split_omega_add_zero)
  also have "... = (y ; x\<^sup>\<star> ; 0 \<frown> L) + (y ; n(x\<^sup>\<omega>) ; T \<frown> L)"
    by (metis meet_commutative meet_left_dist_add mult_associative mult_left_dist_add)
  also have "... \<le> (y ; x\<^sup>\<star> ; 0 \<frown> L) + y ; n(x\<^sup>\<omega>) ; L"
    by (metis add_right_isotone n_vector_meet_L)
  also have "... \<le> y ; x\<^sup>\<star> ; 0 + y ; n(x\<^sup>\<omega>) ; L"
    by (metis add_left_isotone meet.add_left_upper_bound)
  finally show ?thesis
    by metis
qed

-- {* AACP Theorem 8.10 *}

lemma n_mult_omega_L_star_zero: "y ; x\<^sup>\<star> ; 0 + n(y ; x\<^sup>\<omega>) ; L = y ; x\<^sup>\<star> ; 0 + y ; n(x\<^sup>\<omega>) ; L"
  apply (rule antisym)
  apply (metis add_least_upper_bound mult_associative mult_left_dist_add mult_left_sub_dist_add_left n_mult_omega_L_below_zero)
  apply (smt add_associative add_commutative add_left_zero add_right_isotone mult_associative mult_left_dist_add n_n_L_split_n_L)
  done

-- {* AACP Theorem 8.11 *}

lemma n_mult_omega_L_star: "y ; x\<^sup>\<star> + n(y ; x\<^sup>\<omega>) ; L = y ; x\<^sup>\<star> + y ; n(x\<^sup>\<omega>) ; L"
  by (metis zero_right_mult_decreasing n_mult_omega_L_star_zero add_relative_same_increasing)

lemma n_mult_omega_L_below: "n(y ; x\<^sup>\<omega>) ; L \<le> y ; x\<^sup>\<star> + y ; n(x\<^sup>\<omega>) ; L"
  by (metis add_right_upper_bound n_mult_omega_L_star)

lemma n_omega_L_below_zero: "n(x\<^sup>\<omega>) ; L \<le> x ; x\<^sup>\<star> ; 0 + x ; n(x\<^sup>\<omega>) ; L"
  by (smt omega_unfold n_mult_omega_L_below_zero add_left_isotone star.left_plus_below_circ order_trans)

lemma n_omega_L_below: "n(x\<^sup>\<omega>) ; L \<le> x\<^sup>\<star> + x ; n(x\<^sup>\<omega>) ; L"
  by (metis omega_unfold n_mult_omega_L_below add_left_isotone star.left_plus_below_circ order_trans)

lemma n_omega_L_star_zero: "x ; x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; L = x ; x\<^sup>\<star> ; 0 + x ; n(x\<^sup>\<omega>) ; L"
  by (metis n_mult_omega_L_star_zero omega_unfold)

-- {* AACP Theorem 8.8 *}

lemma n_omega_L_star: "x\<^sup>\<star> + n(x\<^sup>\<omega>) ; L = x\<^sup>\<star> + x ; n(x\<^sup>\<omega>) ; L"
  by (metis star.circ_mult_upper_bound star.left_plus_below_circ zero_least n_omega_L_star_zero add_relative_same_increasing)

-- {* AACP Theorem 8.9 *}

lemma n_omega_L_star_zero_star: "x\<^sup>\<star> ; 0 + n(x\<^sup>\<omega>) ; L = x\<^sup>\<star> ; 0 + x\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L"
  by (metis n_mult_omega_L_star_zero star_mult_omega mult_associative star.circ_transitive_equal)

-- {* AACP Theorem 8.8 *}

lemma n_omega_L_star_star: "x\<^sup>\<star> + n(x\<^sup>\<omega>) ; L = x\<^sup>\<star> + x\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L"
  by (metis zero_right_mult_decreasing n_omega_L_star_zero_star add_relative_same_increasing)

lemma n_Omega_left_unfold: "1 + x ; x\<^sup>\<Omega> = x\<^sup>\<Omega>"
  by (smt Omega_def add_associative add_commutative mult_associative mult_left_dist_add n_omega_L_star star.circ_left_unfold)

lemma n_Omega_left_slide: "(x ; y)\<^sup>\<Omega> ; x \<le> x ; (y ; x)\<^sup>\<Omega>"
proof -
   have "(x ; y)\<^sup>\<Omega> ; x \<le> x ; y ; n((x ; y)\<^sup>\<omega>) ; L + (x ; y)\<^sup>\<star> ; x"
     by (smt Omega_def add_commutative add_left_isotone mult_associative mult_right_dist_add mult_right_isotone n_L_below_L n_omega_L_star)
   also have "... \<le> x ; (y ; 0 + n(y ; (x ; y)\<^sup>\<omega>) ; L) + (x ; y)\<^sup>\<star> ; x"
     by (smt add_associative add_commutative less_eq_def mult_associative mult_left_dist_add mult_left_sub_dist_add_left n_n_L_split_n_L star.circ_slide)
   also have "... = x ; (y ; x)\<^sup>\<Omega>"
     by (smt Omega_def add_associative add_commutative less_eq_def mult_associative mult_isotone mult_left_dist_add omega_slide star.circ_increasing star.circ_slide zero_least)
   finally show ?thesis
     by metis
qed

lemma n_Omega_add_1: "(x + y)\<^sup>\<Omega> = x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
proof -
  have 1: "(x + y)\<^sup>\<Omega> = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star>"
    by (smt Omega_def mult_right_dist_add n_dist_omega_star omega_decompose star.circ_add)
  have "n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L \<le> (x\<^sup>\<star> ; y)\<^sup>\<star> + x\<^sup>\<star> ; (y ; n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L)"
    by (metis n_omega_L_below mult_associative)
  also have "... \<le> (x\<^sup>\<star> ; y)\<^sup>\<star> + x\<^sup>\<star> ; y ; 0 + x\<^sup>\<star> ; n((y ; x\<^sup>\<star>)\<^sup>\<omega>) ; L"
    by (smt add_associative add_right_isotone mult_associative mult_left_dist_add mult_right_isotone n_n_L_split_n_L omega_slide)
  also have "... = (x\<^sup>\<star> ; y)\<^sup>\<star> + x\<^sup>\<star> ; n((y ; x\<^sup>\<star>)\<^sup>\<omega>) ; L"
    by (metis add_commutative less_eq_def star.circ_sub_dist_1 zero_right_mult_decreasing)
  also have "... \<le> x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> + x\<^sup>\<star> ; n((y ; x\<^sup>\<star>)\<^sup>\<omega>) ; L"
    by (metis add_left_isotone mult_right_isotone star.circ_increasing star.circ_isotone star_decompose_3)
  also have "... \<le> x\<^sup>\<star> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis Omega_def add_commutative mult_associative mult_left_dist_add mult_right_isotone n_Omega_isotone n_star_below_Omega)
  also have "... \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis n_star_below_Omega mult_left_isotone)
  finally have 2: "n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by metis
  have "n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L \<le> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> + x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> ; y ; n(x\<^sup>\<omega>) ; L"
    by (smt add_associative add_commutative mult_left_one mult_right_dist_add n_mult_omega_L_below star.circ_mult star.circ_slide)
  also have "... = n(x\<^sup>\<omega>) ; L ; (y ; x\<^sup>\<Omega>)\<^sup>\<star> + x\<^sup>\<star> ; (y ; x\<^sup>\<Omega>)\<^sup>\<star>"
    by (smt Omega_def add_associative mult_L_add_star mult_associative mult_left_dist_add L_mult_star)
  also have "... \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis mult_right_dist_add Omega_def n_star_below_Omega mult_right_isotone)
  finally have 3: "n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by metis
  have "(x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>"
    by (metis star_slide mult_isotone mult_right_isotone n_star_below_Omega order_trans star_isotone)
  hence 4: "(x + y)\<^sup>\<Omega> \<le> x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega>" using 1 2 3
    by (metis add_least_upper_bound)
  have 5: "x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega> \<le> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; n((y ; x\<^sup>\<Omega>)\<^sup>\<omega>) ; L + x\<^sup>\<star> ; (y ; x\<^sup>\<Omega>)\<^sup>\<star>"
    by (smt Omega_def add_associative add_left_isotone mult_associative mult_left_dist_add mult_right_dist_add mult_right_isotone n_L_below_L)
  have "n(x\<^sup>\<omega>) ; L \<le> n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L"
    by (metis add_commutative add_left_upper_bound mult_left_isotone n_isotone star.circ_loop_fixpoint)
  hence 6: "n(x\<^sup>\<omega>) ; L \<le> (x + y)\<^sup>\<Omega>" using 1
    by (metis Omega_def add_left_upper_bound n_Omega_isotone order_trans)
  have "x\<^sup>\<star> ; n((y ; x\<^sup>\<Omega>)\<^sup>\<omega>) ; L \<le> x\<^sup>\<star> ; n((y ; x\<^sup>\<star>)\<^sup>\<omega> + (y ; x\<^sup>\<star>)\<^sup>\<star> ; y ; n(x\<^sup>\<omega>) ; L) ; L"
    by (metis Omega_def mult_L_add_omega_below mult_associative mult_left_dist_add mult_left_isotone mult_right_isotone n_isotone)
  also have "... \<le> x\<^sup>\<star> ; 0 + n(x\<^sup>\<star> ; ((y ; x\<^sup>\<star>)\<^sup>\<omega> + (y ; x\<^sup>\<star>)\<^sup>\<star> ; y ; n(x\<^sup>\<omega>) ; L)) ; L"
    by (metis n_n_L_split_n_L)
  also have "... \<le> x\<^sup>\<star> + n((x\<^sup>\<star> ; y)\<^sup>\<omega> + x\<^sup>\<star> ; (y ; x\<^sup>\<star>)\<^sup>\<star> ; y ; n(x\<^sup>\<omega>) ; L) ; L"
    by (smt add_left_isotone mult_associative mult_left_dist_add omega_slide zero_right_mult_decreasing)
  also have "... \<le> x\<^sup>\<star> + n((x\<^sup>\<star> ; y)\<^sup>\<omega> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L) ; L"
    by (smt add_right_divisibility add_right_isotone mult_left_isotone n_isotone star.circ_mult)
  also have "... \<le> x\<^sup>\<star> + n((x + y)\<^sup>\<omega>) ; L"
    by (metis add_right_isotone mult_associative mult_left_isotone mult_right_isotone n_L_decreasing n_isotone omega_decompose)
  also have "... \<le> (x + y)\<^sup>\<Omega>"
    by (metis add_left_isotone star.circ_sub_dist Omega_def add_commutative)
  finally have 7: "x\<^sup>\<star> ; n((y ; x\<^sup>\<Omega>)\<^sup>\<omega>) ; L \<le> (x + y)\<^sup>\<Omega>"
    by metis
  have "x\<^sup>\<star> ; (y ; x\<^sup>\<Omega>)\<^sup>\<star> \<le> (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L"
    by (smt Omega_def add_right_isotone mult_L_add_star mult_associative mult_left_dist_add mult_left_isotone star.left_plus_below_circ star_slide)
  also have "... \<le> (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> + n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L"
    by (metis add_associative add_right_isotone add_right_zero mult_left_dist_add n_n_L_split_n_L)
  also have "... \<le> (x + y)\<^sup>\<Omega>"
    by (smt Omega_def add_commutative add_right_isotone mult_left_isotone n_right_upper_bound omega_decompose star.circ_add)
  finally have "n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; n((y ; x\<^sup>\<Omega>)\<^sup>\<omega>) ; L + x\<^sup>\<star> ; (y ; x\<^sup>\<Omega>)\<^sup>\<star> \<le> (x + y)\<^sup>\<Omega>" using 6 7
    by (metis add_least_upper_bound)
  hence "x\<^sup>\<Omega> ; (y ; x\<^sup>\<Omega>)\<^sup>\<Omega> \<le> (x + y)\<^sup>\<Omega>" using 5
    by (smt order_trans)
  thus ?thesis using 4
    by (metis antisym)
qed

end

sublocale n_omega_algebra < nL_omega!: left_zero_conway_semiring where circ = Omega
  apply unfold_locales
  apply (metis n_Omega_left_unfold)
  apply (metis n_Omega_left_slide)
  apply (metis n_Omega_add_1)
  done

(* circ_plus_same does not hold in the non-strict model using Omega *)

context n_omega_algebra

begin

-- {* AACP Theorem 8.16 *}

lemma omega_apx_isotone: "x \<sqsubseteq> y \<longrightarrow> x\<^sup>\<omega> \<sqsubseteq> y\<^sup>\<omega>"
proof
  assume "x \<sqsubseteq> y"
  hence 1: "x \<le> y + L \<and> C y \<le> x + n(x) ; T"
    by (metis apx_def)
  have "n(x) ; T + x ; (x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T) \<le> n(x) ; T + x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T"
    by (smt add_associative mult_associative mult_left_dist_add add_right_isotone n_n_top_split_n_top add_right_zero omega_unfold)
  also have "... \<le> x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T"
    by (metis add_commutative add_right_isotone mult_left_isotone n_below_n_omega add_associative add_idempotent)
  finally have 2: "x\<^sup>\<star> ; n(x) ; T \<le> x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T"
    by (metis mult_associative star_left_induct)
  have "C (y\<^sup>\<omega>) = (C y)\<^sup>\<omega>"
    by (metis C_omega_export)
  also have "... \<le> (x + n(x) ; T)\<^sup>\<omega>" using 1
    by (metis omega_isotone)
  also have "... = (x\<^sup>\<star> ; n(x) ; T)\<^sup>\<omega> + (x\<^sup>\<star> ; n(x) ; T)\<^sup>\<star> ; x\<^sup>\<omega>"
    by (metis mult_associative omega_decompose)
  also have "... \<le> x\<^sup>\<star> ; n(x) ; T + (x\<^sup>\<star> ; n(x) ; T)\<^sup>\<star> ; x\<^sup>\<omega>"
    by (metis add_left_isotone mult_top_omega)
  also have "... = x\<^sup>\<star> ; n(x) ; T + (1 + x\<^sup>\<star> ; n(x) ; T ; (x\<^sup>\<star> ; n(x) ; T)\<^sup>\<star>) ; x\<^sup>\<omega>"
    by (metis mult_associative star.circ_left_top star.mult_top_circ)
  also have "... \<le> x\<^sup>\<omega> + x\<^sup>\<star> ; n(x) ; T"
    by (smt add_isotone add_least_upper_bound mult_associative mult_left_one mult_right_dist_add mult_right_isotone order_refl top_greatest)
  also have "... \<le> x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T" using 2
    by (metis add_least_upper_bound add_left_upper_bound)
  finally have 3: "C (y\<^sup>\<omega>) \<le> x\<^sup>\<omega> + n(x\<^sup>\<omega>) ; T"
    by metis
  have "x\<^sup>\<omega> \<le> (y + L)\<^sup>\<omega>" using 1
    by (metis omega_isotone)
  also have "... = (y\<^sup>\<star> ; L)\<^sup>\<omega> + (y\<^sup>\<star> ; L)\<^sup>\<star> ; y\<^sup>\<omega>"
    by (metis omega_decompose)
  also have "... = y\<^sup>\<star> ; L ; (y\<^sup>\<star> ; L)\<^sup>\<omega> + (y\<^sup>\<star> ; L)\<^sup>\<star> ; y\<^sup>\<omega>"
    by (metis omega_unfold)
  also have "... \<le> y\<^sup>\<star> ; L + (y\<^sup>\<star> ; L)\<^sup>\<star> ; y\<^sup>\<omega>"
    by (metis add_left_isotone n_L_below_L mult_associative mult_right_isotone)
  also have "... = y\<^sup>\<star> ; L + (1 + y\<^sup>\<star> ; L ; (y\<^sup>\<star> ; L)\<^sup>\<star>) ; y\<^sup>\<omega>"
    by (metis star.circ_left_unfold)
  also have "... \<le> y\<^sup>\<star> ; L + y\<^sup>\<omega>"
    by (metis add_commutative add_least_upper_bound add_right_upper_bound mult_L_star_mult_below mult_associative star.circ_mult star.circ_slide)
  also have "... \<le> y\<^sup>\<star> ; 0 + L + y\<^sup>\<omega>"
    by (metis add_left_isotone n_L_split_L)
  finally have "x\<^sup>\<omega> \<le> y\<^sup>\<omega> + L"
    by (metis add_associative add_commutative less_eq_def star_zero_below_omega)
  thus "x\<^sup>\<omega> \<sqsubseteq> y\<^sup>\<omega>" using 3
    by (metis apx_def)
qed

lemma combined_apx_left_isotone: "x \<sqsubseteq> y \<longrightarrow> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; z \<sqsubseteq> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; z"
  by (metis add_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone n_L_apx_isotone)

lemma combined_apx_left_isotone_2: "x \<sqsubseteq> y \<longrightarrow> (x\<^sup>\<omega> \<frown> L) + x\<^sup>\<star> ; z \<sqsubseteq> (y\<^sup>\<omega> \<frown> L) + y\<^sup>\<star> ; z"
  by (metis add_apx_isotone mult_apx_left_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)

lemma combined_apx_right_isotone: "y \<sqsubseteq> z \<longrightarrow> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; y \<sqsubseteq> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; z"
  by (metis add_apx_right_isotone mult_apx_right_isotone)

lemma combined_apx_right_isotone_2: "y \<sqsubseteq> z \<longrightarrow> (x\<^sup>\<omega> \<frown> L) + x\<^sup>\<star> ; y \<sqsubseteq> (x\<^sup>\<omega> \<frown> L) + x\<^sup>\<star> ; z"
  by (metis add_apx_right_isotone mult_apx_right_isotone)

lemma combined_apx_isotone: "x \<sqsubseteq> y \<and> w \<sqsubseteq> z \<longrightarrow> n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; w \<sqsubseteq> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; z"
  by (metis add_apx_isotone mult_apx_isotone omega_apx_isotone star.circ_apx_isotone n_L_apx_isotone)

lemma combined_apx_isotone_2: "x \<sqsubseteq> y \<and> w \<sqsubseteq> z \<longrightarrow> (x\<^sup>\<omega> \<frown> L) + x\<^sup>\<star> ; w \<sqsubseteq> (y\<^sup>\<omega> \<frown> L) + y\<^sup>\<star> ; z"
  by (metis add_apx_isotone mult_apx_isotone omega_apx_isotone star.circ_apx_isotone meet_L_apx_isotone)

lemma n_split_nu_mu: "C (y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<le> y\<^sup>\<star> ; z + n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) ; T"
proof -
  have "C (y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<le> C (y\<^sup>\<omega>) + y\<^sup>\<star> ; z"
    by (metis add_right_isotone meet.add_right_upper_bound meet_left_dist_add)
  also have "... \<le> y\<^sup>\<star> ; 0 + n(y\<^sup>\<omega>) ; T + y\<^sup>\<star> ; z"
    by (metis add_commutative add_right_isotone n_split_omega_add_zero)
  also have "... \<le> y\<^sup>\<star> ; z + n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) ; T"
    by (smt add_associative add_commutative add_right_isotone add_right_zero mult_left_dist_add mult_left_isotone n_left_upper_bound)
  finally show ?thesis
    by metis
qed

lemma n_split_nu_mu_2: "C (y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<le> y\<^sup>\<star> ; z + ((y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<frown> L) + n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) ; T"
proof -
  have "C (y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<le> C (y\<^sup>\<omega>) + y\<^sup>\<star> ; z"
    by (metis add_right_isotone meet.add_right_upper_bound meet_left_dist_add)
  also have "... \<le> y\<^sup>\<star> ; 0 + n(y\<^sup>\<omega>) ; T + y\<^sup>\<star> ; z"
    by (metis add_commutative add_right_isotone n_split_omega_add_zero)
  also have "... \<le> y\<^sup>\<star> ; z + n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) ; T"
    by (smt add_associative add_commutative add_right_isotone add_right_zero mult_left_dist_add mult_left_isotone n_left_upper_bound)
  finally show ?thesis
    by (smt2 add_associative add_commutative meet_left_dist_add meet_commutative add_right_upper_bound order_trans)
qed

lemma loop_exists: "C (\<nu> (\<lambda>x . y ; x + z)) \<le> \<mu> (\<lambda>x . y ; x + z) + n(\<nu> (\<lambda>x . y ; x + z)) ; T"
  by (metis n_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_exists_2: "C (\<nu> (\<lambda>x . y ; x + z)) \<le> \<mu> (\<lambda>x . y ; x + z) + (\<nu> (\<lambda>x . y ; x + z) \<frown> L) + n(\<nu> (\<lambda>x . y ; x + z)) ; T"
  by (metis n_split_nu_mu_2 omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint: "apx.is_least_fixpoint (\<lambda>x . y ; x + z) (\<mu> (\<lambda>x . y ; x + z) + n(\<nu> (\<lambda>x . y ; x + z)) ; L)"
proof -
  have "kappa_mu_nu_L (\<lambda>x . y ; x + z)"
    by (metis affine_apx_isotone loop_exists affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone nu_below_mu_nu_L_def nu_below_mu_nu_L_kappa_mu_nu_L)
  thus ?thesis
    by (smt apx.least_fixpoint_char kappa_mu_nu_L_def)
qed

lemma loop_apx_least_fixpoint_2: "apx.is_least_fixpoint (\<lambda>x . y ; x + z) (\<mu> (\<lambda>x . y ; x + z) + (\<nu> (\<lambda>x . y ; x + z) \<frown> L))"
proof -
  have "kappa_mu_nu (\<lambda>x . y ; x + z)"
    by (metis affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone loop_exists_2 nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu)
  thus ?thesis
    by (smt apx.least_fixpoint_char kappa_mu_nu_def)
qed

lemma loop_has_apx_least_fixpoint: "apx.has_least_fixpoint (\<lambda>x . y ; x + z)"
  by (metis apx.has_least_fixpoint_def loop_apx_least_fixpoint_2)

lemma loop_semantics: "\<kappa> (\<lambda>x . y ; x + z) = \<mu> (\<lambda>x . y ; x + z) + n(\<nu> (\<lambda>x . y ; x + z)) ; L"
  by (metis apx.least_fixpoint_char loop_apx_least_fixpoint)

lemma loop_semantics_2: "\<kappa> (\<lambda>x . y ; x + z) = \<mu> (\<lambda>x . y ; x + z) + (\<nu> (\<lambda>x . y ; x + z) \<frown> L)"
  by (metis apx.least_fixpoint_char loop_apx_least_fixpoint_2)

-- {* AACP Theorem 8.15 *}

lemma loop_semantics_kappa_mu_nu: "\<kappa> (\<lambda>x . y ; x + z) = n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; z"
proof -
  have "\<kappa> (\<lambda>x . y ; x + z) = y\<^sup>\<star> ; z + n(y\<^sup>\<omega> + y\<^sup>\<star> ; z) ; L"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (smt n_dist_omega_star add_associative mult_right_dist_add add_commutative less_eq_def n_L_decreasing)
qed

-- {* AACP Theorem 8.15 *}

lemma loop_semantics_kappa_mu_nu_2: "\<kappa> (\<lambda>x . y ; x + z) = (y\<^sup>\<omega> \<frown> L) + y\<^sup>\<star> ; z"
proof -
  have "\<kappa> (\<lambda>x . y ; x + z) = y\<^sup>\<star> ; z + ((y\<^sup>\<omega> + y\<^sup>\<star> ; z) \<frown> L)"
    by (metis loop_semantics_2 omega_loop_nu star_loop_mu)
  thus ?thesis
    by (smt add_absorb add_associative add_commutative add_left_dist_meet)
qed

-- {* AACP Theorem 8.16 *}

lemma loop_semantics_apx_left_isotone: "w \<sqsubseteq> y \<longrightarrow> \<kappa> (\<lambda>x . w ; x + z) \<sqsubseteq> \<kappa> (\<lambda>x . y ; x + z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_left_isotone_2)

-- {* AACP Theorem 8.16 *}

lemma loop_semantics_apx_right_isotone: "w \<sqsubseteq> z \<longrightarrow> \<kappa> (\<lambda>x . y ; x + w) \<sqsubseteq> \<kappa> (\<lambda>x . y ; x + z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_right_isotone_2)

lemma loop_semantics_apx_isotone: "v \<sqsubseteq> y \<and> w \<sqsubseteq> z \<longrightarrow> \<kappa> (\<lambda>x . v ; x + w) \<sqsubseteq> \<kappa> (\<lambda>x . y ; x + z)"
  by (metis loop_semantics_kappa_mu_nu_2 combined_apx_isotone_2)

end

(*
end


theory NOmegaAlgebraBinaryItering

imports NOmegaAlgebra BinaryIteringStrict

begin
*)

sublocale extended_binary_itering < left_zero_conway_semiring where circ = "(\<lambda>x . x \<star> 1)"
  apply unfold_locales
  apply (metis while_left_unfold)
  apply (metis mult_right_one while_one_mult_below while_slide)
  apply (metis while_one_while while_sumstar_2)
  done

class binary_itering_apx = bounded_binary_itering + n_algebra_apx

begin

lemma C_while_import: "C (x \<star> z) = C (C x \<star> z)"
proof -
  have 1: "C x ; (x \<star> z) \<le> C x \<star> (C x ; z)"
    by (metis C_mult_propagate eq_refl while_simulate)
  have "C (x \<star> z) = C z + C x ; (x \<star> z)"
    by (metis meet_left_dist_add n_L_T_meet_mult while_left_unfold)
  also have "... \<le> C x \<star> z" using 1
    by (metis add_isotone meet.add_right_upper_bound while_right_unfold)
  finally have "C (x \<star> z) \<le> C (C x \<star> z)"
    by (metis meet.add_least_upper_bound meet.add_left_upper_bound)
  thus ?thesis
    by (smt2 meet.add_left_upper_bound meet.less_eq_def meet_associative meet_commutative while_left_isotone)
qed

lemma C_while_preserve: "C (x \<star> z) = C (x \<star> C z)"
proof -
  have "C x ; (x \<star> z) \<le> C x \<star> (C x ; z)"
    by (metis C_mult_propagate eq_refl while_simulate)
  also have "... \<le> x \<star> (x ; C z)"
    by (metis C_decreasing n_L_T_meet_mult_propagate while_isotone)
  finally have 1: "C x ; (x \<star> z) \<le> x \<star> (x ; C z)"
    by metis
  have "C (x \<star> z) = C z + C x ; (x \<star> z)"
    by (metis meet_left_dist_add n_L_T_meet_mult while_left_unfold)
  also have "... \<le> x \<star> C z" using 1
    by (metis add_least_upper_bound while_increasing while_mult_increasing while_mult_transitive)
  finally have "C (x \<star> z) \<le> C (x \<star> C z)"
    by (metis meet.add_least_upper_bound meet.add_left_upper_bound)
  thus ?thesis
    by (smt2 meet.add_left_upper_bound meet.less_eq_def meet_associative meet_commutative while_right_isotone)
qed

lemma C_while_import_preserve: "C (x \<star> z) = C (C x \<star> C z)"
  by (metis C_while_import C_while_preserve)

lemma while_L_L: "L \<star> L = L"
  by (metis n_L_top_L while_mult_star_exchange while_right_top)

lemma while_L_below_add: "L \<star> x \<le> x + L"
  by (metis while_left_unfold add_right_isotone n_L_below_L)

lemma while_L_split: "x \<star> L \<le> (x \<star> y) + L"
proof -
  have "x \<star> L \<le> (x \<star> 0) + L"
    by (metis add_commutative add_left_zero mult_right_one n_L_split_L while_right_unfold while_simulate_left_plus while_zero)
  thus ?thesis
    by (metis add_commutative add_right_isotone order_trans while_right_isotone zero_least)
qed

lemma while_n_while_top_split: "x \<star> (n(x \<star> y) ; T) \<le> (x \<star> 0) + n(x \<star> y) ; T"
proof -
  have "x ; n(x \<star> y) ; T \<le> x ; 0 + n(x ; (x \<star> y)) ; T"
    by (metis n_n_top_split_n_top)
  also have "... \<le> n(x \<star> y) ; T + x ; 0"
    by (metis add_commutative add_right_isotone mult_left_isotone n_isotone while_left_plus_below)
  finally have "x \<star> (n(x \<star> y) ; T) \<le> n(x \<star> y) ; T + (x \<star> (x ; 0))"
    by (metis mult_associative mult_right_one while_simulate_left mult_left_zero while_left_top)
  also have "... \<le> (x \<star> 0) + n(x \<star> y) ; T"
    by (metis add_least_upper_bound add_left_isotone while_right_plus_below)
  finally show ?thesis
    by metis
qed

lemma circ_apx_right_isotone: "x \<sqsubseteq> y \<longrightarrow> z \<star> x \<sqsubseteq> z \<star> y"
proof
  assume "x \<sqsubseteq> y"
  hence 1: "x \<le> y + L \<and> C y \<le> x + n(x) ; T"
    by (metis apx_def)
  hence "z \<star> x \<le> (z \<star> y) + (z \<star> L)"
    by (metis while_left_dist_add while_right_isotone)
  hence 2: "z \<star> x \<le> (z \<star> y) + L"
    by (smt add_least_upper_bound add_left_upper_bound while_L_split order_trans)
  have "z \<star> (n(z \<star> x) ; T) \<le> (z \<star> 0) + n(z \<star> x) ; T"
    by (metis while_n_while_top_split)
  also have "... \<le> (z \<star> x) + n(z \<star> x) ; T"
    by (metis add_left_isotone while_right_isotone zero_least)
  finally have 3: "z \<star> (n(x) ; T) \<le> (z \<star> x) + n(z \<star> x) ; T"
    by (metis mult_left_isotone n_isotone order_trans while_increasing while_right_isotone)
  have "C (z \<star> y) \<le> z \<star> C y"
    by (metis C_while_preserve meet.add_right_divisibility)
  also have "... \<le> (z \<star> x) + (z \<star> (n(x) ; T))" using 1
    by (metis while_left_dist_add while_right_isotone)
  also have "... \<le> (z \<star> x) + n(z \<star> x) ; T" using 3
    by (metis add_least_upper_bound add_left_upper_bound)
  finally show "z \<star> x \<sqsubseteq> z \<star> y" using 2
    by (metis apx_def)
qed

end

class extended_binary_itering_apx = binary_itering_apx + bounded_extended_binary_itering +
  assumes n_below_while_zero: "n(x) \<le> n(x \<star> 0)"

begin

lemma circ_apx_right_isotone: "x \<sqsubseteq> y \<longrightarrow> x \<star> z \<sqsubseteq> y \<star> z"
proof
  assume "x \<sqsubseteq> y"
  hence 1: "x \<le> y + L \<and> C y \<le> x + n(x) ; T"
    by (metis apx_def)
  hence "x \<star> z \<le> ((y \<star> 1) ; L) \<star> (y \<star> z)"
    by (metis while_left_isotone while_sumstar_3)
  also have "... \<le> (y \<star> z) + (y \<star> 1) ; L"
    by (metis while_productstar add_right_isotone mult_right_isotone n_L_below_L while_slide)
  also have "... \<le> (y \<star> z) + L"
    by (metis add_commutative add_least_upper_bound add_right_upper_bound order_trans while_L_split while_one_mult_below)
  finally have 2: "x \<star> z \<le> (y \<star> z) + L"
    by metis
  have "C (y \<star> z) \<le> C y \<star> z"
    by (metis C_while_import meet.add_right_divisibility)
  also have "... \<le> ((x \<star> 1) ; n(x) ; T) \<star> (x \<star> z)" using 1
    by (metis while_left_isotone mult_associative while_sumstar_3)
  also have "... \<le> (x \<star> z) + (x \<star> 1) ; n(x) ; T"
    by (metis while_productstar add_left_top add_right_isotone mult_associative mult_left_sub_dist_add_right while_slide)
  also have "... \<le> (x \<star> z) + (x \<star> (n(x) ; T))"
    by (metis add_right_isotone mult_associative while_one_mult_below)
  also have "... \<le> (x \<star> z) + (x \<star> (n(x \<star> z) ; T))"
    by (metis n_below_while_zero zero_least while_right_isotone n_isotone mult_left_isotone add_right_isotone order_trans)
  also have "... \<le> (x \<star> z) + n(x \<star> z) ; T"
    by (smt add_associative add_right_isotone while_n_while_top_split add_right_zero while_left_dist_add)
  finally show "x \<star> z \<sqsubseteq> y \<star> z" using 2
    by (metis apx_def)
qed

lemma while_top: "T \<star> x = L + T ; x" nitpick [expect=genuine] oops
lemma while_one_top: "1 \<star> x = L + x" nitpick [expect=genuine] oops
lemma while_unfold_below_1: "x = y ; x \<longrightarrow> x \<le> y \<star> 1" nitpick [expect=genuine] oops

lemma while_square_1: "x \<star> 1 = (x ; x) \<star> (x + 1)" oops
lemma while_absorb_below_one: "y ; x \<le> x \<longrightarrow> y \<star> x \<le> 1 \<star> x" oops
lemma while_mult_L: "(x ; L) \<star> z = z + x ; L" oops
lemma tarski_top_omega_below_2: "x ; L \<le> (x ; L) \<star> 0" oops
lemma tarski_top_omega_2: "x ; L = (x ; L) \<star> 0" oops
lemma while_separate_right_plus: "y ; x \<le> x ; (x \<star> (1 + y)) + 1 \<longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)" oops
lemma "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops
lemma "y ; x \<le> (1 + x) ; (y \<star> 1) \<longrightarrow> (x + y) \<star> 1 = x \<star> (y \<star> 1)" oops

end

class n_omega_algebra_binary = n_omega_algebra + while +
  assumes while_def: "x \<star> y = n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; y"

begin

lemma while_omega_meet_L_star: "x \<star> y = (x\<^sup>\<omega> \<frown> L) + x\<^sup>\<star> ; y"
  by (metis loop_semantics_kappa_mu_nu loop_semantics_kappa_mu_nu_2 while_def)

lemma while_one_mult_while_below_1: "(y \<star> 1) ; (y \<star> v) \<le> y \<star> v"
proof -
  have "(y \<star> 1) ; (y \<star> v) \<le> y \<star> (y \<star> v)"
    by (smt add_left_isotone mult_associative mult_right_dist_add mult_right_isotone n_L_below_L while_def mult_left_one)
  also have "... = n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; y\<^sup>\<star> ; v"
    by (metis while_def mult_left_dist_add add_associative mult_associative)
  also have "... = n(y\<^sup>\<omega>) ; L + n(y\<^sup>\<star> ; y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; y\<^sup>\<star> ; v"
    by (smt n_mult_omega_L_star_zero add_relative_same_increasing add_associative add_left_zero mult_left_sub_dist_add_left add_commutative)
  finally show ?thesis
    by (metis add_idempotent star.circ_transitive_equal star_mult_omega while_def)
qed

lemma star_below_while: "x\<^sup>\<star> ; y \<le> x \<star> y"
  by (metis add_right_upper_bound while_def)

subclass bounded_binary_itering
proof unfold_locales
  fix x y z
  have "z + x ; ((y ; x) \<star> (y ; z)) = x ; (y ; x)\<^sup>\<star> ; y ; z + x ; n((y ; x)\<^sup>\<omega>) ; L + z"
    by (smt add_associative add_commutative mult_associative mult_left_dist_add while_def)
  also have "... = x ; (y ; x)\<^sup>\<star> ; y ; z + n(x ; (y ; x)\<^sup>\<omega>) ; L + z"
    by (metis mult_associative mult_right_isotone zero_least n_mult_omega_L_star_zero add_relative_same_increasing)
  also have "... = (x ; y)\<^sup>\<star> ; z + n(x ; (y ; x)\<^sup>\<omega>) ; L"
    by (smt add_associative add_commutative mult_associative star.circ_loop_fixpoint star_slide)
  also have "... = (x ; y) \<star> z"
    by (smt omega_slide while_def add_commutative)
  finally show "(x ; y) \<star> z = z + x ; ((y ; x) \<star> (y ; z))"
    by metis
next
  fix x y z
  have "(x \<star> y) \<star> (x \<star> z) = n((n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + (n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z)"
    by (metis while_def)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L) ; L + ((x\<^sup>\<star> ; y)\<^sup>\<star> + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L) ; (x \<star> z)"
    by (metis mult_L_add_star mult_L_add_omega)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + n((x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z) + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L ; (x \<star> z)"
    by (metis mult_associative n_dist_omega_star mult_right_dist_add add_associative)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + n((x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; 0 + (x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z) + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L ; (x \<star> z)"
    by (smt add_associative add_left_zero mult_left_dist_add)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + ((x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L ; (x \<star> z) + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z))"
    by (smt n_n_L_split_n_n_L_L add_commutative add_associative)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + ((x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z))"
    by (smt mult_L_omega omega_sub_vector less_eq_def)
  also have "... = n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L + (x\<^sup>\<star> ; y)\<^sup>\<star> ; (x \<star> z)"
    by (metis add_left_divisibility mult_associative mult_right_isotone while_def less_eq_def)
  also have "... = (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> ; z + (x\<^sup>\<star> ; y)\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L + n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L"
    by (metis add_commutative mult_associative mult_left_dist_add while_def)
  also have "... = (x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<star> ; z + n((x\<^sup>\<star> ; y)\<^sup>\<star> ; x\<^sup>\<omega>) ; L + n((x\<^sup>\<star> ; y)\<^sup>\<omega>) ; L"
    by (metis add_right_zero mult_left_dist_add add_associative n_mult_omega_L_star_zero)
  also have "... = (x + y) \<star> z"
    by (metis add_associative add_commutative omega_decompose star.circ_add while_def mult_right_dist_add n_dist_omega_star)
  finally show "(x + y) \<star> z = (x \<star> y) \<star> (x \<star> z)"
    by metis
next
  fix x y z
  show "x \<star> (y + z) = (x \<star> y) + (x \<star> z)"
    by (smt add_associative add_commutative add_left_upper_bound less_eq_def mult_left_dist_add while_def)
next
  fix x y z
  show "(x \<star> y) ; z \<le> x \<star> (y ; z)"
    by (smt add_left_isotone mult_associative mult_right_dist_add mult_right_isotone n_L_below_L while_def)
next
  fix v w x y z
  show "x ; z \<le> z ; (y \<star> 1) + w \<longrightarrow> x \<star> (z ; v) \<le> z ; (y \<star> v) + (x \<star> (w ; (y \<star> v)))"
  proof
    assume 1: "x ; z \<le> z ; (y \<star> 1) + w"
    have "z ; v + x ; (z ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))) \<le> z ; v + x ; z ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))"
      by (metis add_associative add_right_isotone mult_associative mult_left_dist_add mult_left_isotone star.left_plus_below_circ)
    also have "... \<le> z ; v + z ; (y \<star> 1) ; (y \<star> v) + w ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))" using 1
      by (metis add_associative add_left_isotone add_right_isotone mult_left_isotone mult_right_dist_add)
    also have "... \<le> z ; v + z ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))"
      by (smt add_least_upper_bound add_right_upper_bound less_eq_def mult_associative mult_left_dist_add star.circ_loop_fixpoint while_one_mult_while_below_1)
    also have "... = z ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))"
      by (metis less_eq_def mult_left_dist_add mult_left_one mult_right_sub_dist_add_left order_trans star.circ_plus_one star_below_while)
    finally have "x\<^sup>\<star> ; z ; v \<le> z ; (y \<star> v) + x\<^sup>\<star> ; (w ; (y \<star> v))"
      by (metis mult_associative star_left_induct)
    thus "x \<star> (z ; v) \<le> z ; (y \<star> v) + (x \<star> (w ; (y \<star> v)))"
      by (smt add_associative add_commutative add_right_isotone mult_associative while_def)
  qed
next
  fix v w x y z
  show "z ; x \<le> y ; (y \<star> z) + w \<longrightarrow> z ; (x \<star> v) \<le> y \<star> (z ; v + w ; (x \<star> v))"
  proof
    assume "z ; x \<le> y ; (y \<star> z) + w"
    hence 1: "z ; x \<le> y ; y\<^sup>\<star> ; z + (y ; n(y\<^sup>\<omega>) ; L + w)"
      by (smt add_associative add_commutative mult_associative mult_left_dist_add while_def)
    hence "z ; x\<^sup>\<star> \<le> y\<^sup>\<star> ; (z + (y ; n(y\<^sup>\<omega>) ; L + w) ; x\<^sup>\<star>)"
      by (metis star.circ_simulate_right_plus)
    also have "... = y\<^sup>\<star> ; z + y\<^sup>\<star> ; y ; n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
      by (smt add_associative mult_associative mult_left_dist_add mult_right_dist_add L_mult_star)
    also have "... = y\<^sup>\<star> ; z + n(y\<^sup>\<star> ; y ; y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
      by (metis add_relative_same_increasing mult_isotone n_mult_omega_L_star_zero star.left_plus_below_circ star.right_plus_circ zero_least)
    also have "... = n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; z + y\<^sup>\<star> ; w ; x\<^sup>\<star>"
      by (metis add_commutative omega_unfold right_plus_omega)
    finally have "z ; x\<^sup>\<star> ; v \<le> n(y\<^sup>\<omega>) ; L ; v + y\<^sup>\<star> ; z ; v + y\<^sup>\<star> ; w ; x\<^sup>\<star> ; v"
      by (smt less_eq_def mult_right_dist_add)
    also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; (z ; v + w ; x\<^sup>\<star> ; v)"
      by (metis n_L_below_L mult_associative mult_right_isotone add_left_isotone mult_left_dist_add add_associative)
    also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; (z ; v + w ; (x \<star> v))"
      by (metis add_commutative add_right_isotone mult_associative mult_left_sub_dist_add_left mult_right_isotone while_def)
    finally have 2: "z ; x\<^sup>\<star> ; v \<le> y \<star> (z ; v + w ; (x \<star> v))"
      by (metis while_def)
    have 3: "y\<^sup>\<star> ; y ; y\<^sup>\<star> ; 0 \<le> y\<^sup>\<star> ; w ; x\<^sup>\<omega>"
      by (metis add_commutative add_left_zero mult_associative mult_left_sub_dist_add_left star.circ_loop_fixpoint star.circ_transitive_equal)
    have "z ; x\<^sup>\<omega> \<le> y ; y\<^sup>\<star> ; z ; x\<^sup>\<omega> + (y ; n(y\<^sup>\<omega>) ; L + w) ; x\<^sup>\<omega>" using 1
      by (metis mult_associative mult_left_isotone mult_right_dist_add omega_unfold)
    hence "z ; x\<^sup>\<omega> \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; y ; n(y\<^sup>\<omega>) ; L ; x\<^sup>\<omega> + y\<^sup>\<star> ; w ; x\<^sup>\<omega>"
      by (smt add_associative add_commutative left_plus_omega mult_associative mult_left_dist_add mult_right_dist_add omega_induct star.left_plus_circ)
    also have "... \<le> y\<^sup>\<omega> + y\<^sup>\<star> ; y ; n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; w ; x\<^sup>\<omega>"
      by (metis add_left_isotone add_right_isotone mult_associative mult_right_isotone n_L_below_L)
    also have "... = y\<^sup>\<omega> + n(y\<^sup>\<star> ; y ; y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; w ; x\<^sup>\<omega>" using 3
      by (smt add_associative add_commutative add_relative_same_increasing n_mult_omega_L_star_zero)
    also have "... = y\<^sup>\<omega> + y\<^sup>\<star> ; w ; x\<^sup>\<omega>"
      by (metis mult_associative omega_unfold star_mult_omega add_commutative less_eq_def n_L_decreasing)
    finally have "n(z ; x\<^sup>\<omega>) ; L \<le> n(y\<^sup>\<omega>) ; L + n(y\<^sup>\<star> ; w ; x\<^sup>\<omega>) ; L"
      by (metis mult_associative mult_left_isotone mult_right_dist_add n_dist_omega_star n_isotone)
    also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; (w ; (n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; 0))"
      by (smt add_commutative add_right_isotone mult_associative mult_left_dist_add n_mult_omega_L_below_zero)
    also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; (w ; (n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; v))"
      by (metis add_right_isotone mult_right_isotone zero_least)
    also have "... \<le> n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; (z ; v + w ; (n(x\<^sup>\<omega>) ; L + x\<^sup>\<star> ; v))"
      by (metis add_right_isotone mult_left_sub_dist_add_right)
    finally have 4: "n(z ; x\<^sup>\<omega>) ; L \<le> y \<star> (z ; v + w ; (x \<star> v))"
      by (metis while_def)
    have "z ; (x \<star> v) = z ; n(x\<^sup>\<omega>) ; L + z ; x\<^sup>\<star> ; v"
      by (metis while_def mult_left_dist_add mult_associative)
    also have "... = n(z ; x\<^sup>\<omega>) ; L + z ; x\<^sup>\<star> ; v"
      by (metis add_commutative add_relative_same_increasing mult_right_isotone n_mult_omega_L_star_zero zero_least)
    finally show "z ; (x \<star> v) \<le> y \<star> (z ; v + w ; (x \<star> v))" using 2 4
      by (metis add_least_upper_bound)
  qed
qed

lemma while_top: "T \<star> x = L + T ; x"
  by (metis n_top_L star.circ_top star_omega_top while_def)

lemma while_one_top: "1 \<star> x = L + x"
  by (smt mult_left_one n_top_L omega_one star_one while_def)

lemma while_finite_associative: "x\<^sup>\<omega> = 0 \<longrightarrow> (x \<star> y) ; z = x \<star> (y ; z)"
  by (metis add_left_zero mult_associative n_zero_L_zero while_def)

lemma while_while_one: "y \<star> (x \<star> 1) = n(y\<^sup>\<omega>) ; L + y\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L + y\<^sup>\<star> ; x\<^sup>\<star>"
  by (metis add_associative mult_left_dist_add mult_right_one while_def mult_associative)

-- {* AACP Theorem 8.17 *}

subclass bounded_extended_binary_itering
proof unfold_locales
  fix w x y z
  have "w ; (x \<star> y ; z) = n(w ; n(x\<^sup>\<omega>) ; L) ; L + w ; x\<^sup>\<star> ; y ; z"
    by (smt add_associative add_commutative add_left_zero mult_associative mult_left_dist_add n_n_L_split_n_n_L_L while_def)
  also have "... \<le> n((w ; n(x\<^sup>\<omega>) ; L)\<^sup>\<omega>) ; L + w ; x\<^sup>\<star> ; y ; z"
    by (metis eq_refl mult_L_omega)
  also have "... \<le> n((w ; (x \<star> y))\<^sup>\<omega>) ; L + w ; x\<^sup>\<star> ; y ; z"
    by (smt add_left_isotone add_left_upper_bound mult_associative mult_left_isotone mult_right_isotone n_isotone omega_isotone while_def)
  also have "... \<le> n((w ; (x \<star> y))\<^sup>\<omega>) ; L + w ; (x \<star> y) ; z"
    by (metis star_below_while mult_associative mult_left_isotone mult_right_isotone add_right_isotone)
  also have "... \<le> n((w ; (x \<star> y))\<^sup>\<omega>) ; L + (w ; (x \<star> y))\<^sup>\<star> ; (w ; (x \<star> y) ; z)"
    by (metis add_right_isotone add_right_upper_bound star.circ_loop_fixpoint)
  finally show "w ; (x \<star> y ; z) \<le> (w ; (x \<star> y)) \<star> (w ; (x \<star> y) ; z)"
    by (metis while_def)
qed

subclass extended_binary_itering_apx
  apply unfold_locales
  apply (metis n_below_n_omega n_left_upper_bound n_n_L order_trans while_def)
  done

lemma while_simulate_4_plus: "y ; x \<le> x ; (x \<star> (1 + y)) \<longrightarrow> y ; x ; x\<^sup>\<star> \<le> x ; (x \<star> (1 + y))"
proof
  assume 1: "y ; x \<le> x ; (x \<star> (1 + y))"
  have "x ; (x \<star> (1 + y)) = x ; n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; (1 + y)"
    by (metis mult_associative mult_left_dist_add while_def)
  also have "... = n(x ; x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; (1 + y)"
    by (smt n_mult_omega_L_star_zero add_relative_same_increasing add_commutative add_right_zero mult_left_sub_dist_add_right)
  finally have 2: "x ; (x \<star> (1 + y)) = n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y"
    by (metis add_associative mult_left_dist_add mult_right_one omega_unfold)
  hence "x ; x\<^sup>\<star> ; y ; x \<le> x ; x\<^sup>\<star> ; n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; x\<^sup>\<star> ; x + x ; x\<^sup>\<star> ; x ; x\<^sup>\<star> ; y" using 1
    by (metis mult_associative mult_right_isotone mult_left_dist_add star_plus)
  also have "... = n(x ; x\<^sup>\<star> ; x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; x\<^sup>\<star> ; x + x ; x\<^sup>\<star> ; x ; x\<^sup>\<star> ; y"
    by (smt n_mult_omega_L_star_zero add_relative_same_increasing add_commutative add_right_zero mult_left_sub_dist_add_right)
  also have "... = n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; x + x ; x ; x\<^sup>\<star> ; y"
    by (metis mult_associative omega_unfold star.circ_plus_same star.circ_transitive_equal star_mult_omega)
  also have "... \<le> n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y"
    by (smt add_associative add_right_upper_bound less_eq_def mult_associative mult_right_dist_add star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have 3: "x ; x\<^sup>\<star> ; y ; x \<le> n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y"
    by metis
  have "(n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y) ; x \<le> n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; x + x ; x\<^sup>\<star> ; y ; x"
    by (metis mult_right_dist_add n_L_below_L mult_associative mult_right_isotone add_left_isotone)
  also have "... \<le> n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y ; x"
    by (smt add_commutative add_left_isotone mult_associative mult_right_isotone star.left_plus_below_circ star_plus)
  also have "... \<le> n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y" using 3
    by (metis add_least_upper_bound add_left_upper_bound)
  finally show "y ; x ; x\<^sup>\<star> \<le> x ; (x \<star> (1 + y))" using 1 2
    by (metis add_least_upper_bound star_right_induct)
qed

lemma while_simulate_4_omega: "y ; x \<le> x ; (x \<star> (1 + y)) \<longrightarrow> y ; x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
proof
  assume 1: "y ; x \<le> x ; (x \<star> (1 + y))"
  have "x ; (x \<star> (1 + y)) = x ; n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; (1 + y)"
    by (metis mult_associative mult_left_dist_add while_def)
  also have "... = n(x ; x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> ; (1 + y)"
    by (smt n_mult_omega_L_star_zero add_relative_same_increasing add_commutative add_right_zero mult_left_sub_dist_add_right)
  finally have "x ; (x \<star> (1 + y)) = n(x\<^sup>\<omega>) ; L + x ; x\<^sup>\<star> + x ; x\<^sup>\<star> ; y"
    by (metis add_associative mult_left_dist_add mult_right_one omega_unfold)
  hence "y ; x\<^sup>\<omega> \<le> n(x\<^sup>\<omega>) ; L ; x\<^sup>\<omega> + x ; x\<^sup>\<star> ; x\<^sup>\<omega> + x ; x\<^sup>\<star> ; y ; x\<^sup>\<omega>" using 1
    by (smt less_eq_def mult_associative mult_right_dist_add omega_unfold)
  also have "... \<le> x ; x\<^sup>\<star> ; (y ; x\<^sup>\<omega>) + x\<^sup>\<omega>"
    by (metis add_left_isotone mult_L_omega omega_sub_vector mult_associative omega_unfold star_mult_omega n_L_decreasing less_eq_def add_commutative)
  finally have "y ; x\<^sup>\<omega> \<le> (x ; x\<^sup>\<star>)\<^sup>\<omega> + (x ; x\<^sup>\<star>)\<^sup>\<star> ; x\<^sup>\<omega>"
    by (metis add_commutative omega_induct)
  thus "y ; x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis add_idempotent left_plus_omega star_mult_omega)
qed

lemma while_square_1: "x \<star> 1 = (x ; x) \<star> (x + 1)"
  by (metis mult_right_one omega_square star_square_2 while_def)

lemma while_absorb_below_one: "y ; x \<le> x \<longrightarrow> y \<star> x \<le> 1 \<star> x"
  by (metis star_left_induct_mult add_isotone n_galois n_sub_nL while_def while_one_top)

lemma while_mult_L: "(x ; L) \<star> z = z + x ; L"
  by (metis add_right_zero mult_left_zero while_denest_5 while_one_top while_productstar while_sumstar)

lemma tarski_top_omega_below_2: "x ; L \<le> (x ; L) \<star> 0"
  by (metis add_right_divisibility while_mult_L)

lemma tarski_top_omega_2: "x ; L = (x ; L) \<star> 0"
  by (metis add_left_zero while_mult_L)

lemma while_sub_mult_one: "x ; (1 \<star> y) \<le> 1 \<star> x" nitpick [expect=genuine] oops
lemma while_unfold_below: "x = z + y ; x \<longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine] oops
lemma while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y ; x + z) (y \<star> z)" nitpick [expect=genuine] oops
lemma while_denest_3: "(x \<star> w) \<star> x\<^sup>\<omega> = (x \<star> w)\<^sup>\<omega>" nitpick [expect=genuine] oops
lemma while_mult_top: "(x ; T) \<star> z = z + x ; T" nitpick [expect=genuine] oops
lemma tarski_below_top_omega: "x \<le> (x ; L)\<^sup>\<omega>" nitpick [expect=genuine] oops
lemma tarski_mult_omega_omega: "(x ; y\<^sup>\<omega>)\<^sup>\<omega> = x ; y\<^sup>\<omega>" nitpick [expect=genuine] oops
lemma tarski_below_top_omega_2: "x \<le> (x ; L) \<star> 0" nitpick [expect=genuine] oops
lemma "1 = (x ; 0) \<star> 1" nitpick [expect=genuine] oops
lemma tarski: "x = 0 \<or> T ; x ; T = T" nitpick [expect=genuine] oops
lemma "(x + y) \<star> z = ((x \<star> 1) ; y) \<star> ((x \<star> 1) ; z)" nitpick [expect=genuine] oops
lemma while_top_2: "T \<star> z = T ; z" nitpick [expect=genuine] oops
lemma while_mult_top_2: "(x ; T) \<star> z = z + x ; T ; z" nitpick [expect=genuine] oops
lemma while_one_mult: "(x \<star> 1) ; x = x \<star> x" nitpick [expect=genuine] oops
lemma "(x \<star> 1) ; y = x \<star> y" nitpick [expect=genuine] oops
lemma while_associative: "(x \<star> y) ; z = x \<star> (y ; z)" nitpick [expect=genuine] oops
lemma while_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x ; y + z) (z ; (y \<star> 1))" nitpick [expect=genuine] oops
lemma "1 + x ; 0 = x \<star> 1" nitpick [expect=genuine] oops
lemma "x = x ; (x \<star> 1)" nitpick [expect=genuine] oops
lemma "x ; (x \<star> 1) = x \<star> 1" nitpick [expect=genuine] oops
lemma "x \<star> 1 = x \<star> (1 \<star> 1)" nitpick [expect=genuine] oops
lemma "(x + y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" nitpick [expect=genuine] oops
lemma "z + y ; x = x \<longrightarrow> y \<star> z \<le> x" nitpick [expect=genuine] oops
lemma "y ; x = x \<longrightarrow> y \<star> x \<le> x" nitpick [expect=genuine] oops
lemma "z + x ; y = x \<longrightarrow> z ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; y = x \<longrightarrow> x ; (y \<star> 1) \<le> x" nitpick [expect=genuine] oops
lemma "x ; z = z ; y \<longrightarrow> x \<star> z \<le> z ; (y \<star> 1)" nitpick [expect=genuine] oops

lemma while_unfold_below_1: "x = y ; x \<longrightarrow> x \<le> y \<star> 1" nitpick [expect=genuine] oops
lemma "x\<^sup>\<omega> \<le> x\<^sup>\<omega> ; x\<^sup>\<omega>" oops
lemma tarski_omega_idempotent: "x\<^sup>\<omega>\<^sup>\<omega> = x\<^sup>\<omega>" oops

end

class n_omega_algebra_binary_strict = n_omega_algebra_binary + circ +
  assumes L_left_zero: "L ; x = L"
  assumes circ_def: "x\<^sup>\<circ> = n(x\<^sup>\<omega>) ; L + x\<^sup>\<star>"

begin

subclass strict_binary_itering
  apply unfold_locales
  apply (metis while_def mult_associative L_left_zero mult_right_dist_add)
  apply (metis circ_def while_def mult_right_one)
  done

end

(*
end


theory CappedOmega

imports OmegaAlgebra

begin
*)

class capped_omega =
  fixes capped_omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_\<^sup>\<omega>\<^sub>_" [100,100] 100)

class capped_omega_algebra = bounded_left_zero_kleene_algebra + bounded_distributive_lattice + capped_omega +
  assumes capped_omega_unfold: "y\<^sup>\<omega>\<^sub>v = y ; y\<^sup>\<omega>\<^sub>v \<frown> v"
  assumes capped_omega_induct: "x \<le> (y ; x + z) \<frown> v \<longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"

-- {* AACP Theorem 6.1 *}

sublocale capped_omega_algebra < capped!: bounded_left_zero_omega_algebra where omega = "(\<lambda>y . y\<^sup>\<omega>\<^sub>T)"
  apply unfold_locales
  apply (metis capped_omega_unfold meet.add_right_zero)
  apply (metis add_commutative capped_omega_induct meet.add_right_zero)
  done

context capped_omega_algebra

begin

-- {* AACP Theorem 6.2 *}

lemma capped_omega_below_omega: "y\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>T"
  by (metis capped.omega_induct_mult capped_omega_unfold meet.add_left_upper_bound)

-- {* AACP Theorem 6.3 *}

lemma capped_omega_below: "y\<^sup>\<omega>\<^sub>v \<le> v"
  by (metis capped_omega_unfold meet.add_left_divisibility meet_commutative)

-- {* AACP Theorem 6.4 *}

lemma capped_omega_one: "1\<^sup>\<omega>\<^sub>v = v"
proof -
  have "v \<le> (1 ; v + 0) \<frown> v"
    by (metis add_right_zero meet_idempotent mult_left_one order.refl)
  hence "v \<le> 1\<^sup>\<omega>\<^sub>v + 1\<^sup>\<star> ; 0"
    by (metis capped_omega_induct)
  also have "... = 1\<^sup>\<omega>\<^sub>v"
    by (metis add_right_zero mult_left_one star_one)
  finally show ?thesis
    by (metis capped_omega_below antisym)
qed

-- {* AACP Theorem 6.5 *}

lemma capped_omega_zero: "0\<^sup>\<omega>\<^sub>v = 0"
  by (metis capped_omega_unfold meet_commutative meet_right_zero mult_left_zero)

lemma star_below_cap: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> y\<^sup>\<star> ; z \<le> v"
  by (metis add_least_upper_bound dual_order.trans mult_left_isotone star_left_induct)

lemma capped_fix: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> (y ; (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z) + z) \<frown> v = y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"
proof
  assume 1: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v"
  have "(y ; (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z) + z) \<frown> v = (y ; y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z) \<frown> v"
    by (metis add_associative mult_left_dist_add star.circ_loop_fixpoint)
  also have "... = (y ; y\<^sup>\<omega>\<^sub>v \<frown> v) + (y\<^sup>\<star> ; z \<frown> v)"
    by (metis meet_commutative meet_left_dist_add)
  also have "... = y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z" using 1
    by (metis capped_omega_unfold meet_less_eq_def star_below_cap)
  finally show "(y ; (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z) + z) \<frown> v = y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"
    .
qed

lemma capped_fixpoint: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> is_fixpoint (\<lambda>x . (y ; x + z) \<frown> v) (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z)"
  by (metis capped_fix meet.is_fixpoint_def)

lemma capped_greatest_fixpoint: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> is_greatest_fixpoint (\<lambda>x . (y ; x + z) \<frown> v) (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z)"
  by (smt2 capped_fix order_refl capped_omega_induct is_greatest_fixpoint_def)

lemma capped_postfixpoint: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> is_postfixpoint (\<lambda>x . (y ; x + z) \<frown> v) (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z)"
  by (metis capped_fix eq_refl is_postfixpoint_def)

lemma capped_greatest_postfixpoint: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> is_greatest_postfixpoint (\<lambda>x . (y ; x + z) \<frown> v) (y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z)"
  by (smt2 capped_fix order_refl capped_omega_induct is_greatest_postfixpoint_def)

-- {* AACP Theorem 6.6 *}

lemma capped_nu: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> \<nu>(\<lambda>x . (y ; x + z) \<frown> v) = y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"
  by (metis capped_greatest_fixpoint greatest_fixpoint_same)

lemma capped_pnu: "y \<le> u \<and> z \<le> v \<and> u ; v \<le> v \<longrightarrow> p\<nu>(\<lambda>x . (y ; x + z) \<frown> v) = y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"
  by (metis capped_greatest_postfixpoint greatest_postfixpoint_same)

-- {* AACP Theorem 6.7 *}

lemma unfold_capped_omega: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> y ; y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_below meet.order_trans mult_isotone capped_omega_unfold meet_less_eq_def)

-- {* AACP Theorem 6.8 *}

lemma star_mult_capped_omega: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> y\<^sup>\<star> ; y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
proof
  assume "y \<le> u \<and> u ; v \<le> v"
  hence "y ; y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
    by (metis unfold_capped_omega)
  hence "y\<^sup>\<star> ; y\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
    by (metis star_left_induct_mult_equal)
  thus "y\<^sup>\<star> ; y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
    by (metis add_right_upper_bound antisym_conv star.circ_loop_fixpoint)
qed

-- {* AACP Theorem 6.9 *}

lemma star_zero_below_capped_omega_zero: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> y\<^sup>\<star> ; 0 \<le> y\<^sup>\<omega>\<^sub>v ; 0"
proof
  assume "y \<le> u \<and> u ; v \<le> v"
  hence "y ; y\<^sup>\<omega>\<^sub>v \<le> v"
    by (metis capped_omega_below meet.order_trans mult_isotone)
  hence "y ; y\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
    by (metis capped_omega_unfold meet_less_eq_def)
  thus "y\<^sup>\<star> ; 0 \<le> y\<^sup>\<omega>\<^sub>v ; 0"
    by (metis add_commutative add_left_zero mult_associative star_loop_least_fixpoint)
qed

lemma star_zero_below_capped_omega: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> y\<^sup>\<star> ; 0 \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis order.trans zero_right_mult_decreasing star_zero_below_capped_omega_zero)

lemma capped_omega_induct_meet_zero: "x \<le> y ; x \<frown> v \<longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; 0"
  by (metis add_commutative add_left_zero capped_omega_induct)

-- {* AACP Theorem 6.10 *}

lemma capped_omega_induct_meet: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> x \<le> y ; x \<frown> v \<longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_induct_meet_zero add_commutative less_eq_def star_zero_below_capped_omega)

lemma capped_omega_induct_equal: "x = (y ; x + z) \<frown> v \<longrightarrow> x \<le> y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; z"
  by (metis capped_omega_induct order_refl)

-- {* AACP Theorem 6.11 *}

lemma capped_meet_nu: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> \<nu>(\<lambda>x . y ; x \<frown> v) = y\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "y \<le> u \<and> u ; v \<le> v"
  hence "y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; 0 = y\<^sup>\<omega>\<^sub>v"
    by (smt star_zero_below_capped_omega less_eq_def add_commutative)
  hence "\<nu>(\<lambda>x . (y ; x + 0) \<frown> v) = y\<^sup>\<omega>\<^sub>v" using 1
    by (metis capped_nu zero_least)
  thus "\<nu>(\<lambda>x . y ; x \<frown> v) = y\<^sup>\<omega>\<^sub>v"
    by (simp add: add_right_zero)
qed

lemma capped_meet_pnu: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> p\<nu>(\<lambda>x . y ; x \<frown> v) = y\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "y \<le> u \<and> u ; v \<le> v"
  hence "y\<^sup>\<omega>\<^sub>v + y\<^sup>\<star> ; 0 = y\<^sup>\<omega>\<^sub>v"
    by (smt star_zero_below_capped_omega less_eq_def add_commutative)
  hence "p\<nu>(\<lambda>x . (y ; x + 0) \<frown> v) = y\<^sup>\<omega>\<^sub>v" using 1
    by (metis capped_pnu zero_least)
  thus "p\<nu>(\<lambda>x . y ; x \<frown> v) = y\<^sup>\<omega>\<^sub>v"
    by (simp add: add_right_zero)
qed

-- {* AACP Theorem 6.12 *}

lemma capped_omega_isotone: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> t \<le> y \<longrightarrow> t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_induct_meet capped_omega_unfold less_eq_def meet.add_left_isotone mult_right_sub_dist_add_left)

-- {* AACP Theorem 6.13 *}

lemma capped_omega_simulation: "y \<le> u \<and> s \<le> u \<and> u ; v \<le> v \<longrightarrow> s ; t \<le> y ; s \<longrightarrow> s ; t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "y \<le> u \<and> s \<le> u \<and> u ; v \<le> v"
  show "s ; t \<le> y ; s \<longrightarrow> s ; t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
  proof
    assume 2: "s ; t \<le> y ; s"
    have "s ; t\<^sup>\<omega>\<^sub>v \<le> s ; t ; t\<^sup>\<omega>\<^sub>v \<frown> s ; v"
      by (metis capped_omega_unfold meet.add_least_upper_bound meet.add_right_upper_bound meet_commutative mult_associative mult_right_isotone)
    also have "... \<le> s ; t ; t\<^sup>\<omega>\<^sub>v \<frown> v" using 1
      by (metis meet.add_left_isotone meet_commutative mult_left_isotone order_trans)
    also have "... \<le> y ; s ; t\<^sup>\<omega>\<^sub>v \<frown> v" using 2
      by (metis meet.add_left_isotone mult_left_isotone)
    finally show "s ; t\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v" using 1
      by (metis capped_omega_induct_meet mult_associative)
  qed
qed

lemma capped_omega_slide_sub: "s \<le> u \<and> y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v \<longrightarrow> s ; (y ; s)\<^sup>\<omega>\<^sub>v \<le> (s ; y)\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "s \<le> u \<and> y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v"
  hence "s ; y \<le> u"
    by (metis meet.order_trans mult_isotone)
  thus "s ; (y ; s)\<^sup>\<omega>\<^sub>v \<le> (s ; y)\<^sup>\<omega>\<^sub>v" using 1
    by (metis mult_associative capped_omega_simulation order_refl)
qed

-- {* AACP Theorem 6.14 *}

lemma capped_omega_slide: "s \<le> u \<and> y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v \<longrightarrow> s ; (y ; s)\<^sup>\<omega>\<^sub>v = (s ; y)\<^sup>\<omega>\<^sub>v"
  by (smt antisym mult_associative mult_right_isotone capped_omega_unfold capped_omega_slide_sub meet.add_left_upper_bound order_trans)

lemma capped_omega_sub_dist: "s \<le> u \<and> y \<le> u \<and> u ; v \<le> v \<longrightarrow> s\<^sup>\<omega>\<^sub>v \<le> (s + y)\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_isotone add_least_upper_bound add_left_upper_bound)

-- {* AACP Theorem 6.15 *}

lemma capped_omega_simulation_2: "s \<le> u \<and> y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v \<longrightarrow> y ; s \<le> s ; y \<longrightarrow> (s ; y)\<^sup>\<omega>\<^sub>v \<le> s\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "s \<le> u \<and> y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v"
  hence 2: "s ; y \<le> u"
    by (metis mult_isotone order.trans)
  have 3: "s ; (s ; y)\<^sup>\<omega>\<^sub>v \<le> v" using 1
    by (metis capped_omega_below meet.order_trans mult_isotone)
  show "y ; s \<le> s ; y \<longrightarrow> (s ; y)\<^sup>\<omega>\<^sub>v \<le> s\<^sup>\<omega>\<^sub>v"
  proof
    assume 4: "y ; s \<le> s ; y"
    have "(s ; y)\<^sup>\<omega>\<^sub>v = s ; (y ; s)\<^sup>\<omega>\<^sub>v" using 1
      by (metis capped_omega_slide)
    also have "... \<le> s ; (s ; y)\<^sup>\<omega>\<^sub>v" using 1 2 4
      by (smt less_eq_def mult_right_isotone capped_omega_sub_dist order_trans)
    also have "... = s ; (s ; y)\<^sup>\<omega>\<^sub>v \<frown> v" using 3
      by (metis meet.less_eq_def meet_commutative)
    finally show "(s ; y)\<^sup>\<omega>\<^sub>v \<le> s\<^sup>\<omega>\<^sub>v" using 1
      by (metis capped_omega_induct_meet)
  qed
qed

-- {* AACP Theorem 6.16 *}

lemma left_plus_capped_omega: "y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v \<longrightarrow> (y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "y \<le> u \<and> u ; u \<le> u \<and> u ; v \<le> v"
  hence 2: "y ; y\<^sup>\<star> \<le> u"
    by (metis star_plus star_below_cap)
  hence "y ; y\<^sup>\<star> ; (y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v \<le> v" using 1
    by (metis capped_omega_below meet.order_trans mult_isotone)
  hence "y ; y\<^sup>\<star> ; (y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v = (y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v"
    by (metis meet.less_eq_def meet_commutative capped_omega_unfold)
  hence "(y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v" using 1 2
    by (smt2 capped_omega_simulation mult_associative mult_semi_associative star.circ_transitive_equal star_simulation_right_equal)
  thus "(y ; y\<^sup>\<star>)\<^sup>\<omega>\<^sub>v = y\<^sup>\<omega>\<^sub>v" using 1 2
    by (metis antisym capped_omega_isotone star.circ_mult_increasing)
qed

-- {* AACP Theorem 6.17 *}

lemma capped_omega_sub_vector: "z \<le> v \<and> y \<le> u \<and> u ; v \<le> v \<longrightarrow> y\<^sup>\<omega>\<^sub>u ; z \<le> y\<^sup>\<omega>\<^sub>v"
proof
  assume 1: "z \<le> v \<and> y \<le> u \<and> u ; v \<le> v"
  have "y\<^sup>\<omega>\<^sub>u ; z \<le> y ; y\<^sup>\<omega>\<^sub>u ; z \<frown> u ; z"
    by (metis capped_omega_unfold meet.add_least_upper_bound meet.add_right_upper_bound meet_commutative mult_left_isotone)
  also have "... \<le> y ; y\<^sup>\<omega>\<^sub>u ; z \<frown> v" using 1
    by (metis meet.add_left_isotone meet_commutative mult_right_isotone order_trans)
  finally show "y\<^sup>\<omega>\<^sub>u ; z \<le> y\<^sup>\<omega>\<^sub>v" using 1
    by (metis capped_omega_induct_meet mult_associative)
qed

-- {* AACP Theorem 6.18 *}

lemma capped_omega_omega: "y \<le> u \<and> u ; v \<le> v \<longrightarrow> (y\<^sup>\<omega>\<^sub>u)\<^sup>\<omega>\<^sub>v \<le> y\<^sup>\<omega>\<^sub>v"
  by (metis capped_omega_below capped_omega_sub_vector capped_omega_unfold meet.add_left_upper_bound order_trans)

end

(*
end


*)

end