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

section \<open>Kleene Algebras\<close>

text \<open>
Kleene algebras have been axiomatised by Kozen to describe the equational theory of regular languages \<^cite>\<open>"Kozen1994"\<close>.
Binary relations are another important model.
This theory implements variants of Kleene algebras based on idempotent left semirings \<^cite>\<open>"Moeller2007"\<close>.
The weakening of some semiring axioms allows the treatment of further computation models.
The presented algebras are special cases of iterings, so many results can be inherited.
\<close>

theory Kleene_Algebras

imports Iterings

begin

text \<open>
We start with left Kleene algebras, which use the left unfold and left induction axioms of Kleene algebras.
\<close>

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

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

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

abbreviation tc ("_\<^sup>+" [100] 100) where "tc x \<equiv> x * x\<^sup>\<star>"

lemma star_left_unfold_equal:
  "1 \<squnion> x * x\<^sup>\<star> = x\<^sup>\<star>"
  by (metis sup_right_isotone order.antisym mult_right_isotone mult_1_right star_left_induct star_left_unfold)

text \<open>
This means that for some properties of Kleene algebras, only one inequality can be derived, as exemplified by the following sliding rule.
\<close>

lemma star_left_slide:
  "(x * y)\<^sup>\<star> * x \<le> x * (y * x)\<^sup>\<star>"
  by (metis mult_assoc mult_left_sub_dist_sup mult_1_right star_left_induct star_left_unfold_equal)

lemma star_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  by (metis sup_right_isotone mult_left_isotone order_trans star_left_unfold mult_1_right star_left_induct)

lemma star_sup_1:
  "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
proof (rule order.antisym)
  have "y * x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> (y * x\<^sup>\<star>)\<^sup>\<star>"
    using sup_right_divisibility star_left_unfold_equal by auto
  also have "... \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using mult_left_isotone sup_left_divisibility star_left_unfold_equal by fastforce
  finally have "(x \<squnion> y) * (x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>) \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    by (metis le_supI mult_right_dist_sup mult_right_sub_dist_sup_right mult_assoc star_left_unfold_equal)
  hence "1 \<squnion> (x \<squnion> y) * (x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>) \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using reflexive_mult_closed star_left_unfold by auto
  thus "(x \<squnion> y)\<^sup>\<star> \<le> x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
    using star_left_induct by force
next
  have "x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> x\<^sup>\<star> * (y * (x \<squnion> y)\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_right_isotone star_isotone)
  also have "... \<le> x\<^sup>\<star> * ((x \<squnion> y) * (x \<squnion> y)\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: mult_right_isotone mult_right_sub_dist_sup_right star_isotone)
  also have "... \<le> x\<^sup>\<star> * (x \<squnion> y)\<^sup>\<star>\<^sup>\<star>"
    using mult_right_isotone star_left_unfold star_isotone by auto
  also have "... \<le> (x \<squnion> y)\<^sup>\<star> * (x \<squnion> y)\<^sup>\<star>\<^sup>\<star>"
    by (simp add: mult_left_isotone star_isotone)
  also have "... \<le> (x \<squnion> y)\<^sup>\<star>"
    by (metis sup.bounded_iff mult_1_right star_left_induct star_left_unfold)
  finally show "x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<star>"
    by simp
qed

end

text \<open>
We now show that left Kleene algebras form iterings.
A sublocale is used instead of a subclass, because iterings use a different iteration operation.
\<close>

sublocale left_kleene_algebra < star: left_conway_semiring where circ = star
  apply unfold_locales
  apply (rule star_left_unfold_equal)
  apply (rule star_left_slide)
  by (rule star_sup_1)

context left_kleene_algebra
begin

text \<open>
A number of lemmas in this class are taken from Georg Struth's Kleene algebra theory \<^cite>\<open>"ArmstrongGomesStruthWeber2016"\<close>.
\<close>

lemma star_sub_one:
  "x \<le> 1 \<Longrightarrow> x\<^sup>\<star> = 1"
  by (metis sup_right_isotone order.eq_iff le_iff_sup mult_1_right star.circ_plus_one star_left_induct)

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

lemma star_left_induct_mult:
  "x * y \<le> y \<Longrightarrow> x\<^sup>\<star> * y \<le> y"
  by (simp add: star_left_induct)

lemma star_left_induct_mult_iff:
  "x * y \<le> y \<longleftrightarrow> x\<^sup>\<star> * y \<le> y"
  using mult_left_isotone order_trans star.circ_increasing star_left_induct_mult by blast

lemma star_involutive:
  "x\<^sup>\<star> = x\<^sup>\<star>\<^sup>\<star>"
  using star.circ_circ_sup star_sup_1 star_one by auto

lemma star_sup_one:
  "(1 \<squnion> x)\<^sup>\<star> = x\<^sup>\<star>"
  using star.circ_circ_sup star_involutive by auto

lemma star_plus_loops:
  "x\<^sup>\<star> \<squnion> 1 = x\<^sup>+ \<squnion> 1"
  using star.circ_plus_one star_left_unfold_equal sup_commute by auto

lemma star_left_induct_equal:
  "z \<squnion> x * y = y \<Longrightarrow> x\<^sup>\<star> * z \<le> y"
  by (simp add: star_left_induct)

