(*  Title:      HOL/HOLCF/Library/Defl_Bifinite.thy
    Author:     Brian Huffman
*)

section \<open>Algebraic deflations are a bifinite domain\<close>

theory Defl_Bifinite
imports HOLCF "~~/src/HOL/Library/Infinite_Set"
begin

subsection \<open>Lemmas about MOST\<close>

default_sort type

subsection \<open>Eventually constant sequences\<close>

definition
  eventually_constant :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "eventually_constant S = (\<exists>x. MOST i. S i = x)"

lemma eventually_constant_MOST_MOST:
  "eventually_constant S \<longleftrightarrow> (MOST m. MOST n. S n = S m)"
unfolding eventually_constant_def MOST_nat
apply safe
apply (rule_tac x=m in exI, clarify)
apply (rule_tac x=m in exI, clarify)
apply simp
apply fast
done

lemma eventually_constantI: "MOST i. S i = x \<Longrightarrow> eventually_constant S"
unfolding eventually_constant_def by fast

lemma eventually_constant_comp:
  "eventually_constant (\<lambda>i. S i) \<Longrightarrow> eventually_constant (\<lambda>i. f (S i))"
unfolding eventually_constant_def
apply (erule exE, rule_tac x="f x" in exI)
apply (erule MOST_mono, simp)
done

lemma eventually_constant_Suc_iff:
  "eventually_constant (\<lambda>i. S (Suc i)) \<longleftrightarrow> eventually_constant (\<lambda>i. S i)"
unfolding eventually_constant_def
by (subst MOST_Suc_iff, rule refl)

lemma eventually_constant_SucD:
  "eventually_constant (\<lambda>i. S (Suc i)) \<Longrightarrow> eventually_constant (\<lambda>i. S i)"
by (rule eventually_constant_Suc_iff [THEN iffD1])

subsection \<open>Limits of eventually constant sequences\<close>

definition
  eventual :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a" where
  "eventual S = (THE x. MOST i. S i = x)"

lemma eventual_eqI: "MOST i. S i = x \<Longrightarrow> eventual S = x"
unfolding eventual_def
apply (rule the_equality, assumption)
apply (rename_tac y)
apply (subgoal_tac "MOST i::nat. y = x", simp)
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma MOST_eq_eventual:
  "eventually_constant S \<Longrightarrow> MOST i. S i = eventual S"
unfolding eventually_constant_def
by (erule exE, simp add: eventual_eqI)

lemma eventual_mem_range:
  "eventually_constant S \<Longrightarrow> eventual S \<in> range S"
apply (drule MOST_eq_eventual)
apply (simp only: MOST_nat_le, clarify)
apply (drule spec, drule mp, rule order_refl)
apply (erule range_eqI [OF sym])
done

lemma eventually_constant_MOST_iff:
  assumes S: "eventually_constant S"
  shows "(MOST n. P (S n)) \<longleftrightarrow> P (eventual S)"
apply (subgoal_tac "(MOST n. P (S n)) \<longleftrightarrow> (MOST n::nat. P (eventual S))")
apply simp
apply (rule iffI)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, force)
apply (rule MOST_rev_mp [OF MOST_eq_eventual [OF S]])
apply (erule MOST_mono, simp)
done

lemma MOST_eventual:
  "\<lbrakk>eventually_constant S; MOST n. P (S n)\<rbrakk> \<Longrightarrow> P (eventual S)"
proof -
  assume "eventually_constant S"
  hence "MOST n. S n = eventual S"
    by (rule MOST_eq_eventual)
  moreover assume "MOST n. P (S n)"
  ultimately have "MOST n. S n = eventual S \<and> P (S n)"
    by (rule MOST_conj_distrib [THEN iffD2, OF conjI])
  hence "MOST n::nat. P (eventual S)"
    by (rule MOST_mono) auto
  thus ?thesis by simp
qed

lemma eventually_constant_MOST_Suc_eq:
  "eventually_constant S \<Longrightarrow> MOST n. S (Suc n) = S n"
apply (drule MOST_eq_eventual)
apply (frule MOST_Suc_iff [THEN iffD2])
apply (erule MOST_rev_mp)
apply (erule MOST_rev_mp)
apply simp
done

lemma eventual_comp:
  "eventually_constant S \<Longrightarrow> eventual (\<lambda>i. f (S i)) = f (eventual (\<lambda>i. S i))"
apply (rule eventual_eqI)
apply (rule MOST_mono)
apply (erule MOST_eq_eventual)
apply simp
done

subsection \<open>Constructing finite deflations by iteration\<close>

default_sort cpo

lemma le_Suc_induct:
  assumes le: "i \<le> j"
  assumes step: "\<And>i. P i (Suc i)"
  assumes refl: "\<And>i. P i i"
  assumes trans: "\<And>i j k. \<lbrakk>P i j; P j k\<rbrakk> \<Longrightarrow> P i k"
  shows "P i j"
proof (cases "i = j")
  assume "i = j"
  thus "P i j" by (simp add: refl)
next
  assume "i \<noteq> j"
  with le have "i < j" by simp
  thus "P i j" using step trans by (rule less_Suc_induct)
qed

definition
  eventual_iterate :: "('a \<rightarrow> 'a::cpo) \<Rightarrow> ('a \<rightarrow> 'a)"
where
  "eventual_iterate f = eventual (\<lambda>n. iterate n\<cdot>f)"

text \<open>A pre-deflation is like a deflation, but not idempotent.\<close>

locale pre_deflation =
  fixes f :: "'a \<rightarrow> 'a::cpo"
  assumes below: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  assumes finite_range: "finite (range (\<lambda>x. f\<cdot>x))"
begin

lemma iterate_below: "iterate i\<cdot>f\<cdot>x \<sqsubseteq> x"
by (induct i, simp_all add: below_trans [OF below])

lemma iterate_fixed: "f\<cdot>x = x \<Longrightarrow> iterate i\<cdot>f\<cdot>x = x"
by (induct i, simp_all)

lemma antichain_iterate_app: "i \<le> j \<Longrightarrow> iterate j\<cdot>f\<cdot>x \<sqsubseteq> iterate i\<cdot>f\<cdot>x"
apply (erule le_Suc_induct)
apply (simp add: below)
apply (rule below_refl)
apply (erule (1) below_trans)
done

lemma finite_range_iterate_app: "finite (range (\<lambda>i. iterate i\<cdot>f\<cdot>x))"
proof (rule finite_subset)
  show "range (\<lambda>i. iterate i\<cdot>f\<cdot>x) \<subseteq> insert x (range (\<lambda>x. f\<cdot>x))"
    by (clarify, case_tac i, simp_all)
  show "finite (insert x (range (\<lambda>x. f\<cdot>x)))"
    by (simp add: finite_range)
qed

lemma eventually_constant_iterate_app:
  "eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>x)"
unfolding eventually_constant_def MOST_nat_le
proof -
  let ?Y = "\<lambda>i. iterate i\<cdot>f\<cdot>x"
  have "\<exists>j. \<forall>k. ?Y j \<sqsubseteq> ?Y k"
    apply (rule finite_range_has_max)
    apply (erule antichain_iterate_app)
    apply (rule finite_range_iterate_app)
    done
  then obtain j where j: "\<And>k. ?Y j \<sqsubseteq> ?Y k" by fast
  show "\<exists>z m. \<forall>n\<ge>m. ?Y n = z"
  proof (intro exI allI impI)
    fix k
    assume "j \<le> k"
    hence "?Y k \<sqsubseteq> ?Y j" by (rule antichain_iterate_app)
    also have "?Y j \<sqsubseteq> ?Y k" by (rule j)
    finally show "?Y k = ?Y j" .
  qed
qed

lemma eventually_constant_iterate:
  "eventually_constant (\<lambda>n. iterate n\<cdot>f)"
proof -
  have "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). eventually_constant (\<lambda>i. iterate i\<cdot>f\<cdot>y)"
    by (simp add: eventually_constant_iterate_app)
  hence "\<forall>y\<in>range (\<lambda>x. f\<cdot>x). MOST i. MOST j. iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    unfolding eventually_constant_MOST_MOST .
  hence "MOST i. MOST j. \<forall>y\<in>range (\<lambda>x. f\<cdot>x). iterate j\<cdot>f\<cdot>y = iterate i\<cdot>f\<cdot>y"
    by (simp only: MOST_finite_Ball_distrib [OF finite_range])
  hence "MOST i. MOST j. \<forall>x. iterate j\<cdot>f\<cdot>(f\<cdot>x) = iterate i\<cdot>f\<cdot>(f\<cdot>x)"
    by simp
  hence "MOST i. MOST j. \<forall>x. iterate (Suc j)\<cdot>f\<cdot>x = iterate (Suc i)\<cdot>f\<cdot>x"
    by (simp only: iterate_Suc2)
  hence "MOST i. MOST j. iterate (Suc j)\<cdot>f = iterate (Suc i)\<cdot>f"
    by (simp only: cfun_eq_iff)
  hence "eventually_constant (\<lambda>i. iterate (Suc i)\<cdot>f)"
    unfolding eventually_constant_MOST_MOST .
  thus "eventually_constant (\<lambda>i. iterate i\<cdot>f)"
    by (rule eventually_constant_SucD)
qed

abbreviation
  d :: "'a \<rightarrow> 'a"
where
  "d \<equiv> eventual_iterate f"

lemma MOST_d: "MOST n. P (iterate n\<cdot>f) \<Longrightarrow> P d"
unfolding eventual_iterate_def
using eventually_constant_iterate by (rule MOST_eventual)

lemma f_d: "f\<cdot>(d\<cdot>x) = d\<cdot>x"
apply (rule MOST_d)
apply (subst iterate_Suc [symmetric])
apply (rule eventually_constant_MOST_Suc_eq)
apply (rule eventually_constant_iterate_app)
done

lemma d_fixed_iff: "d\<cdot>x = x \<longleftrightarrow> f\<cdot>x = x"
proof
  assume "d\<cdot>x = x"
  with f_d [where x=x]
  show "f\<cdot>x = x" by simp
next
  assume f: "f\<cdot>x = x"
  have "\<forall>n. iterate n\<cdot>f\<cdot>x = x"
    by (rule allI, rule nat.induct, simp, simp add: f)
  hence "MOST n. iterate n\<cdot>f\<cdot>x = x"
    by (rule ALL_MOST)
  thus "d\<cdot>x = x"
    by (rule MOST_d)
qed

lemma finite_deflation_d: "finite_deflation d"
proof
  fix x :: 'a
  have "d \<in> range (\<lambda>n. iterate n\<cdot>f)"
    unfolding eventual_iterate_def
    using eventually_constant_iterate
    by (rule eventual_mem_range)
  then obtain n where n: "d = iterate n\<cdot>f" ..
  have "iterate n\<cdot>f\<cdot>(d\<cdot>x) = d\<cdot>x"
    using f_d by (rule iterate_fixed)
  thus "d\<cdot>(d\<cdot>x) = d\<cdot>x"
    by (simp add: n)
next
  fix x :: 'a
  show "d\<cdot>x \<sqsubseteq> x"
    by (rule MOST_d, simp add: iterate_below)
next
  from finite_range
  have "finite {x. f\<cdot>x = x}"
    by (rule finite_range_imp_finite_fixes)
  thus "finite {x. d\<cdot>x = x}"
    by (simp add: d_fixed_iff)
qed

lemma deflation_d: "deflation d"
using finite_deflation_d
by (rule finite_deflation_imp_deflation)

end

lemma finite_deflation_eventual_iterate:
  "pre_deflation d \<Longrightarrow> finite_deflation (eventual_iterate d)"
by (rule pre_deflation.finite_deflation_d)

lemma pre_deflation_oo:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "pre_deflation (d oo f)"
proof
  interpret d: finite_deflation d by fact
  fix x
  show "\<And>x. (d oo f)\<cdot>x \<sqsubseteq> x"
    by (simp, rule below_trans [OF d.below f])
  show "finite (range (\<lambda>x. (d oo f)\<cdot>x))"
    by (rule finite_subset [OF _ d.finite_range], auto)
qed

lemma eventual_iterate_oo_fixed_iff:
  assumes "finite_deflation d"
  assumes f: "\<And>x. f\<cdot>x \<sqsubseteq> x"
  shows "eventual_iterate (d oo f)\<cdot>x = x \<longleftrightarrow> d\<cdot>x = x \<and> f\<cdot>x = x"
proof -
  interpret d: finite_deflation d by fact
  let ?e = "d oo f"
  interpret e: pre_deflation "d oo f"
    using \<open>finite_deflation d\<close> f
    by (rule pre_deflation_oo)
  let ?g = "eventual (\<lambda>n. iterate n\<cdot>?e)"
  show ?thesis
    apply (subst e.d_fixed_iff)
    apply simp
    apply safe
    apply (erule subst)
    apply (rule d.idem)
    apply (rule below_antisym)
    apply (rule f)
    apply (erule subst, rule d.below)
    apply simp
    done
qed

lemma eventual_mono:
  assumes A: "eventually_constant A"
  assumes B: "eventually_constant B"
  assumes below: "\<And>n. A n \<sqsubseteq> B n"
  shows "eventual A \<sqsubseteq> eventual B"
proof -
  from A have "MOST n. A n = eventual A"
    by (rule MOST_eq_eventual)
  then have "MOST n. eventual A \<sqsubseteq> B n"
    by (rule MOST_mono) (erule subst, rule below)
  with B show "eventual A \<sqsubseteq> eventual B"
    by (rule MOST_eventual)
qed

lemma eventual_iterate_mono:
  assumes f: "pre_deflation f" and g: "pre_deflation g" and "f \<sqsubseteq> g"
  shows "eventual_iterate f \<sqsubseteq> eventual_iterate g"
unfolding eventual_iterate_def
apply (rule eventual_mono)
apply (rule pre_deflation.eventually_constant_iterate [OF f])
apply (rule pre_deflation.eventually_constant_iterate [OF g])
apply (rule monofun_cfun_arg [OF \<open>f \<sqsubseteq> g\<close>])
done

lemma cont2cont_eventual_iterate_oo:
  assumes d: "finite_deflation d"
  assumes cont: "cont f" and below: "\<And>x y. f x\<cdot>y \<sqsubseteq> y"
  shows "cont (\<lambda>x. eventual_iterate (d oo f x))"
    (is "cont ?e")
proof (rule contI2)
  show "monofun ?e"
    apply (rule monofunI)
    apply (rule eventual_iterate_mono)
    apply (rule pre_deflation_oo [OF d below])
    apply (rule pre_deflation_oo [OF d below])
    apply (rule monofun_cfun_arg)
    apply (erule cont2monofunE [OF cont])
    done
next
  fix Y :: "nat \<Rightarrow> 'b"
  assume Y: "chain Y"
  with cont have fY: "chain (\<lambda>i. f (Y i))"
    by (rule ch2ch_cont)
  assume eY: "chain (\<lambda>i. ?e (Y i))"
  have lub_below: "\<And>x. f (\<Squnion>i. Y i)\<cdot>x \<sqsubseteq> x"
    by (rule admD [OF _ Y], simp add: cont, rule below)
  have "deflation (?e (\<Squnion>i. Y i))"
    apply (rule pre_deflation.deflation_d)
    apply (rule pre_deflation_oo [OF d lub_below])
    done
  then show "?e (\<Squnion>i. Y i) \<sqsubseteq> (\<Squnion>i. ?e (Y i))"
  proof (rule deflation.belowI)
    fix x :: 'a
    assume "?e (\<Squnion>i. Y i)\<cdot>x = x"
    hence "d\<cdot>x = x" and "f (\<Squnion>i. Y i)\<cdot>x = x"
      by (simp_all add: eventual_iterate_oo_fixed_iff [OF d lub_below])
    hence "(\<Squnion>i. f (Y i)\<cdot>x) = x"
      apply (simp only: cont2contlubE [OF cont Y])
      apply (simp only: contlub_cfun_fun [OF fY])
      done
    have "compact (d\<cdot>x)"
      using d by (rule finite_deflation.compact)
    then have "compact x"
      using \<open>d\<cdot>x = x\<close> by simp
    then have "compact (\<Squnion>i. f (Y i)\<cdot>x)"
      using \<open>(\<Squnion>i. f (Y i)\<cdot>x) = x\<close> by simp
    then have "\<exists>n. max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)"
      by - (rule compact_imp_max_in_chain, simp add: fY, assumption)
    then obtain n where n: "max_in_chain n (\<lambda>i. f (Y i)\<cdot>x)" ..
    then have "f (Y n)\<cdot>x = x"
      using \<open>(\<Squnion>i. f (Y i)\<cdot>x) = x\<close> fY by (simp add: maxinch_is_thelub)
    with \<open>d\<cdot>x = x\<close> have "?e (Y n)\<cdot>x = x"
      by (simp add: eventual_iterate_oo_fixed_iff [OF d below])
    moreover have "?e (Y n)\<cdot>x \<sqsubseteq> (\<Squnion>i. ?e (Y i)\<cdot>x)"
      by (rule is_ub_thelub, simp add: eY)
    ultimately have "x \<sqsubseteq> (\<Squnion>i. ?e (Y i))\<cdot>x"
      by (simp add: contlub_cfun_fun eY)
    also have "(\<Squnion>i. ?e (Y i))\<cdot>x \<sqsubseteq> x"
      apply (rule deflation.below)
      apply (rule admD [OF adm_deflation eY])
      apply (rule pre_deflation.deflation_d)
      apply (rule pre_deflation_oo [OF d below])
      done
    finally show "(\<Squnion>i. ?e (Y i))\<cdot>x = x" ..
  qed