lemma star_left_induct_mult_equal:
  "x * y = y \<Longrightarrow> x\<^sup>\<star> * y \<le> y"
  by (simp add: 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>"
  using star_involutive by auto

lemma star_simulation_left:
  assumes "x * z \<le> z * y"
    shows "x\<^sup>\<star> * z \<le> z * y\<^sup>\<star>"
proof -
  have "x * z * y\<^sup>\<star> \<le> z * y * y\<^sup>\<star>"
    by (simp add: assms mult_left_isotone)
  also have "... \<le> z * y\<^sup>\<star>"
    by (simp add: mult_right_isotone star.left_plus_below_circ mult_assoc)
  finally have "z \<squnion> x * z * y\<^sup>\<star> \<le> z * y\<^sup>\<star>"
    using star.circ_back_loop_prefixpoint by auto
  thus ?thesis
    by (simp add: star_left_induct mult_assoc)
qed

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

lemma star_rtc_3:
  "1 \<squnion> x \<squnion> y * y = y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  by (metis sup.bounded_iff le_iff_sup mult_left_sub_dist_sup_left mult_1_right star_left_induct_mult_iff star.circ_sub_dist)

lemma star_decompose_1:
  "(x \<squnion> y)\<^sup>\<star> = (x\<^sup>\<star> * y\<^sup>\<star>)\<^sup>\<star>"
  apply (rule order.antisym)
  apply (simp add: star.circ_sup_2)
  using star.circ_sub_dist_3 star_isotone star_involutive by fastforce

lemma star_sum:
  "(x \<squnion> y)\<^sup>\<star> = (x\<^sup>\<star> \<squnion> y\<^sup>\<star>)\<^sup>\<star>"
  using star_decompose_1 star_involutive by auto

lemma star_decompose_3:
  "(x\<^sup>\<star> * y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> * (y * x\<^sup>\<star>)\<^sup>\<star>"
  using star_sup_1 star_decompose_1 by auto

text \<open>
In contrast to iterings, we now obtain that the iteration operation results in least fixpoints.
\<close>

lemma star_loop_least_fixpoint:
  "y * x \<squnion> z = x \<Longrightarrow> y\<^sup>\<star> * z \<le> x"
  by (simp add: sup_commute star_left_induct_equal)

lemma star_loop_is_least_fixpoint:
  "is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<star> * z)"
  by (simp add: is_least_fixpoint_def star.circ_loop_fixpoint star_loop_least_fixpoint)

lemma star_loop_mu:
  "\<mu> (\<lambda>x . y * x \<squnion> 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 \<squnion> z)"
  by (metis has_least_fixpoint_def star_loop_is_least_fixpoint)

lemma star_outer_increasing:
  "x \<le> y\<^sup>\<star> * x * y\<^sup>\<star>"
  by (metis star.circ_back_loop_prefixpoint star.circ_loop_fixpoint sup.boundedE)

(*
lemma circ_sup: "(x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> = (x \<squnion> y)\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_mult: "1 \<squnion> 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 \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * (x \<squnion> y)\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma mult_zero_sup_circ_2: "(x \<squnion> y * bot)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * bot" nitpick [expect=genuine,card=7] oops
lemma circ_simulate_left: "x * z \<le> z * y \<squnion> w \<longrightarrow> x\<^sup>\<star> * z \<le> (z \<squnion> 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 \<squnion> 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 = bot \<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 \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<star> * q \<le> s * (x * b\<^sup>\<star> * q \<squnion> r \<squnion> l)\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<star> \<squnion> w \<longrightarrow> x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>" nitpick [expect=genuine] oops
lemma circ_separate_unfold: "(y * x\<^sup>\<star>)\<^sup>\<star> = y\<^sup>\<star> \<squnion> 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 \<squnion> 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 \<squnion> 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 \<squnion> 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 \<squnion> 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 \<squnion> y) \<longrightarrow> (x \<squnion> 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 \<squnion> y) \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
lemma circ_separate_6: "y * x \<le> x * (x \<squnion> y) \<longrightarrow> (x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> * y\<^sup>\<star>" nitpick [expect=genuine,card=7] oops
*)

end

text \<open>
We next add the right induction rule, which allows us to strengthen many inequalities of left Kleene algebras to equalities.
\<close>

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

lemma star_plus:
  "y\<^sup>\<star> * y = y * y\<^sup>\<star>"
proof (rule order.antisym)
  show "y\<^sup>\<star> * y \<le> y * y\<^sup>\<star>"
    by (simp add: star.circ_plus_sub)
next
  have "y\<^sup>\<star> * y * y \<le> y\<^sup>\<star> * y"
    by (simp add: mult_left_isotone star.right_plus_below_circ)
  hence "y \<squnion> y\<^sup>\<star> * y * y \<le> y\<^sup>\<star> * y"
    by (simp add: star.circ_mult_increasing_2)
  thus "y * y\<^sup>\<star> \<le> y\<^sup>\<star> * y"
    using star_right_induct by blast
qed

lemma star_slide:
  "(x * y)\<^sup>\<star> * x = x * (y * x)\<^sup>\<star>"
proof (rule order.antisym)
  show "(x * y)\<^sup>\<star> * x \<le> x * (y * x)\<^sup>\<star>"
    by (rule star_left_slide)
next
  have "x \<squnion> (x * y)\<^sup>\<star> * x * y * x \<le> (x * y)\<^sup>\<star> * x"
    by (metis (full_types) sup.commute eq_refl star.circ_loop_fixpoint mult.assoc star_plus)
  thus "x * (y * x)\<^sup>\<star> \<le> (x * y)\<^sup>\<star> * x"
    by (simp add: mult_assoc star_right_induct)
qed

lemma star_simulation_right:
  assumes "z * x \<le> y * z"
    shows "z * x\<^sup>\<star> \<le> y\<^sup>\<star> * z"
proof -
  have "y\<^sup>\<star> * z * x \<le> y\<^sup>\<star> * z"
    by (metis assms dual_order.trans mult_isotone mult_left_sub_dist_sup_right star.circ_loop_fixpoint star.circ_transitive_equal sup.cobounded1 mult_assoc)
  thus ?thesis
    by (metis le_supI star.circ_loop_fixpoint star_right_induct sup.cobounded2)
qed

end

text \<open>
Again we inherit results from the itering hierarchy.
\<close>

sublocale strong_left_kleene_algebra < star: itering_1 where circ = star
  apply unfold_locales
  apply (simp add: star_slide)
  by (simp add: star_simulation_right)

context strong_left_kleene_algebra
begin

lemma star_right_induct_mult:
  "y * x \<le> y \<Longrightarrow> y * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct)

lemma star_right_induct_mult_iff:
  "y * x \<le> y \<longleftrightarrow> y * x\<^sup>\<star> \<le> y"
  using mult_right_isotone order_trans star.circ_increasing star_right_induct_mult by blast

lemma star_simulation_right_equal:
  "z * x = y * z \<Longrightarrow> z * x\<^sup>\<star> = y\<^sup>\<star> * z"
  by (metis order.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 (simp add: star_simulation_left star_simulation_right)

lemma star_right_induct_equal:
  "z \<squnion> y * x = y \<Longrightarrow> z * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct)

lemma star_right_induct_mult_equal:
  "y * x = y \<Longrightarrow> y * x\<^sup>\<star> \<le> y"
  by (simp add: star_right_induct_mult)

lemma star_back_loop_least_fixpoint:
  "x * y \<squnion> z = x \<Longrightarrow> z * y\<^sup>\<star> \<le> x"
  by (simp add: sup_commute star_right_induct_equal)

lemma star_back_loop_is_least_fixpoint:
  "is_least_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<star>)"
proof (unfold is_least_fixpoint_def, rule conjI)
  have "(z * y\<^sup>\<star> * y \<squnion> z) * y \<le> z * y\<^sup>\<star> * y \<squnion> z"
    using le_supI1 mult_left_isotone star.circ_back_loop_prefixpoint by auto
  hence "z * y\<^sup>\<star> \<le> z * y\<^sup>\<star> * y \<squnion> z"
    by (simp add: star_right_induct)
  thus "z * y\<^sup>\<star> * y \<squnion> z = z * y\<^sup>\<star>"
    using order.antisym star.circ_back_loop_prefixpoint by auto
next
  show "\<forall>x. x * y \<squnion> z = x \<longrightarrow> z * y\<^sup>\<star> \<le> x"
    by (simp add: star_back_loop_least_fixpoint)
qed

lemma star_square:
  "x\<^sup>\<star> = (1 \<squnion> x) * (x * x)\<^sup>\<star>"
proof -
  let ?f = "\<lambda>y . y * x \<squnion> 1"
  have 1: "isotone ?f"
    by (metis sup_left_isotone isotone_def mult_left_isotone)
  have "?f \<circ> ?f = (\<lambda>y . y * (x * x) \<squnion> (1 \<squnion> x))"
    by (simp add: sup_assoc sup_commute mult_assoc mult_right_dist_sup 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 \<squnion> 1)"
proof -
  have "(1 \<squnion> x) * (x * x)\<^sup>\<star> = (x * x)\<^sup>\<star> * 1 \<squnion> x * (x * x)\<^sup>\<star>"
    using mult_right_dist_sup by force
  thus ?thesis
    by (metis (no_types) order.antisym mult_left_sub_dist_sup star.circ_square_2 star_slide sup_commute star_square)
qed

lemma star_circ_simulate_right_plus:
  assumes "z * x \<le> y * y\<^sup>\<star> * z \<squnion> w"
    shows "z * x\<^sup>\<star> \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
proof -
  have "(z \<squnion> w * x\<^sup>\<star>) * x \<le> z * x \<squnion> w * x\<^sup>\<star>"
    using mult_right_dist_sup star.circ_back_loop_prefixpoint sup_right_isotone by auto
  also have "... \<le> y * y\<^sup>\<star> * z \<squnion> w \<squnion> w * x\<^sup>\<star>"
    using assms sup_left_isotone by blast
  also have "... \<le> y * y\<^sup>\<star> * z \<squnion> w * x\<^sup>\<star>"
    using le_supI1 star.circ_back_loop_prefixpoint sup_commute by auto
  also have "... \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
    by (metis sup.bounded_iff mult_isotone mult_left_isotone mult_left_one mult_left_sub_dist_sup_left star.circ_reflexive star.left_plus_below_circ)
  finally have "y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>) * x \<le> y\<^sup>\<star> * (z \<squnion> w * x\<^sup>\<star>)"
    by (metis mult_assoc mult_right_isotone star.circ_transitive_equal)
  thus ?thesis
    by (metis sup.bounded_iff star_right_induct mult_left_sub_dist_sup_left star.circ_loop_fixpoint)
qed

lemma transitive_star:
  "x * x \<le> x \<Longrightarrow> x\<^sup>\<star> = 1 \<squnion> x"
  by (metis order.antisym star.circ_mult_increasing_2 star.circ_plus_same star_left_induct_mult star_left_unfold_equal)

lemma star_sup_2:
  assumes "x * x \<le> x"
    and "x * y \<le> x"
  shows "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * (x \<squnion> 1)"
proof -
  have "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * (x * y\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star.circ_decompose_6 star_sup_1)
  also have "... = y\<^sup>\<star> * x\<^sup>\<star>"
    using assms(2) dual_order.antisym star.circ_back_loop_prefixpoint star_right_induct_mult by fastforce
  also have "... = y\<^sup>\<star> * (x \<squnion> 1)"
    by (simp add: assms(1) sup_commute transitive_star)
  finally show ?thesis
    .
qed

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

end

text \<open>
The following class contains a generalisation of Kleene algebras, which lacks the right zero axiom.
\<close>

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 star.circ_transitive_equal star_slide mult_assoc)

lemma star_circ_simulate_left_plus:
  assumes "x * z \<le> z * y\<^sup>\<star> \<squnion> w"
    shows "x\<^sup>\<star> * z \<le> (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
proof -
  have "x * (x\<^sup>\<star> * (w * y\<^sup>\<star>)) \<le> x\<^sup>\<star> * (w * y\<^sup>\<star>)"
    by (metis (no_types) mult_right_sub_dist_sup_left star.circ_loop_fixpoint mult_assoc)
  hence "x * ((z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>) \<le> x * z * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    using mult_left_dist_sup mult_right_dist_sup sup_right_isotone mult_assoc by presburger
  also have "... \<le> (z * y\<^sup>\<star> \<squnion> w) * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    using assms mult_isotone semiring.add_right_mono by blast
  also have "... = z * y\<^sup>\<star> \<squnion> w * y\<^sup>\<star> \<squnion> x\<^sup>\<star> * w * y\<^sup>\<star>"
    by (simp add: mult_right_dist_sup star.circ_transitive_equal mult_assoc)
  also have "... = (z \<squnion> w \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
    by (simp add: mult_right_dist_sup)
  also have "... = (z \<squnion> x\<^sup>\<star> * w) * y\<^sup>\<star>"
    by (metis sup_assoc sup_ge2 le_iff_sup star.circ_loop_fixpoint)
  finally show ?thesis
    by (metis sup.bounded_iff mult_left_sub_dist_sup_left mult_1_right star.circ_right_unfold_1 star_left_induct)
qed

lemma star_one_sup_below:
  "x * y\<^sup>\<star> * (1 \<squnion> z) \<le> x * (y \<squnion> z)\<^sup>\<star>"
proof -
  have "y\<^sup>\<star> * z \<le> (y \<squnion> z)\<^sup>\<star>"
    using sup_ge2 order_trans star.circ_increasing star.circ_mult_upper_bound star.circ_sub_dist by blast
  hence "y\<^sup>\<star> \<squnion> y\<^sup>\<star> * z \<le> (y \<squnion> z)\<^sup>\<star>"
    by (simp add: star.circ_sup_upper_bound star.circ_sub_dist)
  hence "y\<^sup>\<star> * (1 \<squnion> z) \<le> (y \<squnion> z)\<^sup>\<star>"
    by (simp add: mult_left_dist_sup)
  thus ?thesis
    by (metis mult_right_isotone mult_assoc)
qed

text \<open>
The following theorem is similar to the puzzle where persons insert themselves always in the middle between two groups of people in a line.
Here, however, items in the middle annihilate each other, leaving just one group of items behind.
\<close>

lemma cancel_separate:
  assumes "x * y \<le> 1"
    shows "x\<^sup>\<star> * y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
proof -
  have "x * y\<^sup>\<star> = x \<squnion> x * y * y\<^sup>\<star>"
    by (metis mult_assoc mult_left_dist_sup mult_1_right star_left_unfold_equal)
  also have "... \<le> x \<squnion> y\<^sup>\<star>"
    by (meson assms dual_order.trans order.refl star.circ_mult_upper_bound star.circ_reflexive sup_right_isotone)
  also have "... \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using star.circ_increasing sup_left_isotone by auto
  finally have 1: "x * y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    .
  have "x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) = x * x\<^sup>\<star> \<squnion> x * y\<^sup>\<star>"
    by (simp add: mult_left_dist_sup)
  also have "... \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using 1 by (metis sup.bounded_iff sup_ge1 order_trans star.left_plus_below_circ)
  finally have 2: "x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    .
  have "y\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    by simp
  hence "y\<^sup>\<star> \<squnion> x * (x\<^sup>\<star> \<squnion> y\<^sup>\<star>) \<le> x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using 2 sup.bounded_iff by blast
  thus ?thesis
    by (metis star_left_induct)
qed

lemma star_separate:
  assumes "x * y = bot"
      and "y * y = bot"
    shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>"
proof -
  have 1: "y\<^sup>\<star> = 1 \<squnion> y"
    using assms(2) by (simp add: transitive_star)
  have "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * (x * y\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: star.circ_decompose_6 star_sup_1)
  also have "... = y\<^sup>\<star> * (x * (1 \<squnion> y * y\<^sup>\<star>))\<^sup>\<star>"
    by (simp add: star_left_unfold_equal)
  also have "... = (1 \<squnion> y) * x\<^sup>\<star>"
    using 1 by (simp add: assms mult_left_dist_sup)
  also have "... = x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>"
    by (simp add: mult_right_dist_sup)
  finally show ?thesis
    .
qed

end

text \<open>
We can now inherit from the strongest variant of iterings.
\<close>

sublocale left_zero_kleene_algebra < star: itering where circ = star
  apply unfold_locales
  apply (metis star.circ_sup_9)
  apply (metis star.circ_mult_1)
  apply (simp add: star_circ_simulate_right_plus)
  by (simp add: star_circ_simulate_left_plus)

context left_zero_kleene_algebra
begin

lemma star_absorb:
  "x * y = bot \<Longrightarrow> x * y\<^sup>\<star> = x"
  by (metis sup.bounded_iff antisym_conv star.circ_back_loop_prefixpoint star.circ_elimination)

lemma star_separate_2:
  assumes "x * z\<^sup>+ * y = bot"
      and "y * z\<^sup>+ * y = bot"
      and "z * x = bot"
    shows "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
proof -
  have 1: "x\<^sup>\<star> * z\<^sup>+ * y = z\<^sup>+ * y"
    by (metis assms mult_assoc mult_1_left mult_left_zero star.circ_zero star_simulation_right_equal)
  have 2: "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: mult_right_isotone star.left_plus_below_circ)
  have "z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<le> z\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis mult_left_isotone star.left_plus_below_circ star.right_plus_circ star_plus)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>)"
    by (simp add: mult_assoc mult_left_sub_dist_sup_right)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    using sup_right_divisibility star.circ_back_loop_fixpoint by blast
  finally have 3: "z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    .
  have "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> * (z * (1 \<squnion> y * x\<^sup>\<star>)) = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ * y * x\<^sup>\<star>"
    by (metis mult_1_right semiring.distrib_left star.circ_plus_same mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (1 \<squnion> y) * x\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star>"
    by (simp add: semiring.distrib_right mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * (1 \<squnion> y) * z\<^sup>+ * y * x\<^sup>\<star>"
    using 1 by (simp add: mult_assoc)
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star> \<squnion> z\<^sup>\<star> * y * z\<^sup>+ * y * x\<^sup>\<star>"
    using mult_left_dist_sup mult_right_dist_sup sup_assoc by auto
  also have "... = z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>+ \<squnion> z\<^sup>\<star> * z\<^sup>+ * y * x\<^sup>\<star>"
    by (metis assms(2) mult_left_dist_sup mult_left_zero sup_commute sup_monoid.add_0_left mult_assoc)
  also have "... \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    using 2 3 by simp
  finally have "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) \<squnion> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> * (z * (1 \<squnion> y * x\<^sup>\<star>)) \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: star_outer_increasing)
  hence 4: "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> \<le> z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star>"
    by (simp add: star_right_induct)
  have 5: "(x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis sup_ge1 mult_right_isotone mult_1_right star_isotone)
  have "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) = z * x\<^sup>\<star> \<squnion> z * y * x\<^sup>\<star>"
    by (simp add: mult_assoc mult_left_dist_sup)
  also have "... = z \<squnion> z * y * x\<^sup>\<star>"
    by (simp add: assms star_absorb)
  also have "... = z * (1 \<squnion> y * x\<^sup>\<star>)"
    by (simp add: mult_assoc mult_left_dist_sup)
  also have "... \<le> (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (simp add: star.circ_increasing)
  also have "... \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis le_supE mult_right_sub_dist_sup_left star.circ_loop_fixpoint)
  finally have "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    .
  hence "z * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    by (metis mult_assoc mult_left_isotone star.circ_transitive_equal)
  hence "z\<^sup>\<star> * (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * z\<^sup>\<star> \<le> (x\<^sup>\<star> \<squnion> y * x\<^sup>\<star>) * (z * (1 \<squnion> y * x\<^sup>\<star>))\<^sup>\<star>"
    using 5 by (metis star_left_induct sup.bounded_iff mult_assoc)
  thus ?thesis
    using 4 by (simp add: antisym)
qed

lemma cancel_separate_eq:
  "x * y \<le> 1 \<Longrightarrow> x\<^sup>\<star> * y\<^sup>\<star> = x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
  by (metis order.antisym cancel_separate star.circ_plus_one star.circ_sup_sub_sup_one_1 star_involutive)

lemma cancel_separate_1:
  assumes "x * y \<le> 1"
    shows "(x \<squnion> y)\<^sup>\<star> = y\<^sup>\<star> * x\<^sup>\<star>"
proof -
  have "y\<^sup>\<star> * x\<^sup>\<star> * y = y\<^sup>\<star> * x\<^sup>\<star> * x * y \<squnion> y\<^sup>\<star> * y"
    by (metis mult_right_dist_sup star.circ_back_loop_fixpoint)
  also have "... \<le> y\<^sup>\<star> * x\<^sup>\<star> \<squnion> y\<^sup>\<star> * y"
    by (metis assms semiring.add_right_mono mult_right_isotone mult_1_right mult_assoc)
  also have "... \<le> y\<^sup>\<star> * x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
    using semiring.add_left_mono star.right_plus_below_circ by simp
  also have "... = y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_back_loop_fixpoint sup.left_idem sup_commute)
  finally have "y\<^sup>\<star> * x\<^sup>\<star> * y \<le> y\<^sup>\<star> * x\<^sup>\<star>"
    by simp
  hence "y\<^sup>\<star> * x\<^sup>\<star> * (x \<squnion> y) \<le> y\<^sup>\<star> * x\<^sup>\<star> * x \<squnion> y\<^sup>\<star> * x\<^sup>\<star>"
    using mult_left_dist_sup order_lesseq_imp by fastforce
  also have "... = y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_back_loop_fixpoint sup.left_idem)
  finally have "(x \<squnion> y)\<^sup>\<star> \<le> y\<^sup>\<star> * x\<^sup>\<star>"
    by (metis star.circ_decompose_7 star_right_induct_mult sup_commute)
  thus ?thesis
    using order.antisym star.circ_sub_dist_3 sup_commute by fastforce
qed

lemma plus_sup:
  "(x \<squnion> y)\<^sup>+ = (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>+ \<squnion> (x\<^sup>\<star> * y)\<^sup>+"
  by (metis semiring.distrib_left star.circ_sup_9 star_plus mult_assoc)

lemma plus_half_bot:
  "x * y * x = bot \<Longrightarrow> (x * y)\<^sup>+ = x * y"
  by (metis star_absorb star_slide mult_assoc)

lemma cancel_separate_1_sup:
  assumes "x * y \<le> 1"
      and "y * x \<le> 1"
  shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> y\<^sup>\<star>"
  by (simp add: assms cancel_separate_1 cancel_separate_eq sup_commute)

text \<open>Lemma \<open>star_separate_3\<close> was contributed by Nicolas Robinson-O'Brien.\<close>

lemma star_separate_3:
  assumes "y * x\<^sup>\<star> * y \<le> y"
    shows "(x \<squnion> y)\<^sup>\<star> = x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star>"
proof (rule order.antisym)
  have "x\<^sup>\<star> * y * (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> \<le> x\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis assms mult_left_isotone mult_right_isotone star_right_induct_mult mult_assoc)
  thus "(x \<squnion> y)\<^sup>\<star> \<le> x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star>"
    by (metis order.antisym semiring.add_left_mono star.circ_sup_2 star.circ_sup_sub star.circ_unfold_sum star_decompose_3 star_slide mult_assoc)
next
  show "x\<^sup>\<star> \<squnion> x\<^sup>\<star> * y * x\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<star>"
    using mult_isotone star.circ_increasing star.circ_sub_dist star.circ_sup_9 by auto
qed

end

text \<open>
A Kleene algebra is obtained by requiring an idempotent semiring.
\<close>

class kleene_algebra = left_zero_kleene_algebra + idempotent_semiring

text \<open>
The following classes are variants of Kleene algebras expanded by an additional iteration operation.
This is useful to study the Kleene star in computation models that do not use least fixpoints in the refinement order as the semantics of recursion.
\<close>

class left_kleene_conway_semiring = left_kleene_algebra + left_conway_semiring
begin

lemma star_zero_below_circ_mult:
  "x\<^sup>\<star> * bot \<le> x\<^sup>\<circ> * y"
  by (simp add: mult_isotone star_below_circ)

lemma star_mult_circ:
  "x\<^sup>\<star> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_right_divisibility order.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 sup_assoc sup.bounded_iff circ_left_unfold circ_rtc_2 order.eq_iff left_plus_circ star.circ_sup_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 order.antisym circ_reflexive circ_transitive_equal star.circ_increasing star.circ_sup_one_right_unfold star_left_induct_mult_equal)

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

lemma circ_sup_3:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<star> \<le> (x \<squnion> y)\<^sup>\<circ>"
  using circ_star circ_sub_dist_3 star_isotone by fastforce

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> * bot \<squnion> x\<^sup>\<star>"
  by (metis sup_commute order.antisym circ_sup_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> * bot \<squnion> x\<^sup>\<star> * y"
  by (metis circ_isolate mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_isolate_mult_sub:
  "x\<^sup>\<circ> * y \<le> x\<^sup>\<circ> \<squnion> x\<^sup>\<star> * y"
  by (metis sup_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>"
proof -
  have "x\<^sup>\<star> * y \<squnion> x\<^sup>\<circ> * bot = x\<^sup>\<circ> * y"
    by (metis sup.commute circ_isolate_mult)
  hence "(x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ> = ((x\<^sup>\<circ> * y)\<^sup>\<circ> \<squnion> x\<^sup>\<circ>)\<^sup>\<star>"
    by (metis circ_star circ_sup_9 circ_sup_mult_zero star_decompose_1)
  thus ?thesis
    by (metis circ_star le_iff_sup star.circ_decompose_7 star.circ_unfold_sum)
qed

lemma circ_sup_4:
  "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  apply (rule order.antisym)
  apply (metis circ_sup circ_sub_decompose circ_transitive_equal mult_assoc mult_left_isotone)
  by (metis circ_sup circ_isotone mult_left_isotone star_below_circ)

lemma circ_sup_5:
  "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> = (x\<^sup>\<star> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  using circ_sup_4 circ_sup_9 by auto

lemma plus_circ:
  "(x\<^sup>\<star> * x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_idem circ_sup_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

text \<open>
The following classes add a greatest element.
\<close>

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 ..

text \<open>
We conclude with an alternative axiomatisation of Kleene algebras.
\<close>

class kleene_algebra_var = idempotent_semiring + star +
  assumes star_left_unfold_var : "1 \<squnion> y * y\<^sup>\<star> \<le> y\<^sup>\<star>"
  assumes star_left_induct_var : "y * x \<le> x \<longrightarrow> y\<^sup>\<star> * x \<le> x"
  assumes star_right_induct_var : "x * y \<le> x \<longrightarrow> x * y\<^sup>\<star> \<le> x"
begin

subclass kleene_algebra
  apply unfold_locales
  apply (rule star_left_unfold_var)
  apply (meson sup.bounded_iff mult_right_isotone order_trans star_left_induct_var)
  by (meson sup.bounded_iff mult_left_isotone order_trans star_right_induct_var)

end

end


theory SC_Depth
imports SC
begin

text\<open>
Many textbook arguments about SC use the depth of the derivation tree as basis for inductions.
We had originally thought that this is mandatory for the proof of contraction,
but found out it is not.
It remains unclear to us whether there is any proof on SC that requires an argument using depth.
\<close>
text\<open>
We keep our formalization of SC with depth for didactic reasons:
we think that arguments about depth do not need much meta-explanation,
but structural induction and rule induction usually need extra explanation
for students unfamiliar with Isabelle/HOL.
They are also a lot harder to execute.
We dare the reader to write down (a few of) the cases for, e.g. \<open>AndL_inv'\<close>, by hand.
\<close>

(* Warning: This theory may have name collisions with SC.thy\<dots> *)

inductive SCc :: "'a formula multiset \<Rightarrow> 'a formula multiset \<Rightarrow> nat \<Rightarrow> bool" ("((_ \<Rightarrow>/ _) \<down> _)" [53,53] 53) where
BotL: "\<bottom> \<in># \<Gamma> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta> \<down> Suc n" |
Ax: "Atom k \<in># \<Gamma> \<Longrightarrow> Atom k \<in># \<Delta> \<Longrightarrow> \<Gamma>\<Rightarrow>\<Delta> \<down> Suc n" |
NotL: "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<Longrightarrow> Not F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
NotR: "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Not F, \<Delta> \<down> Suc n" |
AndL: "F,G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> And F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
AndR: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n; \<Gamma> \<Rightarrow> G,\<Delta> \<down> n \<rbrakk> \<Longrightarrow> \<Gamma> \<Rightarrow> And F G, \<Delta> \<down> Suc n" |
OrL: "\<lbrakk> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n; G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<rbrakk> \<Longrightarrow> Or F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
OrR: "\<Gamma> \<Rightarrow> F,G,\<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Or F G, \<Delta> \<down> Suc n" |
ImpL: "\<lbrakk> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n; G,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<rbrakk> \<Longrightarrow> Imp F G, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" |
ImpR: "F,\<Gamma> \<Rightarrow> G,\<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Imp F G, \<Delta> \<down> Suc n"

lemma
  shows BotL_canonical'[intro!]: "\<bottom>,\<Gamma>\<Rightarrow>\<Delta> \<down> Suc n"
    and Ax_canonical'[intro!]: "Atom k,\<Gamma> \<Rightarrow> Atom k,\<Delta> \<down> Suc n"
  by (meson SCc.intros union_single_eq_member)+

lemma deeper: "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> n + m"
  by(induction rule: SCc.induct; insert SCc.intros; auto)
lemma deeper_suc: "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n"
  (* this version is actually required more often. It can be declared as an elim!, but I want to make its usage explicit *)
  thm deeper[unfolded Suc_eq_plus1[symmetric]]
  by(drule deeper[where m=1]) simp

text\<open>The equivalence is obvious.\<close>
theorem SC_SCp_eq:
  fixes \<Gamma> \<Delta> :: "'a formula multiset"
  shows "(\<exists>n. \<Gamma> \<Rightarrow> \<Delta> \<down> n) \<longleftrightarrow> \<Gamma> \<Rightarrow> \<Delta>" (is "?c \<longleftrightarrow> ?p")
proof
  assume ?c then guess n ..
  thus ?p by(induction rule: SCc.induct; simp add: SCp.intros)
next
  have deeper_max: "\<Gamma> \<Rightarrow> \<Delta> \<down> max m n" "\<Gamma> \<Rightarrow> \<Delta> \<down> max n m" if "\<Gamma> \<Rightarrow> \<Delta> \<down> n" for n m and \<Gamma> \<Delta> :: "'a formula multiset"
  proof -
    have "n \<le> m \<Longrightarrow> \<exists>k. m = n + k" by presburger
    with that[THEN deeper] that
    show "\<Gamma> \<Rightarrow> \<Delta> \<down> max n m" unfolding max_def by clarsimp
    thus "\<Gamma> \<Rightarrow> \<Delta> \<down> max m n" by (simp add: max.commute)
  qed
  assume ?p thus ?c by(induction rule: SCp.induct)
    (insert SCc.intros[where 'a='a] deeper_max; metis)+
qed

(* it makes a difference whether we say Ax is 0 or any: with Ax \<down> 0 we could not prove the deepening rules.
   Also, it is important to allow only atoms in Ax, otherwise the inv-rules are not depth preserving.
  Making Ax/BotL start from \<ge>1 saves proving the base-cases twice
 *)
lemma no_0_SC[dest!]: "\<Gamma> \<Rightarrow> \<Delta> \<down> 0 \<Longrightarrow> False"
  by(cases rule: SCc.cases[of \<Gamma> \<Delta> 0]) assumption

lemma inR1': "\<Gamma> \<Rightarrow> G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inL1': "G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inR2': "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> G, H, F, \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inL2': "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> G, H, F, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inR3': "\<Gamma> \<Rightarrow> F, G, H, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, F, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inR4': "\<Gamma> \<Rightarrow> F, G, H, I, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> H, I, F, G, \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inL3': "F, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, F, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
lemma inL4': "F, G, H, I, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> H, I, F, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(simp add: add_mset_commute)
lemmas SC_swap_applies[intro,elim!] = inL1' inL2' inL3' inL4' inR1' inR2' inR3' inR4'
  (* these are here because they can be used for more careful reasoning with intro *)

lemma "Atom C \<^bold>\<rightarrow> Atom D \<^bold>\<rightarrow> Atom E,
       Atom k \<^bold>\<rightarrow> Atom C \<^bold>\<and> Atom D,
       Atom k, {#}
\<Rightarrow> {# Atom E #} \<down> Suc (Suc (Suc (Suc (Suc 0))))"
  by(auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))

lemma Bot_delR': "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>-{#\<bottom>#} \<down> n"
proof(induction rule: SCc.induct)
  case BotL thus ?case by(rule SCc.BotL; simp) (* SC.BotL refers to SC.SCp.BotL. Even more interestingly, there used to be a SCc.SC.BotL (which was not reffered to). I'll just leave this here and see how long till someone breaks it. *)
next case (Ax k) thus ?case by(intro SCc.Ax[of k]; simp; metis diff_single_trivial formula.distinct(1) insert_DiffM lem1)
next case NotL thus ?case using SCc.NotL by (metis add_mset_remove_trivial diff_single_trivial diff_union_swap insert_DiffM)
next case NotR thus ?case using SCc.NotR by (metis diff_union_swap formula.distinct(11))
next case AndR thus ?case using SCc.AndR by (metis diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(13))
next case OrR thus ?case using SCc.OrR by (metis diff_single_trivial diff_union_swap2 formula.distinct(15) insert_iff set_mset_add_mset_insert)
next case ImpL thus ?case using SCc.ImpL by (metis diff_single_trivial diff_union_swap2)
next case ImpR thus ?case using SCc.ImpR by (metis diff_single_trivial diff_union_swap diff_union_swap2 formula.distinct(17))
qed (simp_all add: SCc.intros)

lemma NotL_inv': "Not F, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>  \<down> n"
proof(induction "Not F, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
  case (NotL \<Gamma>' G \<Delta> n) thus ?case by(cases "Not F = Not G")
    (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc)
qed (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: SCp.intros lem1 lem2)

lemma AndL_inv': "And F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F,G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
proof(induction "And F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
  case (AndL F' G' \<Gamma>' \<Delta>) thus ?case
    by(cases "And F G = And F' G'";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       metis add_mset_commute)
qed (auto intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2 inL2')

lemma OrL_inv':
  assumes "Or F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n"
  shows "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<and> G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
proof(insert assms, induction "Or F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
  case (OrL F' \<Gamma>' \<Delta> n G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       blast)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma ImpL_inv':
  assumes "Imp F G, \<Gamma> \<Rightarrow> \<Delta> \<down> n"
  shows "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<and> G,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
proof(insert assms, induction "Imp F G, \<Gamma>" \<Delta> n arbitrary: \<Gamma> rule: SCc.induct)
  case (ImpL \<Gamma>' F' \<Delta> n G') thus ?case
    by(cases "Or F G = Or F' G'"; (* oops, I didn't pay attention and used the wrong constructor\<dots> doesn't matter! *)
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       blast)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma ImpR_inv':
  assumes "\<Gamma> \<Rightarrow> Imp F G,\<Delta> \<down> n"
  shows "F,\<Gamma> \<Rightarrow> G,\<Delta> \<down> n"
proof(insert assms, induction \<Gamma> "Imp F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
  case (ImpR  F' \<Gamma> G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       blast)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma AndR_inv':
shows "\<Gamma> \<Rightarrow> And F G, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<down> n \<and> \<Gamma> \<Rightarrow> G, \<Delta> \<down> n"
proof(induction \<Gamma> "And F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
  case (AndR  \<Gamma> F' \<Delta>' n G') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       blast)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma OrR_inv': "\<Gamma> \<Rightarrow> Or F G, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,G,\<Delta> \<down> n"
proof(induction \<Gamma> "Or F G, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
  case (OrR  \<Gamma> F' G' \<Delta>') thus ?case
    by(cases "Or F G = Or F' G'";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       metis add_mset_commute)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma NotR_inv': "\<Gamma> \<Rightarrow> Not F, \<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n"
proof(induction \<Gamma> "Not F, \<Delta>" n arbitrary: \<Delta> rule: SCc.induct)
  case (NotR  G \<Gamma> \<Delta>') thus ?case
    by(cases "Not F = Not G";
       auto intro!: SCc.intros(3-) dest!: multi_member_split simp: lem1 lem2 deeper_suc;
       metis add_mset_commute)
qed (fastforce intro!: SCc.intros(3-) dest!: multi_member_split simp: SCc.intros lem1 lem2)+

lemma weakenL': "\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>  \<down> n"
  by(induction rule: SCc.induct)
    (auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))

lemma weakenR': "\<Gamma> \<Rightarrow> \<Delta>  \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>  \<down> n"
  by(induction rule: SCc.induct)
    (auto intro!: SCc.intros(3-) intro: SCc.intros(1,2))

lemma contract':
  "(F,F,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<down> n) \<and> (\<Gamma> \<Rightarrow> F,F,\<Delta> \<down> n \<longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta> \<down> n)"
proof(induction n arbitrary: F \<Gamma> \<Delta>)
  case (Suc n)
  hence IH: "F, F, \<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> F, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "\<Gamma> \<Rightarrow> F, F, \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta> \<down> n" for F :: "'a formula" and \<Gamma> \<Delta> by blast+
  show ?case proof(intro conjI allI impI, goal_cases)
    case 1
    let ?ffs = "\<lambda>\<Gamma>. \<Gamma> - {# F #} - {# F #}"
    from 1 show ?case proof(insert 1; cases rule: SCc.cases[of "F,F,\<Gamma>" \<Delta> "Suc n"])
      case (NotL  \<Gamma>' G)
      show ?thesis
      proof(cases)
        assume e: "F = \<^bold>\<not>G"
        with NotL have \<Gamma>': "\<Gamma>' = \<^bold>\<not>G, \<Gamma>" by simp
        from NotL_inv' NotL(2) have "\<Gamma> \<Rightarrow> G, G, \<Delta> \<down> n" unfolding \<Gamma>' .
        with IH(2) have "\<Gamma> \<Rightarrow> G, \<Delta> \<down> n" .
        with SCc.NotL show ?thesis unfolding e .
      next
        assume e: "F \<noteq> \<^bold>\<not>G"
        have ?thesis
          using NotL(2) IH(1)[of F "?ffs \<Gamma>'" "G, \<Delta>"] SCc.NotL[of "F, \<Gamma>' - {# F #} - {# F #}" G \<Delta> n]
          using e NotL(1) by (metis (no_types, lifting) insert_DiffM lem2)
        from e NotL(1) have \<Gamma>: "\<Gamma> = \<^bold>\<not> G, ?ffs \<Gamma>'" by (meson lem1)
        with NotL(1) have \<Gamma>': "F,F,?ffs \<Gamma>' = \<Gamma>'" by simp
        show ?thesis using NotL(2) IH(1)[of F "?ffs \<Gamma>'" "G, \<Delta>"] SCc.NotL[of "F, ?ffs \<Gamma>'" G \<Delta> n] \<open>F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n\<close> by blast
      qed
    next
      case (AndL G H \<Gamma>') show ?thesis proof cases
        assume e: "F = And G H"
        with AndL(1) have \<Gamma>': "\<Gamma>' = And G H, \<Gamma>" by simp
        have "G \<^bold>\<and> H, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using AndL(2) unfolding \<Gamma>' by auto
        hence "G, H, G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by(rule AndL_inv')
        hence "G, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using IH(1) by (metis inL1' inL3')
        thus "F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" using e SCc.AndL by simp
      next
        assume ne: "F \<noteq> And G H"
        with AndL(1) have \<Gamma>: "\<Gamma> = And G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
        have "F, F, G, H, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using AndL(2) using \<Gamma> inL4' local.AndL(1) by auto
        hence "G, H, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using IH(1) inL2 by blast
        thus ?thesis using SCc.AndL unfolding \<Gamma> using inL1 by blast
      qed
    next
      case (OrL G \<Gamma>' H) show ?thesis proof cases
        assume e: "F = Or G H"
        with OrL(1) have \<Gamma>': "\<Gamma>' = Or G H, \<Gamma>" by simp
        have "Or G H, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "Or G H, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using OrL(2,3) unfolding \<Gamma>' by simp_all
        hence "G, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "H, H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using OrL_inv' by blast+
        hence "G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" using IH(1) by presburger+
        thus "F, \<Gamma> \<Rightarrow> \<Delta> \<down> Suc n" unfolding e using SCc.OrL by blast
      next
        assume ne: "F \<noteq> Or G H"
        with OrL(1) have \<Gamma>: "\<Gamma> = Or G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
        have "F, F, G, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" "F, F, H,?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using OrL \<Gamma> by auto
        hence "G, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" "H, F, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using IH(1) by(metis add_mset_commute)+
        thus ?thesis using SCc.OrL unfolding \<Gamma> by auto
      qed
    next
      case (ImpL \<Gamma>' G H) show ?thesis proof cases
        assume e: "F = Imp G H"
        with ImpL(1) have \<Gamma>': "\<Gamma>' = Imp G H, \<Gamma>" by simp
        have "H, \<Gamma> \<Rightarrow> \<Delta> \<down> n" "\<Gamma> \<Rightarrow> G,\<Delta> \<down> n" using IH ImpL_inv' ImpL(2,3) unfolding \<Gamma>'
          by (metis add_mset_commute)+
        thus ?thesis unfolding e using SCc.ImpL[where 'a='a] by simp
      next
        assume ne: "F \<noteq> Imp G H"
        with ImpL(1) have \<Gamma>: "\<Gamma> = Imp G H, ?ffs \<Gamma>'" by (metis (no_types, lifting) diff_diff_add lem2)
        have "F, F, ?ffs \<Gamma>' \<Rightarrow> G, \<Delta> \<down> n" "F, F, H, ?ffs \<Gamma>' \<Rightarrow> \<Delta> \<down> n" using ImpL \<Gamma> by auto
        thus ?thesis using SCc.ImpL IH unfolding \<Gamma> by (metis inL1')
      qed
    next
      case ImpR thus ?thesis by (simp add: IH(1) SCc.intros(10) add_mset_commute)
    next
      case (NotR G \<Delta>') thus ?thesis using IH(1) by (simp add: SCc.NotR add_mset_commute)
    qed (auto intro: IH SCc.intros(1,2) intro!: SCc.intros(3-10))
  next
    case 2
    let ?ffs = "\<lambda>\<Gamma>. \<Gamma> - {# F #} - {# F #}"
    have not_principal[dest]:
      "\<lbrakk>F \<noteq> f G H; F, F, \<Delta> = f G H, \<Delta>'\<rbrakk> \<Longrightarrow> \<Delta> = f G H, ?ffs \<Delta>' \<and> F, F, ?ffs \<Delta>' = \<Delta>'" for f G H \<Delta>' proof(intro conjI, goal_cases)
        case 2
        from 2 have "F \<in># \<Delta>'" by(blast dest: lem1[THEN iffD1])
        then obtain \<Delta>'' where \<Delta>': "\<Delta>' = F,\<Delta>''"  by (metis insert_DiffM)
        with 2(2) have "F, \<Delta> = f G H, \<Delta>''" by(simp add: add_mset_commute)
        hence "F \<in># \<Delta>''" using 2(1) by(blast dest: lem1[THEN iffD1])
        then obtain \<Delta>''' where \<Delta>'': "\<Delta>'' = F,\<Delta>'''" by (metis insert_DiffM)
        show ?case unfolding \<Delta>' \<Delta>'' by simp
        case 1 show ?case using 1(2) unfolding \<Delta>' \<Delta>'' by(simp add: add_mset_commute)
      qed
    have principal[dest]: "F, F, \<Delta> = f G H, \<Delta>' \<Longrightarrow> F = f G H \<Longrightarrow> \<Delta>' = f G H, \<Delta>" for f G H \<Delta>' by simp
    from 2 show ?case proof(cases rule: SCc.cases[of \<Gamma> "F,F,\<Delta>" "Suc n"])
      case (ImpR G H \<Delta>') thus ?thesis proof cases
        assume e[simp]: "F = Imp G H"
        with ImpR(1) have \<Delta>'[simp]: "\<Delta>' = Imp G H, \<Delta>" by simp
        have "G, \<Gamma> \<Rightarrow> Imp G H, H, \<Delta> \<down> n" using ImpR(2) by simp
        hence "G, G, \<Gamma> \<Rightarrow> H, H, \<Delta> \<down> n" by(rule ImpR_inv')
        hence "G, \<Gamma> \<Rightarrow> H, \<Delta> \<down> n" using IH by fast
        thus "\<Gamma> \<Rightarrow> F, \<Delta> \<down> Suc n" using SCc.ImpR by simp
      next
        assume a: "F \<noteq> Imp G H"
        with ImpR(1) have \<Delta>: "\<Delta> = Imp G H, ?ffs \<Delta>'" by (metis (no_types, lifting) diff_diff_add lem2)
        have "G,\<Gamma> \<Rightarrow> F, F, H, ?ffs \<Delta>' \<down> n" using ImpR \<Delta> by fastforce
        thus ?thesis using SCc.ImpR IH unfolding \<Delta> by (metis inR1')
      qed
    next
      case (AndR G \<Delta>' H) thus ?thesis proof(cases "F = And G H")
        case True thus ?thesis using AndR by(auto intro!: SCc.intros(3-) dest!: AndR_inv' intro: IH)
      next
        case False
        hence e: "\<Delta> = And G H, ?ffs \<Delta>'" using AndR(1) using diff_diff_add lem2 by blast
        hence "G \<^bold>\<and> H, F, F, ?ffs \<Delta>' = G \<^bold>\<and> H, \<Delta>'" using AndR(1) by simp
        hence "\<Gamma> \<Rightarrow> F, F, G, ?ffs \<Delta>' \<down> n" "\<Gamma> \<Rightarrow> F, F, H, ?ffs \<Delta>' \<down> n" using AndR(2,3) using add_left_imp_eq inR2 by fastforce+
        hence "\<Gamma> \<Rightarrow> G, F, ?ffs \<Delta>' \<down> n" "\<Gamma> \<Rightarrow> H, F, ?ffs \<Delta>' \<down> n" using IH(2) by blast+
        thus ?thesis unfolding e by(intro SCc.AndR[THEN inR1'])
      qed
    next
    case (OrR G H \<Delta>') thus ?thesis proof cases
      assume a: "F = Or G H"
      hence \<Delta>': "\<Delta>' = G \<^bold>\<or> H, \<Delta>" using OrR(1) by(intro principal)
      hence "\<Gamma> \<Rightarrow> G, H, G, H, \<Delta> \<down> n" using inR3'[THEN OrR_inv'] OrR(2) by auto
      hence "\<Gamma> \<Rightarrow> H, G, \<Delta> \<down> n" using IH(2)[of \<Gamma> G "H,H,\<Delta>"] IH(2)[of \<Gamma> H "G,\<Delta>"]
        unfolding add_ac(3)[of "{#H#}" "{#G#}"] using inR2  by blast
      hence "\<Gamma> \<Rightarrow> G, H, \<Delta> \<down> n" by(elim SC_swap_applies)
    thus ?thesis unfolding a by (simp add: SCc.OrR)
    next
      assume a: "F \<noteq> Or G H"
      with not_principal have np: "\<Delta> = G \<^bold>\<or> H, ?ffs \<Delta>' \<and> F, F, ?ffs \<Delta>' = \<Delta>'" using OrR(1) .
      with OrR(2) have "\<Gamma> \<Rightarrow> G, H, F, ?ffs \<Delta>' \<down> n" using IH(2) by (metis inR2' inR4')
      hence "\<Gamma> \<Rightarrow> F, G \<^bold>\<or> H, ?ffs \<Delta>' \<down> Suc n" by(intro SCc.OrR[THEN inR1'])
      thus ?thesis using np by simp
    qed
    next
      case (NotR G \<Delta>') thus ?thesis proof(cases "F = Not G")
        case True
        with principal NotR(1) have "\<Delta>' = \<^bold>\<not> G, \<Delta>" .
        with NotR_inv' NotR(2) have "G, G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" by blast
        with IH(1) have "G, \<Gamma> \<Rightarrow> \<Delta> \<down> n" .
        thus "\<Gamma> \<Rightarrow> F, \<Delta> \<down> Suc n" unfolding True by(intro SCc.NotR)
      next
        case False
        with not_principal have np: "\<Delta> = \<^bold>\<not> G, \<Delta>' - (F, {#F#}) \<and> F, F, \<Delta>' - (F, {#F#}) = \<Delta>'" using NotR(1) by auto
        hence "G, \<Gamma> \<Rightarrow> F, F, ?ffs \<Delta>' \<down> n" using NotR(2) by simp
        hence "G, \<Gamma> \<Rightarrow> F, ?ffs \<Delta>' \<down> n" by(elim IH(2))
        thus ?thesis using np SCc.NotR inR1 by auto
      qed
    next
      case BotL thus ?thesis by(elim SCc.BotL)
    next
      case (Ax k) thus ?thesis by(intro SCc.Ax[where k=k]) simp_all
    next
      case NotL thus ?thesis by (simp add: SCc.NotL Suc.IH add_mset_commute)
    next
      case AndL thus ?thesis using SCc.AndL Suc.IH by blast
    next
      case OrL thus ?thesis using SCc.OrL Suc.IH by blast
    next
      case ImpL thus ?thesis by (metis SCc.ImpL Suc.IH add_mset_commute)
    qed
  qed
qed blast

(* depth for cut? *)
lemma Cut_Atom_depth: "Atom k,\<Gamma> \<Rightarrow> \<Delta> \<down> n \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k,\<Delta> \<down> m \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> n + m"
proof(induction "Atom k,\<Gamma>" "\<Delta>" n arbitrary: \<Gamma> m rule: SCc.induct)
  case (BotL \<Delta>)
  hence "\<bottom> \<in># \<Gamma>" by simp
  thus ?case using SCc.BotL  by auto
next
  case (Ax l \<Delta>)
  show ?case proof cases
    assume "l = k"
    with \<open>Atom l \<in># \<Delta>\<close> obtain \<Delta>' where "\<Delta> = Atom k, \<Delta>'" by (meson multi_member_split)
    with \<open>\<Gamma> \<Rightarrow> Atom k, \<Delta> \<down> m\<close> have "\<Gamma> \<Rightarrow> \<Delta> \<down> m" using contract' by blast
    thus ?thesis by (metis add.commute deeper)
  next
    assume "l \<noteq> k"
    with \<open>Atom l \<in># Atom k, \<Gamma>\<close> have "Atom l \<in># \<Gamma>" by simp
    with \<open>Atom l \<in># \<Delta>\<close> show ?thesis using SCc.Ax[of l] by simp
  qed
next
  case (NotL \<Gamma> F \<Delta>)
  obtain \<Gamma>' where \<Gamma>: "\<Gamma> = Not F, \<Gamma>'" by (meson NotL.hyps(3) add_eq_conv_ex formula.simps(9))
  show ?case unfolding \<Gamma>
    apply(unfold plus_nat.add_Suc)
    apply(intro SCc.NotL)
    apply(intro NotL.hyps (* IH *))
     subgoal using NotL \<Gamma> by (simp add: lem2)
    subgoal using \<Gamma> NotL.prems NotL_inv' by blast
  done
next
  case (NotR F \<Delta>)
  then show ?case by(auto intro!: SCc.NotR dest!: NotR_inv')
next
  case (AndL F G \<Gamma> \<Delta>)
  obtain \<Gamma>' where \<Gamma>: "\<Gamma> = And F G, \<Gamma>'" by (metis AndL.hyps(3) add_eq_conv_diff formula.distinct(5))
  show ?case unfolding \<Gamma>
    apply(unfold plus_nat.add_Suc)
    apply(intro SCc.AndL)
    apply(intro AndL.hyps (* IH *))
     subgoal using AndL \<Gamma> by (simp add: lem2)
    subgoal using \<Gamma> AndL.prems AndL_inv' by blast
  done
next
  case (AndR F \<Delta> G)
  then show ?case
    using AndR_inv' SCc.AndR by (metis add_Suc inR1')
next
  case (OrL F \<Gamma>' \<Delta> n G)
  obtain \<Gamma>'' where \<Gamma>: "\<Gamma> = Or F G, \<Gamma>''" by (meson OrL.hyps(5) add_eq_conv_ex formula.simps(13))
  have ihm: "F, \<Gamma>' = Atom k, F, \<Gamma>''" "G, \<Gamma>' = Atom k, G, \<Gamma>''" using OrL \<Gamma>  by (simp_all add: lem2)
  show ?case unfolding \<Gamma>
    apply(unfold plus_nat.add_Suc)
    apply(intro SCc.OrL OrL.hyps(2)[OF ihm(1)] OrL.hyps(4)[OF ihm(2)])
     subgoal using \<Gamma> OrL.prems OrL_inv' by blast
    subgoal using \<Gamma> OrL.prems OrL_inv' by blast
  done
next
  case (OrR F G \<Delta>)
  then show ?case by(auto intro!: SCc.intros(3-) dest!: OrR_inv')
next
  case (ImpL \<Gamma>' F \<Delta> n G)
  obtain \<Gamma>'' where \<Gamma>: "\<Gamma> = Imp F G, \<Gamma>''" by (metis ImpL.hyps(5) add_eq_conv_ex formula.simps)
  show ?case unfolding \<Gamma>
    apply(unfold plus_nat.add_Suc)
    apply(intro SCc.ImpL ImpL.hyps(2) ImpL.hyps(4))
       subgoal using ImpL \<Gamma> by (simp add: lem2)
      subgoal using \<Gamma> ImpL.prems by(auto dest!: ImpL_inv')
     subgoal using ImpL \<Gamma> by (simp add: lem2)
    subgoal using \<Gamma> ImpL.prems ImpL_inv' by blast
  done
next
  case (ImpR F G \<Delta>)
  then show ?case by (auto dest!: ImpR_inv' intro!: SCc.ImpR)
qed
primrec cut_bound :: "nat \<Rightarrow> nat \<Rightarrow> 'a formula \<Rightarrow> nat" where
  "cut_bound n m (Atom _) = m + n" |
  "cut_bound n m Bot = n" |
  "cut_bound n m (Not F) = cut_bound m n F" |
  "cut_bound n m (And F G) = cut_bound n (cut_bound n m F) G" |
  "cut_bound n m (Or F G) = cut_bound (cut_bound n m F) m G" |
  "cut_bound n m (Imp F G) = cut_bound (cut_bound m n F) m G"
theorem cut_bound: "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>  \<down> m \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n m F"
proof(induction F arbitrary: \<Gamma> \<Delta> n m)
  case (Atom k) thus ?case using Cut_Atom_depth by simp fast
next
  case Bot thus ?case using Bot_delR' by fastforce
next
  case Not from Not.prems show ?case by(auto dest!: NotL_inv' NotR_inv' intro!: Not.IH elim!: weakenL)
next
  case (And F G) from And.prems show ?case by(auto dest!: AndL_inv' AndR_inv' intro!: And.IH elim!: weakenR' weakenL')
next
  case (Or F G) from Or.prems show ?case by(auto dest: OrL_inv' OrR_inv' intro!: Or.IH elim!:  weakenR' weakenL')
next
  case (Imp F G)
  from ImpR_inv' \<open>\<Gamma> \<Rightarrow> F \<^bold>\<rightarrow> G, \<Delta> \<down> n\<close> have R: "F, \<Gamma> \<Rightarrow> G, \<Delta> \<down> n" by blast
  from ImpL_inv' \<open>F \<^bold>\<rightarrow> G, \<Gamma> \<Rightarrow> \<Delta> \<down> m\<close> have L: "\<Gamma> \<Rightarrow> F, \<Delta> \<down> m" "G, \<Gamma> \<Rightarrow> \<Delta> \<down> m" by blast+
  from L(1) have "\<Gamma> \<Rightarrow> F, G, \<Delta> \<down> m" using weakenR' by blast
  from Imp.IH(1)[OF this R] have "\<Gamma> \<Rightarrow> G, \<Delta> \<down> cut_bound m n F" .
  from Imp.IH(2)[OF this L(2)] have "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound (cut_bound m n F) m G" .
  thus "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n m (F \<^bold>\<rightarrow> G)" by simp
qed

context begin
private primrec cut_bound' :: "nat \<Rightarrow> 'a formula \<Rightarrow> nat" where
  "cut_bound' n (Atom _) = 2*n" |
  "cut_bound' n Bot = n" |
  "cut_bound' n (Not F) = cut_bound' n F" |
  "cut_bound' n (And F G) = cut_bound' (cut_bound' n F) G" |
  "cut_bound' n (Or F G) = cut_bound' (cut_bound' n F) G" |
  "cut_bound' n (Imp F G) = cut_bound' (cut_bound' n F) G"

private lemma cut_bound'_mono: "a \<le> b \<Longrightarrow> cut_bound' a F \<le> cut_bound' b F"
  by(induction F arbitrary: a b; simp)

private lemma cut_bound_mono: "a \<le> c \<Longrightarrow> b \<le> d \<Longrightarrow> cut_bound a b F \<le> cut_bound c d F"
  by(induction F arbitrary: a b c d; simp)

private lemma cut_bound_max: "max n (cut_bound' (max n m) F) = cut_bound' (max n m) F"
  by(induction F arbitrary: n m; simp; metis)
private lemma cut_bound_max': "max n (cut_bound' n F) = cut_bound' n F"
  by(induction F arbitrary: n ; simp; metis max.assoc)

private lemma cut_bound_': "cut_bound n m F \<le> cut_bound' (max n m) F"
proof(induction F arbitrary: n m)
  case (Not F)
  then show ?case by simp (metis max.commute)
next
  case (And F1 F2)
  from And.IH(1) have 1: "cut_bound n (cut_bound n m F1) F2 \<le> cut_bound n (cut_bound' (max n m) F1) F2"
    by(rule cut_bound_mono[OF order.refl])
  also from And.IH(2) have "\<dots> \<le> cut_bound' (max n (cut_bound' (max n m) F1)) F2" by simp
  also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max)
  finally show ?case by simp
next
  case (Or F1 F2)
  from Or.IH(1) have 1: "cut_bound (cut_bound n m F1) m F2 \<le> cut_bound (cut_bound' (max n m) F1) m F2"
    by(rule cut_bound_mono[OF _ order.refl])
  also from Or.IH(2)[of "cut_bound' (max n m) F1"] have "\<dots> \<le> cut_bound' (max (cut_bound' (max n m) F1) m) F2" by simp
  also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max max.commute)
  finally show ?case by simp
next
  case (Imp F1 F2)
  from Imp.IH(1) have 1: "cut_bound (cut_bound m n F1) m F2 \<le> cut_bound (cut_bound' (max m n) F1) m F2"
    by(rule cut_bound_mono[OF _ order.refl])
  also from Imp.IH(2)[of "cut_bound' (max m n) F1"] have "\<dots> \<le> cut_bound' (max (cut_bound' (max m n) F1) m) F2" by simp
  also have "\<dots> = cut_bound' (cut_bound' (max n m) F1) F2" by (simp add: cut_bound_max max.commute)
  finally show ?case by simp
qed simp_all

primrec depth :: "'a formula \<Rightarrow> nat" where
  "depth (Atom _) = 0" |
  "depth Bot = 0" |
  "depth (Not F) = Suc (depth F)" |
  "depth (And F G) = Suc (max (depth F) (depth G))" |
  "depth (Or F G) = Suc (max (depth F) (depth G))" |
  "depth (Imp F G) = Suc (max (depth F) (depth G))"

private primrec (* primrec works, but fun would give me a nicer induction rule *) cbnd where
  "cbnd k 0 = 2*k" |
  "cbnd k (Suc n) = cbnd (cbnd k n) n"

private lemma cbnd_grow: "(k :: nat) \<le> cbnd k d"
  by(induction d arbitrary: k; simp) (insert le_trans, blast)

private lemma cbnd_mono: assumes "b \<le> d" shows "cbnd (a::nat) b \<le> cbnd a d"
proof -
  have "cbnd (a::nat) b \<le> cbnd a (b + d)" for b d
    by(induction d arbitrary: a b; simp) (insert le_trans cbnd_grow, blast)
  thus ?thesis using assms using le_Suc_ex by blast
qed

private lemma cut_bound'_cbnd: "cut_bound' n F \<le> cbnd n (depth F)"
proof(induction F arbitrary: n)
next
  case (Not F)
  then show ?case using cbnd_grow dual_order.trans by fastforce
next
  case (And F1 F2)
  let ?md = "max (depth F1) (depth F2)"
  have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: And.IH(1) cut_bound'_mono)
  also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
  also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using And.IH(2) by blast
  also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
  finally show ?case by simp
next
  case (Imp F1 F2)
  case (Or F1 F2)
  text\<open>analogous\<close> (*<*)
  let ?md = "max (depth F1) (depth F2)"
  have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: Or.IH(1) cut_bound'_mono)
  also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
  also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using Or.IH(2) by blast
  also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
  finally show ?case by simp
next
  case (Imp F1 F2)
  let ?md = "max (depth F1) (depth F2)"
  have "cut_bound' (cut_bound' n F1) F2 \<le> cut_bound' (cbnd n (depth F1)) F2" by (simp add: Imp.IH(1) cut_bound'_mono)
  also have "... \<le> cut_bound' (cbnd n ?md) F2" by (simp add: cbnd_mono cut_bound'_mono)
  also have "... \<le> cbnd (cbnd n ?md) (depth F2)" using Imp.IH(2) by blast
  also have "... \<le> cbnd (cbnd n ?md) ?md" by (simp add: cbnd_mono)
  finally show ?case by simp
(*>*)
qed simp_all

value "map (cbnd (0::int)) [0,1,2,3,4]"
value "map (cbnd (1::int)) [0,1,2,3,4]" (* int, because that's easier to read\<dots> *)
value "map (cbnd (2::int)) [0,1,2,3,4]"
value "map (cbnd (3::int)) [0,1,2,3,4]"
value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound 3 3 \<circ> (\<lambda>n. ((\<lambda>F. And F F) ^^ n) (Atom 0))) [0,1,2,3,4,5,6,7]"
value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound' 3 \<circ> (\<lambda>n. ((\<lambda>F. And F F) ^^ n) (Atom 0))) [0,1,2,3,4]"
(* TODO: hm *)
value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound 3 3 \<circ> (\<lambda>n. ((\<lambda>F. Imp (Or F F) (And F F)) ^^ n) (Atom 0))) [0,1,2]"
value [nbe] "map (int \<circ> (\<lambda>n. n div 3) \<circ> cut_bound' 3 \<circ> (\<lambda>n. ((\<lambda>F. Imp (Or F F) (And F F)) ^^ n) (Atom 0))) [0,1,2]"
(* Hmhm *)
value [nbe] "(\<lambda>F. And (Or F F) (Or F F)) ^^ 2"

lemma "n + ((n + m) * 2 ^ (size F - Suc 0) +
      (n + (n + m + (n + m) * 2 ^ (size F - Suc 0))) * 2 ^ (size G - Suc 0))
    \<le> (n + (m :: nat)) * 2 ^ (size F + size G)"
  oops
    (* so the proof below won't work. *)
lemma "cut_bound (n :: nat) m F \<le> (n + m) * (2 ^ (size F - 1) + 1)"
proof(induction F arbitrary: n m)
next
  case (Not F)
  show ?case unfolding cut_bound.simps by(rule le_trans[OF Not]) (simp add: add.commute)
next
  have "1 \<le> size F" for F :: "'a formula" by(cases F; simp)
  case (And F G)
  from And(2) have "cut_bound n (cut_bound n m F) G \<le> (n + (cut_bound n m F)) * (2 ^ (size G - 1) + 1)" by simp
  also from And(1) have "\<dots> \<le> (n + (n + m) * (2 ^ (size F - 1) + 1)) * (2 ^ (size G - 1) + 1)"
    by (meson add_le_cancel_left mult_le_mono1)
  also have "\<dots> \<le> (n + m) * (2 ^ (size (F \<^bold>\<and> G) - 1) + 1)"
    apply simp
    oops

(* Oh! Look: *)
private lemma cbnd_comm: "cbnd (l * k::nat) n = l * cbnd (k::nat) n"
  by(induction n arbitrary: k; simp)

private lemma cbnd_closed: "cbnd (k::nat) n = k * 2 ^ (2 ^ n)"
  by(induction n arbitrary: k;simp add: semiring_normalization_rules(26))

theorem cut': assumes "\<Gamma> \<Rightarrow> F,\<Delta> \<down> n" "F,\<Gamma> \<Rightarrow> \<Delta> \<down> n" shows "\<Gamma> \<Rightarrow> \<Delta> \<down> n * 2 ^ (2 ^ depth F)"
proof -
  from cut_bound[OF assms] have c: "\<Gamma> \<Rightarrow> \<Delta> \<down> cut_bound n n F" .
  have d: "cut_bound n n F \<le> max n n * 2 ^ (2 ^ depth F)"
    using cut_bound_' cut_bound'_cbnd cbnd_closed by (metis order_trans)
  show ?thesis using c d le_Suc_ex deeper unfolding max.idem by metis
qed

end

end


section \<open>Fixpoints and Complete Lattices\<close>

(*
    Author: Viorel Preoteasa
*)

theory Complete_Lattice_Prop
imports WellFoundedTransitive
begin

text\<open>
This theory introduces some results about fixpoints of functions on
complete lattices. The main result is that a monotonic function
mapping momotonic functions to monotonic functions has the least
fixpoint monotonic.
\<close>

context complete_lattice begin

lemma inf_Inf: assumes nonempty: "A \<noteq> {}"
   shows "inf x (Inf A) = Inf ((inf x) ` A)"
  apply (rule antisym, simp_all)
  apply (rule INF_greatest)
  apply (safe, simp)
  apply (rule_tac y = "Inf A" in order_trans, simp_all)
  apply (rule Inf_lower, simp)
  apply (cut_tac nonempty)
  apply safe
  apply (erule notE)
  apply (rule_tac y = "inf x xa" in order_trans)
  apply (rule INF_lower, blast)
  apply simp
  apply (rule Inf_greatest)
  apply (rule_tac y = "inf x xa" in order_trans)
  apply (rule INF_lower)
  apply (simp add: image_def)
  by auto

end

(*
Monotonic applications which map monotonic to monotonic have monotonic fixpoints
*)

definition
  "mono_mono F = (mono F \<and> (\<forall> f . mono f \<longrightarrow> mono (F f)))"

theorem lfp_mono [simp]:
  "mono_mono F \<Longrightarrow> mono (lfp F)"
  apply (simp add: mono_mono_def)
  apply (rule_tac f="F" and P = "mono" in lfp_ordinal_induct)
  apply (simp_all add: mono_def)
  apply (intro allI impI SUP_least)
  apply (rule_tac y = "f y" in order_trans)
  apply (auto intro: SUP_upper)
  done

lemma gfp_ordinal_induct:
  fixes f :: "'a::complete_lattice => 'a"
  assumes mono: "mono f"
  and P_f: "!!S. P S ==> P (f S)"
  and P_Union: "!!M. \<forall>S\<in>M. P S ==> P (Inf M)"
  shows "P (gfp f)"
proof -
  let ?M = "{S. gfp f \<le> S \<and> P S}"
  have "P (Inf ?M)" using P_Union by simp
  also have "Inf ?M = gfp f"
  proof (rule antisym)
    show "gfp f \<le> Inf ?M" by (blast intro: Inf_greatest)
    hence "f (gfp f) \<le> f (Inf ?M)" by (rule mono [THEN monoD])
    hence "gfp f \<le> f (Inf ?M)" using mono [THEN gfp_unfold] by simp
    hence "f (Inf ?M) \<in> ?M" using P_f P_Union by simp
    hence "Inf ?M \<le> f (Inf ?M)" by (rule Inf_lower)
    thus "Inf ?M \<le> gfp f" by (rule gfp_upperbound)
  qed
  finally show ?thesis .
qed
theorem gfp_mono [simp]:
  "mono_mono F \<Longrightarrow> mono (gfp F)"
  apply (simp add: mono_mono_def)
  apply (rule_tac f="F" and P = "mono" in gfp_ordinal_induct)
  apply (simp_all, safe)
  apply (simp_all add: mono_def)
  apply (intro allI impI INF_greatest)
  apply (rule_tac y = "f x" in order_trans)
  apply (auto intro: INF_lower)
  done

context complete_lattice begin

definition
  "Sup_less x (w::'b::well_founded) = Sup {y ::'a . \<exists> v < w . y = x v}"

lemma Sup_less_upper:
  "v < w \<Longrightarrow> P v \<le> Sup_less P w"
  by (simp add: Sup_less_def, rule Sup_upper, blast)

lemma Sup_less_least:
  "(!! v . v < w \<Longrightarrow> P v \<le> Q) \<Longrightarrow> Sup_less P w \<le> Q"
  by (simp add: Sup_less_def, rule Sup_least, blast)

end

lemma Sup_less_fun_eq:
  "((Sup_less P w) i) = (Sup_less (\<lambda> v . P v i)) w"
  apply (simp add: Sup_less_def fun_eq_iff)
  apply (rule arg_cong [of _ _ Sup])
  apply auto
  done

theorem fp_wf_induction:
  "f x  = x \<Longrightarrow> mono f \<Longrightarrow> (\<forall> w . (y w) \<le> f (Sup_less y w)) \<Longrightarrow> Sup (range y) \<le> x"
  apply (rule Sup_least)
  apply (simp add: image_def, safe, simp)
  apply (rule less_induct1, simp_all)
  apply (rule_tac y = "f (Sup_less y xa)" in order_trans, simp)
  apply (drule_tac x = "Sup_less y xa" and y = "x" in monoD)
  by (simp add: Sup_less_least, auto)

end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Demonic Refinement Algebras *}

theory DRA
  imports DRA_Base
begin

text {*
  A demonic refinement algebra~\cite{Wright02} is a Kleene algebra without right annihilation plus
  an operation for possibly infinite iteration.
*}
class dra = kleene_algebra_zerol +
  fixes strong_iteration :: "'a \<Rightarrow> 'a" ("_\<^sup>\<infinity>" [101] 100)
  assumes iteration_unfoldl [simp] : "1 + x \<cdot> x\<^sup>\<infinity> = x\<^sup>\<infinity>"
  and coinduction: "y \<le> z + x \<cdot> y \<longrightarrow> y \<le> x\<^sup>\<infinity> \<cdot> z"
  and isolation [simp]: "x\<^sup>\<star> + x\<^sup>\<infinity>\<cdot>0 = x\<^sup>\<infinity>"
begin

text {* $\top$ is an abort statement, defined as an infinite skip. It is the maximal element of any DRA. *}

abbreviation top_elem :: "'a" ("\<top>") where "\<top> \<equiv> 1\<^sup>\<infinity>"

text {* Simple/basic lemmas about iteration operator *}

lemma iteration_refl: "1 \<le> x\<^sup>\<infinity>"
  by (metis add_ub1 iteration_unfoldl)

lemma top_ref: "x \<le> \<top>"
  by (metis add_idem' add_lub add_ub1 mult_1_left mult_1_right coinduction)

lemma top_mult_annil[simp]: "\<top>\<cdot>x = \<top>"
  by (metis add_ub2 eq_iff mult_1_left coinduction top_ref)

lemma top_add_annil[simp]: "\<top> + x = \<top>"
  by (metis add.commute less_eq_def top_ref)

lemma top_elim: "x\<cdot>y \<le> x\<cdot>\<top>"
  by (metis mult_isol top_ref)

lemma iteration_unfoldl_distl: "y\<cdot>x\<^sup>\<infinity> = y + y\<cdot>x\<cdot>x\<^sup>\<infinity>"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldl)

lemma iteration_unfoldl_distr: "x\<^sup>\<infinity>\<cdot>y = y + x\<cdot>x\<^sup>\<infinity>\<cdot>y"
  by (metis distrib_right' mult_1_left iteration_unfoldl)

lemma iteration_unfoldl': "z\<cdot>x\<^sup>\<infinity>\<cdot>y = z\<cdot>y + z\<cdot>x\<cdot>x\<^sup>\<infinity>\<cdot>y"
  by (metis distrib_left mult.assoc iteration_unfoldl_distr)

lemma iteration_idem[simp]: "x\<^sup>\<infinity>\<cdot>x\<^sup>\<infinity> = x\<^sup>\<infinity>"
  by (metis add_zerol annil isolation mult.assoc iteration_refl iteration_unfoldl_distr star_inductl_var_eq2 star_invol star_sum_unfold sup_id_star1)

lemma iteration_induct: "x\<cdot>x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>x"
  by (metis eq_iff mult.assoc coinduction iteration_unfoldl_distl)

lemma iteration_ref_star: "x\<^sup>\<star> \<le> x\<^sup>\<infinity>"
  by (metis eq_refl iteration_unfoldl star_inductl_one)

lemma iteration_subdist: "x\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add_assoc' distrib_right' mult_oner coinduction add_ub1 iteration_unfoldl)

lemma iteration_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<infinity> \<le> y\<^sup>\<infinity>"
  by (metis iteration_subdist order_prop)

lemma iteration_unfoldr: "1 + x\<^sup>\<infinity> \<cdot> x = x\<^sup>\<infinity>"
  by (metis add_0_left annil eq_refl isolation mult.assoc iteration_idem iteration_unfoldl iteration_unfoldl_distr star_denest star_one star_prod_unfold star_slide tc)

lemma iteration_unfoldr_distl: "y\<cdot>x\<^sup>\<infinity> = y + y\<cdot>x\<^sup>\<infinity>\<cdot>x"
  by (metis distrib_left mult.assoc mult_oner iteration_unfoldr)

lemma iteration_unfoldr_distr: "x\<^sup>\<infinity>\<cdot>y = y + x\<^sup>\<infinity>\<cdot>x\<cdot>y"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfold_eq: "x\<^sup>\<infinity>\<cdot>x = x\<cdot>x\<^sup>\<infinity>"
  by (metis iteration_unfoldl_distr iteration_unfoldr_distl)

lemma iteration_unfoldr': "z\<cdot>x\<^sup>\<infinity>\<cdot>y = z\<cdot>y + z\<cdot>x\<^sup>\<infinity>\<cdot>x\<cdot>y"
  by (metis distrib_left mult.assoc iteration_unfoldr_distr)

lemma iteration_double[simp]: "(x\<^sup>\<infinity>)\<^sup>\<infinity> = \<top>"
  by (metis less_eq_def iteration_iso iteration_refl top_add_annil)

lemma star_iteration[simp]: "(x\<^sup>\<star>)\<^sup>\<infinity> = \<top>"
  by (metis less_eq_def iteration_iso star_ref top_add_annil)

lemma iteration_star[simp]: "(x\<^sup>\<infinity>)\<^sup>\<star> = x\<^sup>\<infinity>"
  by (metis boffa less_eq_def iteration_idem iteration_refl)

lemma iteration_star2[simp]: "x\<^sup>\<star>\<cdot>x\<^sup>\<infinity> = x\<^sup>\<infinity>"
  by (metis add.assoc boffa isolation mult_1_right iteration_idem iteration_unfoldl star_denest star_denest_var_2 star_invol star_slide star_zero)

lemma iteration_zero[simp]: "0\<^sup>\<infinity> = 1"
  by (metis add_zeror annil iteration_unfoldl)

lemma iteration_annil[simp]: "(x\<cdot>0)\<^sup>\<infinity> = 1 + x\<cdot>0"
  by (metis annil iteration_unfoldl mult.assoc)

lemma iteration_subdenest: "x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> \<le> (x + y)\<^sup>\<infinity>"
  by (metis add.commute mult_isol_var iteration_idem iteration_subdist)

lemma sup_id_top: "1 \<le> y \<Longrightarrow> y \<cdot> \<top> = \<top>"
  by (metis antisym_conv iteration_unfold_eq mult_isol_var top_mult_annil top_ref)

lemma iteration_top[simp]: "x\<^sup>\<infinity>\<cdot>\<top> = \<top>"
  by (metis iteration_refl sup_id_top)

text {* Next, we prove some simulation laws for data refinement. *}

lemma iteration_sim: "z\<cdot>y \<le> x\<cdot>z \<Longrightarrow> z\<cdot>y\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>z"
proof -
  assume assms: "z\<cdot>y \<le> x\<cdot>z"
  have "z\<cdot>y\<^sup>\<infinity> = z + z\<cdot>y\<cdot>y\<^sup>\<infinity>"
    by (metis distrib_left mult.assoc mult_oner iteration_unfoldl)
  also have "... \<le> z + x\<cdot>z\<cdot>y\<^sup>\<infinity>"
    by (metis assms add.commute add_iso mult_isor)
  finally show "z\<cdot>y\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>z"
    by (metis mult.assoc coinduction)
qed

text {* Nitpick gives a counterexample to the dual simulation law. *}

lemma "y\<cdot>z \<le> z\<cdot>x \<Longrightarrow> y\<^sup>\<infinity>\<cdot>z \<le> z\<cdot>x\<^sup>\<infinity>"
  (* nitpick *) oops

text {* Next, we prove some sliding laws. *}

lemma iteration_slide_var: "x\<cdot>(y\<cdot>x)\<^sup>\<infinity> \<le> (x\<cdot>y)\<^sup>\<infinity>\<cdot>x"
  by (metis eq_refl iteration_sim mult.assoc)

lemma iteration_prod_unfold: "(y\<cdot>x)\<^sup>\<infinity> = 1 + y\<cdot>(x\<cdot>y)\<^sup>\<infinity>\<cdot>x"
  apply (rule antisym, metis iteration_unfoldl add_iso_var eq_refl iteration_slide_var mult.assoc mult_isol)
  by (metis add_iso_var iteration_refl iteration_slide_var iteration_unfoldr iteration_zero mult.assoc mult_isol mult_isol_var mult_oner)

lemma iteration_slide: "x\<cdot>(y\<cdot>x)\<^sup>\<infinity> = (x\<cdot>y)\<^sup>\<infinity>\<cdot>x"
  by (metis iteration_prod_unfold iteration_unfoldl_distr distrib_left mult_1_right mult.assoc)

text {* Nitpick refutes the next lemma. *}

lemma "(x\<^sup>\<star>\<cdot>y\<^sup>\<star>)\<^sup>\<infinity> = (x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity>"
  (* nitpick *) oops

lemma star_iteration_slide: "(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity> = y\<^sup>\<star>\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity>"
proof -
  have "y\<^sup>\<star>\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity> \<le> 1 + (x\<^sup>\<star>\<cdot>y)\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity> + x\<^sup>\<star>\<cdot>y\<cdot>y\<^sup>\<star>\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity>"
    by (metis star_unfoldl_eq distrib_right' eq_refl iteration_unfoldl star_ref mult_1_left mult_isor add_iso_var)
  hence "y\<^sup>\<star>\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity> \<le> 1 + x\<^sup>\<star>\<cdot>y\<cdot>y\<^sup>\<star>\<cdot>(x\<^sup>\<star>\<cdot>y)\<^sup>\<infinity>"
    by (metis less_eq_def add.assoc distrib_left distrib_right mult_1_left mult.assoc star_ref)
  thus ?thesis
    by (metis mult_1_right mult.assoc coinduction star_ref mult_1_left mult_isor add.commute less_eq_def)
qed

text {* The following laws are called denesting laws. *}

lemma iteration_sub_denest: "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = x\<cdot>(x + y)\<^sup>\<infinity> + y\<cdot>(x + y)\<^sup>\<infinity> + 1"
    by (metis add.commute distrib_right' iteration_unfoldl)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>(y\<cdot>(x + y)\<^sup>\<infinity> + 1)"
    by (metis add_assoc' add_lub_var add_ub1 add_ub2 coinduction)
  moreover hence "x\<^sup>\<infinity>\<cdot>(y\<cdot>(x + y)\<^sup>\<infinity> + 1) \<le> x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis add_iso mult.assoc mult_isol add.commute coinduction mult_oner mult_isol)
  ultimately show ?thesis
    by (metis dual_order.trans)
qed

lemma iteration_denest: "(x + y)\<^sup>\<infinity> = x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity> \<le> x\<cdot>x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity> + y\<cdot>x\<^sup>\<infinity>\<cdot>(y\<cdot>x\<^sup>\<infinity>)\<^sup>\<infinity> + 1"
    by (metis add.commute iteration_unfoldl_distr add_assoc' add.commute iteration_unfoldl order_refl)
  thus ?thesis
    by (metis add.commute iteration_sub_denest order.antisym coinduction distrib_right' iteration_sub_denest mult.assoc mult_oner order.antisym)
qed

lemma iteration_denest2: "(x + y)\<^sup>\<infinity> = y\<^sup>\<star>\<cdot>x\<cdot>(x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
proof -
  have "(x + y)\<^sup>\<infinity> = y\<^sup>\<infinity>\<cdot>x\<cdot>(y\<^sup>\<infinity>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.commute iteration_denest iteration_slide iteration_unfoldl_distr)
  also have "... = y\<^sup>\<star>\<cdot>x\<cdot>(y\<^sup>\<infinity>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> + y\<^sup>\<infinity>\<cdot>0 + y\<^sup>\<infinity>"
    by (metis isolation mult.assoc distrib_right' annil mult.assoc)
  also have "... = y\<^sup>\<star>\<cdot>x\<cdot>(y\<^sup>\<infinity>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add.assoc distrib_left mult_1_right add_0_left mult_1_right)
  finally show ?thesis
    by (metis add.commute iteration_denest iteration_slide mult.assoc)
qed

lemma iteration_denest3: "(x + y)\<^sup>\<infinity> = (y\<^sup>\<star>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
  apply (rule antisym, metis add.commute iteration_denest2 eq_refl coinduction)
  by (metis add.commute iteration_denest iteration_slide mult_isor iteration_iso iteration_ref_star)

text {* Now we prove separation laws for reasoning about distributed systems in the framework of action systems. *}

lemma iteration_sep: "y\<cdot>x \<le> x\<cdot>y \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
proof -
  assume "y\<cdot>x \<le> x\<cdot>y"
  hence "y\<^sup>\<star>\<cdot>x \<le> x\<cdot>(x + y)\<^sup>\<star>"
    by (metis star_sim1 add.commute mult_isol order_trans star_subdist)
  hence "y\<^sup>\<star>\<cdot>x\<cdot>(x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x\<cdot>(x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis mult_isor mult.assoc iteration_star2 add_iso_var eq_refl)
  thus ?thesis
    by (metis iteration_denest2 add.commute coinduction add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sim2: "y\<cdot>x \<le> x\<cdot>y \<Longrightarrow> y\<^sup>\<infinity>\<cdot>x\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
  by (metis add.commute iteration_sep iteration_subdenest)

lemma iteration_sep2: "y\<cdot>x \<le> x\<cdot>y\<^sup>\<star> \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
proof -
  assume "y\<cdot>x \<le> x\<cdot>y\<^sup>\<star>"
  hence "y\<^sup>\<star>\<cdot>(y\<^sup>\<star>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>y\<^sup>\<star>\<cdot>y\<^sup>\<infinity>"
    by (metis mult.assoc mult_isor iteration_sim star_denest_var_2 star_sim1 star_slide_var star_trans_eq tc_eq)
  moreover have "x\<^sup>\<infinity>\<cdot>y\<^sup>\<star>\<cdot>y\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
    by (metis eq_refl mult.assoc iteration_star2)
  moreover have "(y\<^sup>\<star>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity> \<le> y\<^sup>\<star>\<cdot>(y\<^sup>\<star>\<cdot>x)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
    by (metis mult_isor mult_onel star_ref)
  ultimately show ?thesis
    by (metis antisym iteration_denest3 iteration_subdenest order_trans)
qed

lemma iteration_sep3: "y\<cdot>x \<le> x\<cdot>(x + y) \<Longrightarrow> (x + y)\<^sup>\<infinity> = x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
proof -
  assume "y\<cdot>x \<le> x\<cdot>(x + y)"
  hence "y\<^sup>\<star>\<cdot>x \<le> x\<cdot>(x + y)\<^sup>\<star>"
    by (metis star_sim1)
  hence "y\<^sup>\<star>\<cdot>x\<cdot>(x + y)\<^sup>\<infinity> + y\<^sup>\<infinity> \<le> x\<cdot>(x + y)\<^sup>\<star>\<cdot>(x + y)\<^sup>\<infinity> + y\<^sup>\<infinity>"
    by (metis add_iso mult_isor)
  hence "(x + y)\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
    by (metis mult.assoc iteration_denest2 iteration_star2 add.commute coinduction)
  thus ?thesis
    by (metis add.commute less_eq_def iteration_subdenest)
qed

lemma iteration_sep4: "\<lbrakk>y\<cdot>0 = 0; z\<cdot>x = 0; y\<cdot>x \<le> (x + z)\<cdot>y\<^sup>\<star>\<rbrakk> \<Longrightarrow> (x + y + z)\<^sup>\<infinity> = x\<^sup>\<infinity>\<cdot>(y + z)\<^sup>\<infinity>"
proof -
  assume assms: "y\<cdot>0 = 0" "z\<cdot>x = 0" "y\<cdot>x \<le> (x + z)\<cdot>y\<^sup>\<star>"
  have "y\<cdot>y\<^sup>\<star>\<cdot>z \<le> y\<^sup>\<star>\<cdot>z\<cdot>y\<^sup>\<star>"
    by (metis mult_isor star_1l mult_oner order_trans star_plus_one subdistl)
  have "y\<^sup>\<star>\<cdot>z\<cdot>x \<le> x\<cdot>y\<^sup>\<star>\<cdot>z"
    by (metis zero_least assms(1) assms(2) independence1 mult.assoc)
  have "y\<cdot>(x + y\<^sup>\<star>\<cdot>z) \<le> (x + z)\<cdot>y\<^sup>\<star> + y\<cdot>y\<^sup>\<star>\<cdot>z"
    by (metis assms(3) distrib_left mult.assoc add_iso)
  also have "... \<le> (x + y\<^sup>\<star>\<cdot>z)\<cdot>y\<^sup>\<star> + y\<cdot>y\<^sup>\<star>\<cdot>z"
    by (metis star_ref add_iso_var eq_refl mult_1_left mult_isor)
  also have "... \<le> (x + y\<^sup>\<star>\<cdot>z)\<cdot>y\<^sup>\<star> + y\<^sup>\<star>\<cdot>z \<cdot>y\<^sup>\<star>" using `y\<cdot>y\<^sup>\<star>\<cdot>z \<le> y\<^sup>\<star>\<cdot>z\<cdot>y\<^sup>\<star>`
    by (metis add.commute add_iso)
  finally have "y\<cdot>(x + y\<^sup>\<star>\<cdot>z) \<le> (x + y\<^sup>\<star>\<cdot>z)\<cdot>y\<^sup>\<star>"
    by (metis add.commute add_idem' add.left_commute distrib_right)
  moreover have "(x + y + z)\<^sup>\<infinity> \<le> (x + y + y\<^sup>\<star>\<cdot>z)\<^sup>\<infinity>"
    by (metis star_ref add_iso_var eq_refl mult_1_left mult_isor iteration_iso)
  moreover have "... = (x + y\<^sup>\<star>\<cdot>z)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>"
    by (metis add.assoc add.commute calculation iteration_sep2)
  moreover have "... = x\<^sup>\<infinity>\<cdot>(y\<^sup>\<star>\<cdot>z)\<^sup>\<infinity>\<cdot>y\<^sup>\<infinity>" using `y\<^sup>\<star>\<cdot>z\<cdot>x \<le> x\<cdot>y\<^sup>\<star>\<cdot>z`
    by (metis iteration_sep mult.assoc)
  ultimately have "(x + y + z)\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>(y + z)\<^sup>\<infinity>"
    by (metis add.commute mult.assoc iteration_denest3)
  thus ?thesis
    by (metis add.commute add.left_commute less_eq_def iteration_subdenest)
qed

text {* Finally, we prove some blocking laws. *}

text {* Nitpick refutes the next lemma. *}

lemma "x\<cdot>y = 0 \<Longrightarrow> x\<^sup>\<infinity>\<cdot>y = y"
  (* nitpick *) oops

lemma iteration_idep: "x\<cdot>y = 0 \<Longrightarrow> x\<cdot>y\<^sup>\<infinity> = x"
  by (metis add_zeror annil iteration_unfoldl_distl)

text {* Nitpick refutes the next lemma. *}

lemma "y\<cdot>w \<le> x\<cdot>y + z \<Longrightarrow> y\<cdot>w\<^sup>\<infinity> \<le> x\<^sup>\<infinity>\<cdot>z"
  (* nitpick *) oops

text {* At the end of this file, we consider a data refinement example from von Wright~\cite{Wright02}. *}

lemma data_refinement:
  assumes "s' \<le> s\<cdot>z" "z\<cdot>e' \<le> e" "z\<cdot>a' \<le> a\<cdot>z" "z\<cdot>b \<le> z" "b\<^sup>\<infinity> = b\<^sup>\<star>"
  shows "s'\<cdot>(a' + b)\<^sup>\<infinity>\<cdot>e' \<le> s\<cdot>a\<^sup>\<infinity>\<cdot>e"
proof -
  have "z\<cdot>b\<^sup>\<star> \<le> z"
    by (metis assms(4) star_inductr_var)
  have "(z\<cdot>a')\<cdot>b\<^sup>\<star> \<le> (a\<cdot>z)\<cdot>b\<^sup>\<star>"
    by (metis assms(3) mult.assoc mult_isor)
  hence "z\<cdot>(a'\<cdot>b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity>\<cdot>z" using `z\<cdot>b\<^sup>\<star> \<le> z`
    by (metis mult.assoc mult_isol order_trans iteration_sim mult.assoc)
  have "s'\<cdot>(a' + b)\<^sup>\<infinity>\<cdot>e' \<le> s'\<cdot>b\<^sup>\<star>\<cdot>(a'\<cdot>b\<^sup>\<star>)\<^sup>\<infinity>\<cdot>e'"
    by (metis add.commute assms(5) eq_refl iteration_denest mult.assoc)
  also have "... \<le> s\<cdot>z\<cdot>b\<^sup>\<star>\<cdot>(a'\<cdot>b\<^sup>\<star>)\<^sup>\<infinity>\<cdot>e'"
    by (metis assms(1) mult_isor)
  also have "... \<le> s\<cdot>z\<cdot>(a'\<cdot>b\<^sup>\<star>)\<^sup>\<infinity>\<cdot>e'" using `z\<cdot>b\<^sup>\<star> \<le> z`
    by (metis mult.assoc mult_isol mult_isor)
  also have "... \<le> s\<cdot>a\<^sup>\<infinity>\<cdot>z\<cdot>e'" using `z\<cdot>(a'\<cdot>b\<^sup>\<star>)\<^sup>\<infinity> \<le>  a\<^sup>\<infinity>\<cdot>z`
    by (metis mult.assoc mult_isol mult_isor)
  finally show ?thesis
    by (metis assms(2) mult.assoc mult_isol mult.assoc mult_isol order_trans)
qed

end

end