qed

subsection \<open>Intersection of algebraic deflations\<close>

default_sort bifinite

definition meet_fin_defl :: "'a fin_defl \<Rightarrow> 'a fin_defl \<Rightarrow> 'a fin_defl"
  where "meet_fin_defl a b =
    Abs_fin_defl (eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b))"

lemma Rep_meet_fin_defl:
  "Rep_fin_defl (meet_fin_defl a b) =
    eventual_iterate (Rep_fin_defl a oo Rep_fin_defl b)"
unfolding meet_fin_defl_def
apply (rule Abs_fin_defl_inverse [simplified])
apply (rule finite_deflation_eventual_iterate)
apply (rule pre_deflation_oo)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma Rep_meet_fin_defl_fixed_iff:
  "Rep_fin_defl (meet_fin_defl a b)\<cdot>x = x \<longleftrightarrow>
    Rep_fin_defl a\<cdot>x = x \<and> Rep_fin_defl b\<cdot>x = x"
unfolding Rep_meet_fin_defl
apply (rule eventual_iterate_oo_fixed_iff)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule Rep_fin_defl.below)
done

lemma meet_fin_defl_mono:
  "\<lbrakk>a \<sqsubseteq> b; c \<sqsubseteq> d\<rbrakk> \<Longrightarrow> meet_fin_defl a c \<sqsubseteq> meet_fin_defl b d"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below1: "meet_fin_defl a b \<sqsubseteq> a"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_below2: "meet_fin_defl a b \<sqsubseteq> b"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

lemma meet_fin_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_fin_defl b c"
unfolding below_fin_defl_def
apply (rule Rep_fin_defl.belowI)
apply (simp add: Rep_meet_fin_defl_fixed_iff Rep_fin_defl.belowD)
done

definition meet_defl :: "'a defl \<rightarrow> 'a defl \<rightarrow> 'a defl"
  where "meet_defl = defl.extension (\<lambda>a. defl.extension (\<lambda>b.
    defl_principal (meet_fin_defl a b)))"

lemma meet_defl_principal:
  "meet_defl\<cdot>(defl_principal a)\<cdot>(defl_principal b) =
    defl_principal (meet_fin_defl a b)"
unfolding meet_defl_def
by (simp add: defl.extension_principal defl.extension_mono meet_fin_defl_mono)

lemma meet_defl_below1: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> a"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below1)
done

lemma meet_defl_below2: "meet_defl\<cdot>a\<cdot>b \<sqsubseteq> b"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_below2)
done

lemma meet_defl_greatest: "\<lbrakk>a \<sqsubseteq> b; a \<sqsubseteq> c\<rbrakk> \<Longrightarrow> a \<sqsubseteq> meet_defl\<cdot>b\<cdot>c"
apply (induct a rule: defl.principal_induct, simp)
apply (induct b rule: defl.principal_induct, simp)
apply (induct c rule: defl.principal_induct, simp)
apply (simp add: meet_defl_principal meet_fin_defl_greatest)
done

lemma meet_defl_eq2: "b \<sqsubseteq> a \<Longrightarrow> meet_defl\<cdot>a\<cdot>b = b"
by (fast intro: below_antisym meet_defl_below2 meet_defl_greatest)

interpretation meet_defl: semilattice "\<lambda>a b. meet_defl\<cdot>a\<cdot>b"
by standard
  (fast intro: below_antisym meet_defl_greatest
   meet_defl_below1 [THEN below_trans] meet_defl_below2 [THEN below_trans])+

lemma deflation_meet_defl: "deflation (meet_defl\<cdot>a)"
apply (rule deflation.intro)
apply (rule meet_defl.left_idem)
apply (rule meet_defl_below2)
done

lemma finite_deflation_meet_defl:
  assumes "compact a"
  shows "finite_deflation (meet_defl\<cdot>a)"
proof (rule finite_deflation_intro)
  obtain d where a: "a = defl_principal d"
    using defl.compact_imp_principal [OF assms] ..
  have "finite (defl_set -` Pow (defl_set a))"
    apply (rule finite_vimageI)
    apply (rule finite_Pow_iff [THEN iffD2])
    apply (simp add: defl_set_def a cast_defl_principal Abs_fin_defl_inverse)
    apply (rule Rep_fin_defl.finite_fixes)
    apply (rule injI)
    apply (simp add: po_eq_conv defl_set_subset_iff [symmetric])
    done
  hence "finite (range (\<lambda>b. meet_defl\<cdot>a\<cdot>b))"
    apply (rule rev_finite_subset)
    apply (clarsimp, erule rev_subsetD)
    apply (simp add: defl_set_subset_iff meet_defl_below1)
    done
  thus "finite {b. meet_defl\<cdot>a\<cdot>b = b}"
    by (rule finite_range_imp_finite_fixes)
qed (rule deflation_meet_defl)

lemma compact_iff_finite_deflation_cast:
  "compact d \<longleftrightarrow> finite_deflation (cast\<cdot>d)"
apply (safe dest!: defl.compact_imp_principal)
apply (simp add: cast_defl_principal finite_deflation_Rep_fin_defl)
apply (rule compact_cast_iff [THEN iffD1])
apply (erule finite_deflation_imp_compact)
done

lemma compact_iff_finite_defl_set:
  "compact d \<longleftrightarrow> finite (defl_set d)"
by (simp add: compact_iff_finite_deflation_cast defl_set_def
  finite_deflation_def deflation_cast finite_deflation_axioms_def)

lemma compact_meet_defl1: "compact a \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
apply (simp add: compact_iff_finite_defl_set)
apply (erule rev_finite_subset)
apply (simp add: defl_set_subset_iff meet_defl_below1)
done

lemma compact_meet_defl2: "compact b \<Longrightarrow> compact (meet_defl\<cdot>a\<cdot>b)"
by (subst meet_defl.commute, rule compact_meet_defl1)

subsection \<open>Chain of approx functions on algebraic deflations\<close>

context bifinite_approx_chain
begin

definition defl_approx :: "nat \<Rightarrow> 'a defl \<rightarrow> 'a defl"
  where "defl_approx i = meet_defl\<cdot>(defl_principal (Abs_fin_defl (approx i)))"

lemma defl_approx: "approx_chain defl_approx"
proof (rule approx_chain.intro)
  have chain1: "chain (\<lambda>i. defl_principal (Abs_fin_defl (approx i)))"
    apply (rule chainI)
    apply (rule defl.principal_mono)
    apply (simp add: below_fin_defl_def Abs_fin_defl_inverse)
    apply (rule chainE [OF chain_approx])
    done
  show chain: "chain (\<lambda>i. defl_approx i)"
    unfolding defl_approx_def by (simp add: chain1)
  have below: "\<And>i d. defl_approx i\<cdot>d \<sqsubseteq> d"
    unfolding defl_approx_def by (rule meet_defl_below2)
  show "(\<Squnion>i. defl_approx i) = ID"
    apply (rule cfun_eqI, rename_tac d, simp)
    apply (rule below_antisym)
    apply (simp add: contlub_cfun_fun chain)
    apply (simp add: lub_below chain below)
    apply (simp add: defl_approx_def)
    apply (simp add: lub_distribs chain1)
    apply (rule meet_defl_greatest [OF _ below_refl])
    apply (rule cast_below_imp_below)
    apply (simp add: contlub_cfun_arg chain1)
    apply (simp add: cast_defl_principal Abs_fin_defl_inverse)
    apply (rule cast.below_ID)
    done
  show "\<And>i. finite_deflation (defl_approx i)"
    unfolding defl_approx_def
    apply (rule finite_deflation_meet_defl)
    apply (rule defl.compact_principal)
    done
qed

end

subsection \<open>Algebraic deflations are a bifinite domain\<close>

instance defl :: (bifinite) bifinite
proof
  obtain a :: "nat \<Rightarrow> 'a \<rightarrow> 'a" where "approx_chain a"
    using bifinite ..
  hence "bifinite_approx_chain a"
    unfolding bifinite_approx_chain_def .
  thus "\<exists>(a::nat \<Rightarrow> 'a defl \<rightarrow> 'a defl). approx_chain a"
    by (fast intro: bifinite_approx_chain.defl_approx)
qed

subsection \<open>Algebraic deflations are representable\<close>

default_sort "domain"

definition defl_emb :: "udom defl \<rightarrow> udom"
  where "defl_emb = udom_emb (bifinite_approx_chain.defl_approx udom_approx)"

definition defl_prj :: "udom \<rightarrow> udom defl"
  where "defl_prj = udom_prj (bifinite_approx_chain.defl_approx udom_approx)"

lemma ep_pair_defl: "ep_pair defl_emb defl_prj"
unfolding defl_emb_def defl_prj_def
apply (rule ep_pair_udom)
apply (rule bifinite_approx_chain.defl_approx)
apply (simp add: bifinite_approx_chain_def)
done

text "Deflation combinator for deflation type constructor"

definition defl_defl :: "udom defl \<rightarrow> udom defl"
  where defl_deflation_def:
  "defl_defl = defl.extension (\<lambda>a. defl_principal
    (Abs_fin_defl (defl_emb oo meet_defl\<cdot>(defl_principal a) oo defl_prj)))"

lemma cast_defl_defl:
  "cast\<cdot>(defl_defl\<cdot>a) = defl_emb oo meet_defl\<cdot>a oo defl_prj"
apply (induct a rule: defl.principal_induct, simp)
apply (subst defl_deflation_def)
apply (subst defl.extension_principal)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
apply (simp add: cast_defl_principal
  below_fin_defl_def Abs_fin_defl_inverse
  ep_pair.finite_deflation_e_d_p ep_pair_defl
  finite_deflation_meet_defl monofun_cfun)
done

definition defl_map_emb :: "'a::domain defl \<rightarrow> udom defl"
  where "defl_map_emb = defl_fun1 emb prj ID"

definition defl_map_prj :: "udom defl \<rightarrow> 'a::domain defl"
  where "defl_map_prj = defl.extension (\<lambda>a. defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb)))"

lemma defl_map_emb_principal:
  "defl_map_emb\<cdot>(defl_principal a) =
    defl_principal (Abs_fin_defl (emb oo Rep_fin_defl a oo prj))"
unfolding defl_map_emb_def defl_fun1_def
apply (subst defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def Abs_fin_defl_inverse monofun_cfun
       domain.finite_deflation_e_d_p finite_deflation_Rep_fin_defl)
apply simp
done

lemma defl_map_prj_principal:
  "(defl_map_prj\<cdot>(defl_principal a) :: 'a::domain defl) =
  defl_principal (Abs_fin_defl (prj oo cast\<cdot>(meet_defl\<cdot>DEFL('a)\<cdot>(defl_principal a)) oo emb))"
unfolding defl_map_prj_def
apply (rule defl.extension_principal)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (simp add: monofun_cfun below_fin_defl_def)
done

lemma defl_map_prj_defl_map_emb: "defl_map_prj\<cdot>(defl_map_emb\<cdot>d) = d"
apply (rule cast_eq_imp_eq)
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_emb_principal)
apply (subst defl_map_prj_principal)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (subst meet_defl_eq2)
apply (rule cast_below_imp_below)
apply (simp add: cast_DEFL)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (rule cfun_belowI, simp)
apply (rule Rep_fin_defl.below)
apply (simp add: cast_defl_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_e_d_p)
apply (rule finite_deflation_Rep_fin_defl)
apply (simp add: cfun_eqI)
done

lemma defl_map_emb_defl_map_prj:
  "defl_map_emb\<cdot>(defl_map_prj\<cdot>d :: 'a defl) = meet_defl\<cdot>DEFL('a)\<cdot>d"
apply (induct_tac d rule: defl.principal_induct, simp)
apply (subst defl_map_prj_principal)
apply (subst defl_map_emb_principal)
apply (subst Abs_fin_defl_inverse, simp)
apply (rule domain.finite_deflation_p_d_e)
apply (rule finite_deflation_cast)
apply (simp add: compact_meet_defl2)
apply (subst emb_prj)
apply (intro monofun_cfun below_refl meet_defl_below1)
apply (rule cast_eq_imp_eq)
apply (subst cast_defl_principal)
apply (simp add: cfcomp1 emb_prj)
apply (subst deflation_below_comp2 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (subst deflation_below_comp1 [OF deflation_cast deflation_cast])
apply (rule monofun_cfun_arg, rule meet_defl_below1)
apply (simp add: eta_cfun)
apply (rule Abs_fin_defl_inverse, simp)
apply (rule finite_deflation_cast)
apply (rule compact_meet_defl2, simp)
done

lemma ep_pair_defl_map_emb_defl_map_prj:
  "ep_pair defl_map_emb defl_map_prj"
apply (rule ep_pair.intro)
apply (rule defl_map_prj_defl_map_emb)
apply (simp add: defl_map_emb_defl_map_prj)
apply (rule meet_defl_below2)
done

instantiation defl :: ("domain") "domain"
begin

definition
  "emb = defl_emb oo defl_map_emb"

definition
  "prj = defl_map_prj oo defl_prj"

definition
  "defl (t::'a defl itself) = defl_defl\<cdot>DEFL('a)"

definition
  "(liftemb :: 'a defl u \<rightarrow> udom u) = u_map\<cdot>emb"

definition
  "(liftprj :: udom u \<rightarrow> 'a defl u) = u_map\<cdot>prj"

definition
  "liftdefl (t::'a defl itself) = liftdefl_of\<cdot>DEFL('a defl)"

instance proof
  show ep: "ep_pair emb (prj :: udom \<rightarrow> 'a defl)"
    unfolding emb_defl_def prj_defl_def
    apply (rule ep_pair_comp [OF _ ep_pair_defl])
    apply (rule ep_pair_defl_map_emb_defl_map_prj)
    done
  show "cast\<cdot>DEFL('a defl) = emb oo (prj :: udom \<rightarrow> 'a defl)"
    unfolding defl_defl_def emb_defl_def prj_defl_def
    by (simp add: cast_defl_defl cfcomp1 defl_map_emb_defl_map_prj)
qed (fact liftemb_defl_def liftprj_defl_def liftdefl_defl_def)+

end

lemma DEFL_defl [domain_defl_simps]: "DEFL('a defl) = defl_defl\<cdot>DEFL('a)"
by (rule defl_defl_def)

end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Kleene Algebras\<close>

theory Kleene_Algebra
imports Conway
begin

subsection \<open>Left Near Kleene Algebras\<close>

text \<open>Extending the hierarchy developed in @{theory Kleene_Algebra.Dioid} we now
add an operation of Kleene star, finite iteration, or reflexive
transitive closure to variants of Dioids. Since a multiplicative unit
is needed for defining the star we only consider variants with~$1$;
$0$ can be added separately. We consider the left star induction axiom
and the right star induction axiom independently since in some
applications, e.g., Salomaa's axioms, probabilistic Kleene algebras,
or completeness proofs with respect to the equational theoy of regular
expressions and regular languages, the right star induction axiom is
not needed or not valid.

We start with near dioids, then consider pre-dioids and finally
dioids. It turns out that many of the known laws of Kleene algebras
hold already in these more general settings. In fact, all our
equational theorems have been proved within left Kleene algebras, as
expected.

Although most of the proofs in this file could be fully automated by
Sledgehammer and Metis, we display step-wise proofs as they would
appear in a text book. First, this file may then be useful as a
reference manual on Kleene algebra. Second, it is better protected
against changes in the underlying theories and supports easy
translation of proofs into other settings.\<close>

class left_near_kleene_algebra = near_dioid_one + star_op +
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"

begin

text \<open>First we prove two immediate consequences of the unfold
axiom. The first one states that starred elements are reflexive.\<close>

lemma star_ref [simp]: "1 \<le> x\<^sup>\<star>"
  using star_unfoldl by auto

text \<open>Reflexivity of starred elements implies, by definition of the
order, that~$1$ is an additive unit for starred elements.\<close>

lemma star_plus_one [simp]: "1 + x\<^sup>\<star> = x\<^sup>\<star>"
  using less_eq_def star_ref by blast

lemma star_1l [simp]: "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  using star_unfoldl by auto

lemma "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

text \<open>Next we show that starred elements are transitive.\<close>

lemma star_trans_eq [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym) \<comment> \<open>this splits an equation into two inequalities\<close>
  have "x\<^sup>\<star> + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by auto
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_inductl)
  next show "x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    using mult_isor star_ref by fastforce
qed

lemma star_trans: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  by simp

text \<open>We now derive variants of the star induction axiom.\<close>

lemma star_inductl_var: "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
proof -
  assume "x \<cdot> y \<le> y"
  hence "y + x \<cdot> y \<le> y"
    by simp
  thus "x\<^sup>\<star> \<cdot> y \<le> y"
    by (simp add: star_inductl)
qed

lemma star_inductl_var_equiv [simp]: "x\<^sup>\<star> \<cdot> y \<le> y \<longleftrightarrow> x \<cdot> y \<le> y"
proof
  assume "x \<cdot> y \<le> y"
  thus "x\<^sup>\<star> \<cdot> y \<le> y"
    by (simp add: star_inductl_var)
next
  assume "x\<^sup>\<star> \<cdot> y \<le> y"
  hence  "x\<^sup>\<star> \<cdot> y = y"
    by (metis eq_iff mult_1_left mult_isor star_ref)
  moreover hence "x \<cdot> y = x \<cdot> x\<^sup>\<star> \<cdot> y"
    by (simp add: mult.assoc)
  moreover have "... \<le> x\<^sup>\<star> \<cdot> y"
    by (metis mult_isor star_1l)
  ultimately show "x \<cdot> y \<le> y"
    by auto
qed

lemma star_inductl_var_eq:  "x \<cdot> y = y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
  by (metis eq_iff star_inductl_var)

lemma star_inductl_var_eq2: "y = x \<cdot> y \<Longrightarrow> y = x\<^sup>\<star> \<cdot> y"
proof -
  assume hyp: "y = x \<cdot> y"
  hence "y \<le> x\<^sup>\<star> \<cdot> y"
    using mult_isor star_ref by fastforce
  thus "y = x\<^sup>\<star> \<cdot> y"
    using hyp eq_iff by auto
qed

lemma "y = x \<cdot> y \<longleftrightarrow> y = x\<^sup>\<star> \<cdot> y"
(*nitpick [expect=genuine]*)
  oops

lemma "x\<^sup>\<star> \<cdot> z \<le> y \<Longrightarrow> z + x \<cdot> y \<le> y"
(*nitpick [expect=genuine]*)
  oops

lemma star_inductl_one: "1 + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  using star_inductl by force

lemma star_inductl_star: "x \<cdot> y\<^sup>\<star> \<le> y\<^sup>\<star> \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (simp add: star_inductl_one)

lemma star_inductl_eq:  "z + x \<cdot> y = y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  by (simp add: star_inductl)

text \<open>We now prove two facts related to~$1$.\<close>

lemma star_subid: "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
proof -
  assume "x \<le> 1"
  hence "1 + x \<cdot> 1 \<le> 1"
    by simp
  hence "x\<^sup>\<star> \<le> 1"
    by (metis mult_oner star_inductl)
  thus "x\<^sup>\<star> = 1"
    by (simp add: order.antisym)
qed

lemma star_one [simp]: "1\<^sup>\<star> = 1"
  by (simp add: star_subid)

text \<open>We now prove a subdistributivity property for the star (which
is equivalent to isotonicity of star).\<close>

lemma star_subdist:  "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
proof -
  have "x \<cdot> (x + y)\<^sup>\<star> \<le> (x + y) \<cdot> (x + y)\<^sup>\<star>"
    by simp
  also have "...  \<le> (x + y)\<^sup>\<star>"
    by (metis star_1l)
  thus ?thesis
    using calculation order_trans star_inductl_star by blast
qed

lemma star_subdist_var:  "x\<^sup>\<star> + y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  using join.sup_commute star_subdist by force

lemma star_iso [intro]: "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (metis less_eq_def star_subdist)

text \<open>We now prove some more simple properties.\<close>

lemma star_invol [simp]: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  have "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (fact star_trans_eq)
  thus "(x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_inductl_star)
  have"(x\<^sup>\<star>)\<^sup>\<star> \<cdot> (x\<^sup>\<star>)\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<star>"
    by (fact star_trans)
  hence "x \<cdot> (x\<^sup>\<star>)\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<star>"
    by (meson star_inductl_var_equiv)
  thus "x\<^sup>\<star> \<le> (x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star_inductl_star)
qed

lemma star2 [simp]: "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  show "x\<^sup>\<star> \<le> (1 + x)\<^sup>\<star>"
    by auto
  have "x\<^sup>\<star> + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by simp
  thus "(1 + x)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: star_inductl_star)
qed

lemma "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "x \<le> x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "x \<cdot> z \<le> z \<cdot> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> z \<cdot> y\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

text \<open>The following facts express inductive conditions that are used
to show that @{term "(x + y)\<^sup>\<star>"} is the greatest term that can be built
from~@{term x} and~@{term y}.\<close>

lemma prod_star_closure: "x \<le> z\<^sup>\<star> \<Longrightarrow> y \<le> z\<^sup>\<star> \<Longrightarrow> x \<cdot> y \<le> z\<^sup>\<star>"
proof -
  assume assm: "x \<le> z\<^sup>\<star>" "y \<le> z\<^sup>\<star>"
  hence "y + z\<^sup>\<star> \<cdot> z\<^sup>\<star> \<le> z\<^sup>\<star>"
    by simp
  hence "z\<^sup>\<star> \<cdot> y \<le> z\<^sup>\<star>"
    by (simp add: star_inductl)
  also have "x \<cdot> y \<le> z\<^sup>\<star> \<cdot> y"
    by (simp add: assm mult_isor)
  thus "x \<cdot> y \<le> z\<^sup>\<star>"
    using calculation order.trans by blast
qed

lemma star_star_closure: "x\<^sup>\<star> \<le> z\<^sup>\<star> \<Longrightarrow> (x\<^sup>\<star>)\<^sup>\<star> \<le> z\<^sup>\<star>"
  by (metis star_invol)

lemma star_closed_unfold: "x\<^sup>\<star> = x \<Longrightarrow> x = 1 + x \<cdot> x"
  by (metis star_plus_one star_trans_eq)

lemma "x\<^sup>\<star> = x \<longleftrightarrow> x = 1 + x \<cdot> x"
(*nitpick [expect=genuine]*)
  oops

end (* left_near_kleene_algebra *)

subsection \<open>Left Pre-Kleene Algebras\<close>

class left_pre_kleene_algebra = left_near_kleene_algebra + pre_dioid_one

begin

text \<open>We first prove that the star operation is extensive.\<close>

lemma star_ext [simp]: "x \<le> x\<^sup>\<star>"
proof -
  have "x \<le> x \<cdot> x\<^sup>\<star>"
    by (metis mult_oner mult_isol star_ref)
  thus ?thesis
    by (metis order_trans star_1l)
qed

text \<open>We now prove a right star unfold law.\<close>

lemma star_1r [simp]: "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
proof -
  have "x + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by simp
  thus ?thesis
    by (fact star_inductl)
qed

lemma star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  by simp

lemma "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

text \<open>Next we prove a simulation law for the star.  It is
instrumental in proving further properties.\<close>

lemma star_sim1: "x \<cdot> z \<le> z \<cdot> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> z \<cdot> y\<^sup>\<star>"
proof -
  assume "x \<cdot> z \<le> z \<cdot> y"
  hence "x \<cdot> z \<cdot> y\<^sup>\<star> \<le> z \<cdot> y \<cdot> y\<^sup>\<star>"
    by (simp add: mult_isor)
  also have "...  \<le> z \<cdot> y\<^sup>\<star>"
    by (simp add: mult_isol mult_assoc)
  finally have "x \<cdot> z \<cdot> y\<^sup>\<star> \<le> z \<cdot> y\<^sup>\<star>"
    by simp
  hence "z + x \<cdot> z \<cdot> y\<^sup>\<star> \<le> z \<cdot> y\<^sup>\<star>"
    by (metis join.sup_least mult_isol mult_oner star_ref)
  thus "x\<^sup>\<star> \<cdot> z \<le> z \<cdot> y\<^sup>\<star>"
    by (simp add: star_inductl mult_assoc)
qed

text \<open>The next lemma is used in omega algebras to prove, for
instance, Bachmair and Dershowitz's separation of termination
theorem~\cite{bachmair86commutation}. The property at the left-hand
side of the equivalence is known as \emph{quasicommutation}.\<close>

lemma quasicomm_var: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<longleftrightarrow> y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
proof
  assume "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  thus "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using star_sim1 by force
next
  assume "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  thus "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    by (meson mult_isor order_trans star_ext)
qed

lemma star_slide1: "(x \<cdot> y)\<^sup>\<star> \<cdot> x \<le> x \<cdot> (y \<cdot> x)\<^sup>\<star>"
  by (simp add: mult_assoc star_sim1)

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

lemma star_slide_var1: "x\<^sup>\<star> \<cdot> x \<le> x \<cdot> x\<^sup>\<star>"
  by (simp add: star_sim1)

text \<open>We now show that the (left) star unfold axiom can be strengthened to an equality.\<close>

lemma star_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (fact star_unfoldl)
  have "1 + x \<cdot> (1 + x \<cdot> x\<^sup>\<star>) \<le> 1 + x \<cdot> x\<^sup>\<star>"
    by (meson join.sup_mono eq_refl mult_isol star_unfoldl)
  thus "x\<^sup>\<star> \<le> 1 + x \<cdot> x\<^sup>\<star>"
    by (simp add: star_inductl_one)
qed

lemma "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

text \<open>Next we relate the star and the reflexive transitive closure
operation.\<close>

lemma star_rtc1_eq [simp]: "1 + x + x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  by (simp add: join.sup.absorb2)

lemma star_rtc1: "1 + x + x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  by simp

lemma star_rtc2: "1 + x \<cdot> x \<le> x \<longleftrightarrow> x = x\<^sup>\<star>"
proof
  assume "1 + x \<cdot> x \<le> x"
  thus "x = x\<^sup>\<star>"
    by (simp add: local.eq_iff local.star_inductl_one)
next
  assume "x = x\<^sup>\<star>"
  thus "1 + x \<cdot> x \<le> x"
    using local.star_closed_unfold by auto
qed

lemma star_rtc3: "1 + x \<cdot> x = x \<longleftrightarrow> x = x\<^sup>\<star>"
  by (metis order_refl star_plus_one star_rtc2 star_trans_eq)

lemma star_rtc_least: "1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
proof -
  assume "1 + x + y \<cdot> y \<le> y"
  hence "1 + x \<cdot> y \<le> y"
    by (metis join.le_sup_iff mult_isol_var star_trans_eq star_rtc2)
  thus "x\<^sup>\<star> \<le> y"
    by (simp add: star_inductl_one)
qed

lemma star_rtc_least_eq: "1 + x + y \<cdot> y = y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  by (simp add: star_rtc_least)

lemma "1 + x + y \<cdot> y \<le> y \<longleftrightarrow> x\<^sup>\<star> \<le> y"
(*nitpick [expect=genuine]*)
  oops

text \<open>The next lemmas are again related to closure conditions\<close>

lemma star_subdist_var_1: "x \<le> (x + y)\<^sup>\<star>"
  by (meson join.sup.boundedE star_ext)

lemma star_subdist_var_2: "x \<cdot> y \<le> (x + y)\<^sup>\<star>"
  by (meson join.sup.boundedE prod_star_closure star_ext)

lemma star_subdist_var_3: "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  by (simp add: prod_star_closure star_iso)

text \<open>We now prove variants of sum-elimination laws under a star.
These are also known a denesting laws or as sum-star laws.\<close>

lemma star_denest [simp]: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
proof (rule antisym)
  have "x + y \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis join.sup.bounded_iff mult_1_right mult_isol_var mult_onel star_ref star_ext)
  thus "(x + y)\<^sup>\<star> \<le> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
    by (fact star_iso)
  have "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (fact star_subdist_var_3)
  thus "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (simp add: prod_star_closure star_inductl_star)
qed

lemma star_sum_var [simp]: "(x\<^sup>\<star> + y\<^sup>\<star>)\<^sup>\<star> = (x + y)\<^sup>\<star>"
  by simp

lemma star_denest_var [simp]: "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> = (x + y)\<^sup>\<star>"
proof (rule antisym)
  have "1 \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult_isol_var mult_oner star_ref)
  moreover have "x \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_isor)
  moreover have "y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult_isol_var mult_onel star_1l star_ref)
  ultimately have "1 + (x + y) \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by auto
  thus "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (metis mult.assoc mult_oner star_inductl)
  have "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (y\<^sup>\<star> \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_isol_var star_iso)
  hence "(y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (metis add.commute star_denest)
  moreover have "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (fact star_subdist)
  ultimately show "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    using prod_star_closure by blast
qed

lemma star_denest_var_2 [simp]: "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by simp

lemma star_denest_var_3 [simp]: "x\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x\<^sup>\<star>)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by simp

lemma star_denest_var_4 [ac_simps]: "(y\<^sup>\<star> \<cdot> x\<^sup>\<star>)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (metis add_comm star_denest)

lemma star_denest_var_5 [ac_simps]: "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> = y\<^sup>\<star> \<cdot> (x \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (simp add: star_denest_var_4)

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

lemma star_denest_var_6 [simp]: "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star> = (x + y)\<^sup>\<star>"
  using mult_assoc by simp

lemma star_denest_var_7 [simp]: "(x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> = (x + y)\<^sup>\<star>"
proof (rule antisym)
  have "(x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_assoc)
  thus "(x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by simp
  have "1 \<le> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis dual_order.trans mult_1_left mult_isor star_ref)
  moreover have "(x + y) \<cdot> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    using mult_isor star_1l by presburger
  ultimately have "1 + (x + y) \<cdot> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by simp
  thus "(x + y)\<^sup>\<star> \<le> (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis mult.assoc star_inductl_one)
qed

lemma star_denest_var_8 [simp]: "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (simp add: mult_assoc)

lemma star_denest_var_9 [simp]: "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  using star_denest_var_7 by simp

text \<open>The following statements are well known from term
rewriting. They are all variants of the Church-Rosser theorem in
Kleene algebra~\cite{struth06churchrosser}. But first we prove a law
relating two confluence properties.\<close>

lemma confluence_var [iff]: "y \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<longleftrightarrow> y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
proof
  assume "y \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  thus "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    using star_sim1 by fastforce
next
  assume "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  thus "y \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (meson mult_isor order_trans star_ext)
qed

lemma church_rosser [intro]: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
proof (rule antisym)
  assume "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  hence "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis mult_isol mult_isor mult.assoc)
  hence "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: mult_assoc)
  moreover have "1 \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis dual_order.trans mult_1_right mult_isol star_ref)
  ultimately have "1 + x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by simp
  hence "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (simp add: star_inductl_one)
  thus "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by simp
  thus "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by simp
qed

lemma church_rosser_var: "y \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by fastforce

lemma church_rosser_to_confluence: "(x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis add_comm eq_iff star_subdist_var_3)

lemma church_rosser_equiv: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<longleftrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  using church_rosser_to_confluence eq_iff by blast

lemma confluence_to_local_confluence: "y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> y \<cdot> x \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (meson mult_isol_var order_trans star_ext)

lemma "y \<cdot> x \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> y\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

lemma "y \<cdot> x \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  (* nitpick [expect=genuine] *) oops

text \<open>
More variations could easily be proved. The last counterexample shows
that Newman's lemma needs a wellfoundedness assumption. This is well
known.
\<close>

text \<open>The next lemmas relate the reflexive transitive closure and
the transitive closure.\<close>

lemma sup_id_star1: "1 \<le> x \<Longrightarrow> x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof -
  assume "1 \<le> x"
  hence " x\<^sup>\<star> \<le> x \<cdot> x\<^sup>\<star>"
    using mult_isor by fastforce
  thus "x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (simp add: eq_iff)
qed

lemma sup_id_star2: "1 \<le> x \<Longrightarrow> x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  by (metis order.antisym mult_isol mult_oner star_1r)

lemma "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
(*nitpick [expect=genuine]*)
  oops

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

lemma "x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
(* nitpick [expect=genuine] *)
  oops

end (* left_pre_kleene_algebra *)

subsection \<open>Left Kleene Algebras\<close>

class left_kleene_algebra = left_pre_kleene_algebra + dioid_one

begin

text \<open>In left Kleene algebras the non-fact @{prop "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"}
is a good challenge for counterexample generators. A model of left
Kleene algebras in which the right star induction law does not hold
has been given by Kozen~\cite{kozen90kleene}.\<close>

text \<open>We now show that the right unfold law becomes an equality.\<close>

lemma star_unfoldr_eq [simp]: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
proof (rule antisym)
  show "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
    by (fact star_unfoldr)
  have "1 + x \<cdot> (1 + x\<^sup>\<star> \<cdot> x) = 1 + (1 + x \<cdot> x\<^sup>\<star>) \<cdot> x"
    using distrib_left distrib_right mult_1_left mult_1_right mult_assoc by presburger
  also have "... = 1 + x\<^sup>\<star> \<cdot> x"
    by simp
  finally show "x\<^sup>\<star> \<le> 1 + x\<^sup>\<star> \<cdot> x"
    by (simp add: star_inductl_one)
qed

text \<open>The following more complex unfold law has been used as an
axiom, called prodstar, by Conway~\cite{conway71regular}.\<close>

lemma star_prod_unfold [simp]: "1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y = (x \<cdot> y)\<^sup>\<star>"
proof (rule antisym)
  have "(x \<cdot> y)\<^sup>\<star> = 1 + (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y"
    by (simp add: mult_assoc)
  thus "(x \<cdot> y)\<^sup>\<star> \<le> 1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y"
    by (metis join.sup_mono mult_isor order_refl star_slide1)
  have "1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<le> 1 + x \<cdot> y \<cdot>  (x \<cdot> y)\<^sup>\<star>"
    by (metis join.sup_mono eq_refl mult.assoc mult_isol star_slide1)
  thus "1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<le> (x \<cdot> y)\<^sup>\<star>"
    by simp
qed

text \<open>The slide laws, which have previously been inequalities, now
become equations.\<close>

lemma star_slide [ac_simps]: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
proof -
  have "x \<cdot> (y \<cdot> x)\<^sup>\<star> = x \<cdot> (1 + y \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> x)"
    by simp
  also have "... = (1 + x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<star>) \<cdot> x"
    by (simp add: distrib_left mult_assoc)
  finally show ?thesis
    by simp
qed

lemma star_slide_var [ac_simps]: "x\<^sup>\<star> \<cdot> x = x \<cdot> x\<^sup>\<star>"
  by (metis mult_onel mult_oner star_slide)

lemma star_sum_unfold_var [simp]: "1 + x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star> \<cdot> y\<^sup>\<star> = (x + y)\<^sup>\<star>"
  by (metis star_denest star_denest_var_3 star_denest_var_4 star_plus_one star_slide)

text \<open>The following law shows how starred sums can be unfolded.\<close>

lemma star_sum_unfold [simp]: "x\<^sup>\<star> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<star> = (x + y)\<^sup>\<star>"
proof -
  have "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star> )\<^sup>\<star>"
    by simp
  also have "... = x\<^sup>\<star> \<cdot> (1 + y \<cdot> x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star> )\<^sup>\<star>)"
    by simp
  also have "... = x\<^sup>\<star> \<cdot> (1 + y \<cdot> (x + y)\<^sup>\<star>)"
    by (simp add: mult.assoc)
  finally show ?thesis
    by (simp add: distrib_left mult_assoc)
qed

text \<open>The following property appears in process algebra.\<close>

lemma troeger: "(x + y)\<^sup>\<star> \<cdot> z = x\<^sup>\<star> \<cdot> (y \<cdot> (x + y)\<^sup>\<star> \<cdot> z + z)"
proof -
  have "(x + y)\<^sup>\<star> \<cdot> z = x\<^sup>\<star> \<cdot> z + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<star> \<cdot> z"
    by (metis (full_types) distrib_right star_sum_unfold)
  thus ?thesis
    by (simp add: add_commute distrib_left mult_assoc)
qed

text \<open>The following properties are related to a property from
propositional dynamic logic which has been attributed to Albert
Meyer~\cite{harelkozentiuryn00dynamic}. Here we prove it as a theorem
of Kleene algebra.\<close>

lemma star_square: "(x \<cdot> x)\<^sup>\<star> \<le> x\<^sup>\<star>"
proof -
  have "x \<cdot> x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: prod_star_closure)
  thus ?thesis
    by (simp add: star_inductl_star)
qed

lemma meyer_1 [simp]: "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> = x\<^sup>\<star>"
proof (rule antisym)
  have "x \<cdot>  (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> = x \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (simp add: distrib_left)
  also have "... \<le> x \<cdot> (x \<cdot> x)\<^sup>\<star> + (x \<cdot> x)\<^sup>\<star>"
    using join.sup_mono star_1l by blast
  finally have "x \<cdot>  (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (simp add: join.sup_commute)
  moreover have "1 \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    using join.sup.coboundedI1 by auto
  ultimately have "1 + x \<cdot> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by auto
  thus "x\<^sup>\<star> \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (simp add: star_inductl_one mult_assoc)
  show "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (simp add: prod_star_closure star_square)
qed

text \<open>The following lemma says that transitive elements are equal to
their transitive closure.\<close>

lemma tc: "x \<cdot> x \<le> x \<Longrightarrow> x\<^sup>\<star> \<cdot> x = x"
proof -
  assume "x \<cdot> x \<le> x"
  hence "x + x \<cdot> x \<le> x"
    by simp
  hence "x\<^sup>\<star> \<cdot> x \<le> x"
    by (fact star_inductl)
  thus  "x\<^sup>\<star> \<cdot> x = x"
    by (metis mult_isol mult_oner star_ref star_slide_var eq_iff)
qed

lemma tc_eq: "x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> \<cdot> x = x"
  by (auto intro: tc)

text \<open>The next fact has been used by Boffa~\cite{boffa90remarque} to
axiomatise the equational theory of regular expressions.\<close>

lemma boffa_var: "x \<cdot> x \<le> x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
proof -
  assume "x \<cdot> x \<le> x"
  moreover have "x\<^sup>\<star> = 1 + x\<^sup>\<star> \<cdot> x"
    by simp
  ultimately show "x\<^sup>\<star> = 1 + x"
    by (simp add: tc)
qed

lemma boffa: "x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
  by (auto intro: boffa_var)

(*
text {*
For the following two lemmas, Isabelle could neither find a
counterexample nor a proof automatically.
*}

lemma "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
  -- "unfortunately, no counterexample found"
oops

lemma star_sim3: "z \<cdot> x = y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> = y\<^sup>\<star> \<cdot> z"
  -- "we conjecture that this is not provable"
oops
*)

end (* left_kleene_algebra *)

subsection \<open>Left Kleene Algebras with Zero\<close>

text \<open>
There are applications where only a left zero is assumed, for instance
in the context of total correctness and for demonic refinement
algebras~\cite{vonwright04refinement}.
\<close>

class left_kleene_algebra_zerol = left_kleene_algebra + dioid_one_zerol
begin

sublocale conway: near_conway_base_zerol star
  by standard (simp_all add: local.star_slide)

lemma star_zero [simp]: "0\<^sup>\<star> = 1"
  by (rule local.conway.zero_dagger)

text \<open>
In principle,~$1$ could therefore be defined from~$0$ in this setting.
\<close>

end (* left_kleene_algebra_zerol *)

class left_kleene_algebra_zero = left_kleene_algebra_zerol + dioid_one_zero

subsection \<open>Pre-Kleene Algebras\<close>

text \<open>Pre-Kleene algebras are essentially probabilistic Kleene
algebras~\cite{mciverweber05pka}.  They have a weaker right star
unfold axiom. We are still looking for theorems that could be proved
in this setting.\<close>

class pre_kleene_algebra = left_pre_kleene_algebra +
  assumes weak_star_unfoldr: "z + y \<cdot> (x + 1) \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

subsection \<open>Kleene Algebras\<close>

class kleene_algebra_zerol = left_kleene_algebra_zerol +
  assumes star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim2: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
proof -
  assume "z \<cdot> x \<le> y \<cdot> z"
  hence "y\<^sup>\<star> \<cdot> z \<cdot> x \<le> y\<^sup>\<star> \<cdot> y \<cdot> z"
    using mult_isol mult_assoc by auto
  also have "... \<le> y\<^sup>\<star> \<cdot> z"
    by (simp add: mult_isor)
  finally have "y\<^sup>\<star> \<cdot> z \<cdot> x \<le> y\<^sup>\<star> \<cdot> z"
    by simp
  moreover have "z \<le> y\<^sup>\<star> \<cdot> z"
    using mult_isor star_ref by fastforce
  ultimately have "z + y\<^sup>\<star> \<cdot> z \<cdot> x \<le> y\<^sup>\<star> \<cdot> z"
    by simp
  thus "z \<cdot> x\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> z"
    by (simp add: star_inductr)
qed

sublocale conway: pre_conway star
  by standard (simp add: star_sim2)

lemma star_inductr_var: "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  by (simp add: star_inductr)

lemma star_inductr_var_equiv: "y \<cdot> x \<le> y \<longleftrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  by (meson order_trans mult_isol star_ext star_inductr_var)

lemma star_sim3: "z \<cdot> x = y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<star> = y\<^sup>\<star> \<cdot> z"
  by (simp add: eq_iff star_sim1 star_sim2)

lemma star_sim4: "x \<cdot> y \<le>  y \<cdot> x \<Longrightarrow> x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> y\<^sup>\<star> \<cdot> x\<^sup>\<star>"
  by (auto intro: star_sim1 star_sim2)

lemma star_inductr_eq: "z + y \<cdot> x = y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
  by (auto intro: star_inductr)

lemma star_inductr_var_eq: "y \<cdot> x = y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
  by (auto intro: star_inductr_var)

lemma star_inductr_var_eq2: "y \<cdot> x = y \<Longrightarrow> y \<cdot> x\<^sup>\<star> = y"
  by (metis mult_onel star_one star_sim3)

lemma bubble_sort: "y \<cdot> x \<le> x \<cdot> y \<Longrightarrow> (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (fastforce intro: star_sim4)

lemma independence1: "x \<cdot> y = 0 \<Longrightarrow> x\<^sup>\<star> \<cdot> y = y"
proof -
  assume "x \<cdot> y = 0"
  moreover have "x\<^sup>\<star> \<cdot> y = y + x\<^sup>\<star> \<cdot> x \<cdot> y"
    by (metis distrib_right mult_onel star_unfoldr_eq)
  ultimately show "x\<^sup>\<star> \<cdot> y = y"
    by (metis add_0_left add.commute join.sup_ge1 eq_iff star_inductl_eq)
qed

lemma independence2: "x \<cdot> y = 0 \<Longrightarrow> x \<cdot> y\<^sup>\<star> = x"
  by (metis annil mult_onel star_sim3 star_zero)

lemma lazycomm_var: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> + y \<longleftrightarrow> y \<cdot> x\<^sup>\<star> \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
proof
  let ?t = "x \<cdot> (x + y)\<^sup>\<star>"
  assume hyp: "y \<cdot> x \<le> ?t + y"
  have "(?t + y) \<cdot> x = ?t \<cdot> x + y \<cdot> x"
    by (fact distrib_right)
  also have "... \<le> ?t \<cdot> x + ?t + y"
    using hyp join.sup.coboundedI2 join.sup_assoc by auto
  also have "... \<le> ?t + y"
    using eq_refl join.sup_least join.sup_mono mult_isol prod_star_closure star_subdist_var_1 mult_assoc by presburger
  finally have "y + (?t + y) \<cdot> x \<le> ?t + y"
    by simp
  thus "y \<cdot> x\<^sup>\<star> \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
    by (fact star_inductr)
next
  assume "y \<cdot> x\<^sup>\<star> \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
  thus "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
    using dual_order.trans mult_isol star_ext by blast
qed

lemma arden_var: "(\<forall>y v. y \<le> x \<cdot> y + v \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> v) \<Longrightarrow> z = x \<cdot> z + w \<Longrightarrow> z = x\<^sup>\<star> \<cdot> w"
  by (auto simp: add_comm eq_iff star_inductl_eq)

lemma "(\<forall>x y. y \<le> x \<cdot> y \<longrightarrow> y = 0) \<Longrightarrow> y \<le> x \<cdot> y + z \<Longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z"
  by (metis eq_refl mult_onel)

end

text \<open>Finally, here come the Kleene algebras \`a~la
Kozen~\cite{kozen94complete}. We only prove quasi-identities in this
section. Since left Kleene algebras are complete with respect to the
equational theory of regular expressions and regular languages, all
identities hold already without the right star induction axiom.\<close>

class kleene_algebra = left_kleene_algebra_zero +
  assumes star_inductr': "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
begin

subclass kleene_algebra_zerol
  by standard (simp add: star_inductr')

sublocale conway_zerol: conway star ..

text \<open>
The next lemma shows that opposites of Kleene algebras (i.e., Kleene
algebras with the order of multiplication swapped) are again Kleene
algebras.
\<close>

lemma dual_kleene_algebra:
  "class.kleene_algebra (+) (\<odot>) 1 0 (\<le>) (<) star"
proof
  fix x y z :: 'a
  show "(x \<odot> y) \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis opp_mult_def distrib_left)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (fact add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
   show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "x + x = x"
    by (fact add_idem)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "z \<odot> x \<le> z \<odot> (x + y)"
    by (metis mult_isor opp_mult_def order_prop)
  show "1 + x \<odot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis opp_mult_def order_refl star_slide_var star_unfoldl_eq)
  show "z + x \<odot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<odot> z \<le> y"
    by (metis opp_mult_def star_inductr)
  show "z + y \<odot> x \<le> y \<Longrightarrow> z \<odot> x\<^sup>\<star> \<le> y"
    by (metis opp_mult_def star_inductl)
qed

end (* kleene_algebra *)

text \<open>We finish with some properties on (multiplicatively)
commutative Kleene algebras. A chapter in Conway's
book~\cite{conway71regular} is devoted to this topic.\<close>

class commutative_kleene_algebra = kleene_algebra +
  assumes mult_comm [ac_simps]: "x \<cdot> y = y \<cdot> x"

begin

lemma conway_c3 [simp]: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  using church_rosser mult_comm by auto

lemma conway_c4: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> = 1 + x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> y"
  by (metis conway_c3 star_denest_var star_prod_unfold)

lemma cka_1: "(x \<cdot> y)\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis conway_c3 star_invol star_iso star_subdist_var_2)

lemma cka_2 [simp]: "x\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis conway_c3 mult_comm star_denest_var)

lemma conway_c4_var [simp]: "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis conway_c3 star_invol)

lemma conway_c2_var: "(x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y \<cdot> y\<^sup>\<star> \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis mult_isor star_1r mult_assoc)

lemma conway_c2 [simp]: "(x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>) = x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
proof (rule antisym)
  show "(x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>) \<le> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    by (metis cka_1 conway_c3 prod_star_closure star_ext star_sum_var)
  have "x \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>) = x \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + 1 + y \<cdot> y\<^sup>\<star>)"
    by (simp add: add_assoc)
  also have "... = x \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y \<cdot> y\<^sup>\<star>)"
    by (simp add: add_commute)
  also have "... = (x \<cdot> y)\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>) + (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y \<cdot> y\<^sup>\<star>"
    using distrib_left mult_comm mult_assoc by force
  also have "... \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star> + (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y \<cdot> y\<^sup>\<star>"
    using add_iso mult_isol by force
  also have "... \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star> + (x \<cdot> y)\<^sup>\<star> \<cdot> y\<^sup>\<star>"
    using conway_c2_var join.sup_mono by blast
  also have "... = (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>)"
    by (simp add: distrib_left)
  finally have "x \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>) \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>)" .
  moreover have "y\<^sup>\<star> \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>)"
    by (metis dual_order.trans join.sup_ge2 mult_1_left mult_isor star_ref)
  ultimately have "y\<^sup>\<star> + x \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>) \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>)"
    by simp
  thus "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> (x\<^sup>\<star> + y\<^sup>\<star>)"
    by (simp add: mult.assoc star_inductl)
qed

end (* commutative_kleene_algebra *)

end