(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Regular Algebras\<close>

theory Regular_Algebras
  imports Dioid_Power_Sum Kleene_Algebra.Finite_Suprema Kleene_Algebra.Kleene_Algebra
begin

subsection \<open>Conway's Classical Axioms\<close>

text \<open>Conway's classical axiomatisation of Regular Algebra from~\<^cite>\<open>"Conway"\<close>.\<close>

class star_dioid = dioid_one_zero + star_op + plus_ord

class conway_dioid = star_dioid +
  assumes C11: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
  and C12: "(x \<cdot> y)\<^sup>\<star> = 1 + x \<cdot>(y \<cdot> x)\<^sup>\<star> \<cdot> y"

class strong_conway_dioid = conway_dioid +
  assumes  C13: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"

class C_algebra = strong_conway_dioid +
  assumes C14: "x\<^sup>\<star> = (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>"

text \<open>We tried to dualise using sublocales, but this causes an infinite loop on dual.dual.dual....\<close>

lemma (in conway_dioid) C11_var: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
proof -
  have "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>\<star> \<cdot> y \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis C12 distrib_left mult.assoc mult_oner)
  also have "... = (1 +  x\<^sup>\<star> \<cdot> y \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star>) \<cdot> x\<^sup>\<star>"
    by (metis distrib_right mult.assoc mult_onel)
  finally show ?thesis
    by (metis C11 C12 mult_onel mult_oner)
qed

lemma (in conway_dioid) dual_conway_dioid:
  "class.conway_dioid (+) (\<odot>) 1 0 (\<le>) (<) star"
proof
  fix x y z :: 'a
  show "(x \<odot> y) \<odot> z = x \<odot>(y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir times.opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis opp_mult_def distrib_right')
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
qed

lemma (in strong_conway_dioid) dual_strong_conway_dioid: "class.strong_conway_dioid ((+) ) ((\<odot>) ) 1 0 (\<le>) (<) star"
proof
  fix x y z :: 'a
  show "(x \<odot> y) \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot>  x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis opp_mult_def distrib_right')
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis C13)
qed

text\<open>Nitpick finds counterexamples to the following claims.\<close>

lemma (in conway_dioid) "1\<^sup>\<star> = 1"
  nitpick [expect=genuine] \<comment> \<open>3-element counterexample\<close>
oops

lemma (in conway_dioid) "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
  nitpick [expect=genuine] \<comment> \<open>3-element counterexample\<close>
oops

context C_algebra
begin

lemma C_unfoldl [simp]: "1 + x \<cdot>  x\<^sup>\<star> =  x\<^sup>\<star>"
  by (metis C12 mult_onel mult_oner)

lemma C_slide: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
proof-
  have "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<cdot> x"
    by (metis C12 mult_onel distrib_right')
  also have "... = x \<cdot> (1 + (y \<cdot> x)\<^sup>\<star> \<cdot> y \<cdot> x)"
    by (metis distrib_left mult.assoc mult_oner)
  finally show ?thesis
    by (metis C12 mult.assoc mult_onel mult_oner)
qed

lemma powsum_ub: "i \<le> n \<Longrightarrow> x\<^bsup>i\<^esup> \<le> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>"
proof (induct n)
  case 0 show ?case
    by (metis (opaque_lifting, mono_tags) "0.prems" order.eq_iff le_0_eq power_0 powsum_00)
next
  case (Suc n) show ?case
proof -
  { assume aa1: "Suc n \<noteq> i"
    have ff1: "x\<^bsub>0\<^esub>\<^bsup>Suc n\<^esup> \<le> x\<^bsub>0\<^esub>\<^bsup>Suc n\<^esup> \<and> Suc n \<noteq> i"
      using aa1 by fastforce
    have ff2: "\<exists>x\<^sub>1. x\<^bsub>0\<^esub>\<^bsup>n\<^esup> + x\<^sub>1 \<le> x\<^bsub>0\<^esub>\<^bsup>Suc n\<^esup> \<and> Suc n \<noteq> i"
      using ff1 powsum2 by auto
    have "x\<^bsup>i\<^esup> \<le> x\<^bsub>0\<^esub>\<^bsup>Suc n\<^esup>"
      by (metis Suc.hyps Suc.prems ff2 le_Suc_eq local.dual_order.trans local.join.le_supE)
  }
  thus "x\<^bsup>i\<^esup> \<le> x\<^bsub>0\<^esub>\<^bsup>Suc n\<^esup>"
    using local.less_eq_def local.powsum_split_var2 by blast
qed
qed

lemma C14_aux: "m \<le> n \<Longrightarrow>  x\<^bsup>m\<^esup> \<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m\<^esup>"
proof -
  assume assm: "m \<le> n"
  hence "x\<^bsup>m\<^esup> \<cdot>  (x\<^bsup>n\<^esup>)\<^sup>\<star> =  x\<^bsup>m\<^esup> \<cdot> (x\<^bsup>n-m\<^esup> \<cdot> x\<^bsup>m\<^esup>)\<^sup>\<star>"
    by (metis (full_types) le_add_diff_inverse2 power_add)
  also have "... = (x\<^bsup>n-m\<^esup> \<cdot> x\<^bsup>m\<^esup>)\<^sup>\<star> \<cdot>  x\<^bsup>m\<^esup>"
    by (metis (opaque_lifting, mono_tags) C_slide ab_semigroup_add_class.add.commute power_add)
  finally show ?thesis
    by (metis (full_types) assm le_add_diff_inverse ab_semigroup_add_class.add.commute power_add)
qed

end

context dioid_one_zero
begin

lemma opp_power_def:
  "power.power 1 (\<odot>) x n = x\<^bsup>n\<^esup>"
proof (induction n)
  case 0 thus ?case
    by (metis power.power.power_0)
next
  case (Suc n) thus ?case
    by (metis power.power.power_Suc power_Suc2 times.opp_mult_def)
qed

lemma opp_powsum_def:
  "dioid_one_zero.powsum (+) (\<odot>) 1 0 x m n = x\<^bsub>m\<^esub>\<^bsup>n\<^esup>"
proof -
  have "sum (power.power 1 (\<odot>) x) {m..n + m} = sum ((^) x) {m..n + m}"
    by (induction n, simp_all add:opp_power_def)
  thus ?thesis
    by (simp add: dioid_one_zero.powsum_def[of _ _ _ _ "(\<le>)" "(<)"] dual_dioid_one_zero powsum_def)
qed

end

lemma C14_dual:
  fixes x::"'a::C_algebra"
  shows "x\<^sup>\<star> = x\<^bsub>0\<^esub>\<^bsup>n\<^esup> \<cdot> (x\<^bsup>n+1\<^esup>)\<^sup>\<star>"
proof -
  have "x\<^sup>\<star> =  (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>"
    by (rule C14)
  also have "... = (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> (\<Sum>i=0..n. x^i)"
    by (subst powsum_def, auto)
  also have "... = (\<Sum>i=0..n. (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x^i)"
    by (metis le0 sum_interval_distl)
  also have "... = (\<Sum>i=0..n. x^i \<cdot> (x\<^bsup>n+1\<^esup>)\<^sup>\<star>)"
    by (auto intro: sum_interval_cong simp only:C14_aux)
  also have "... = x\<^bsub>0\<^esub>\<^bsup>n\<^esup> \<cdot> (x\<^bsup>n+1\<^esup>)\<^sup>\<star>"
    by (simp only: sum_interval_distr[THEN sym] powsum_def Nat.add_0_right)
  finally show ?thesis .
qed

lemma C_algebra: "class.C_algebra (+) (\<odot>) (1::'a::C_algebra) 0 (\<le>) (<) star"
proof
  fix x y :: 'a and n :: nat
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis C13)
  show "x\<^sup>\<star> = power.power 1 (\<odot>) x (n + 1)\<^sup>\<star> \<odot> dioid_one_zero.powsum (+) (\<odot>) 1 0 x 0 n"
    by (metis C14_dual opp_mult_def opp_power_def opp_powsum_def)
qed (simp_all add: opp_mult_def mult.assoc distrib_left)

subsection \<open>Boffa's Axioms\<close>

text \<open>Boffa's two axiomatisations of Regular Algebra from~\<^cite>\<open>"Boffa1" and "Boffa2"\<close>.\<close>

class B1_algebra = conway_dioid +
  assumes R: "x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"

class B2_algebra = star_dioid +
  assumes B21: "1 + x \<le> x\<^sup>\<star>"
  and B22 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  and B23: "\<lbrakk> 1 + x \<le> y; y \<cdot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"

lemma (in B1_algebra) B1_algebra:
  "class.B1_algebra (+) (\<odot>) 1 0 (\<le>) (<) star"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show "x \<odot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
    by (metis R opp_mult_def)
qed

lemma (in B2_algebra) B2_algebra:
  "class.B2_algebra (+) (\<odot>) 1 0 (\<le>) (<) star"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left times.opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis B21)
  show "x\<^sup>\<star> \<odot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis B22 opp_mult_def)
  show "\<lbrakk> 1 + x \<le> y; y \<odot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis B23 opp_mult_def)
qed

instance B1_algebra \<subseteq> B2_algebra
proof
  fix x y :: 'a
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis C12 add_iso_r distrib_right join.sup.cobounded1 mult_onel)
  show two: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis (no_types, lifting) C11_var C12 R add_idem' mult_onel mult_oner)
  show "\<lbrakk> 1 + x \<le> y; y \<cdot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis (no_types, lifting) C11_var R two distrib_left join.sup.bounded_iff less_eq_def mult.assoc mult.right_neutral)
qed

context B2_algebra
begin

lemma star_ref: "1 \<le> x\<^sup>\<star>"
  using local.B21 by auto

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

lemma star_trans: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  by (metis B22 order_refl)

lemma star_trans_eq [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  by (metis B22)

lemma star_invol [simp]: "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
  by (metis B21 B22 B23 order.antisym star_plus_one)

lemma star_1l: "x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  by (metis local.B21 local.join.sup.boundedE local.mult_isor local.star_trans_eq)

lemma star_one [simp]: "1\<^sup>\<star> = 1"
  by (metis B23 add_idem order.antisym mult_oner order_refl star_ref)

lemma star_subdist:  "x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  by (meson local.B21 local.B23 local.join.sup.bounded_iff local.star_trans_eq)

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

lemma star2: "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
  by (metis B21 add.commute less_eq_def star_invol star_subdist)

lemma star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  by (metis local.join.sup.bounded_iff star_1l star_ref)

lemma star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  by (metis (full_types) B21 local.join.sup.bounded_iff mult_isol star_trans_eq)

lemma star_ext: "x \<le> x\<^sup>\<star>"
  by (metis B21 local.join.sup.bounded_iff)

lemma star_1r: "x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  by (metis mult_isol star_ext star_trans_eq)

lemma star_unfoldl_eq [simp]: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
proof -
  have "(1 + x \<cdot> x\<^sup>\<star>) \<cdot> (1 + x \<cdot> x\<^sup>\<star>) = 1 \<cdot> (1 + x \<cdot> x\<^sup>\<star>) + x \<cdot> x\<^sup>\<star> \<cdot> (1 + x \<cdot> x\<^sup>\<star>)"
    by (metis distrib_right)
  also have "... = 1 + x \<cdot> x\<^sup>\<star> + (x \<cdot> x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star>)"
    by (metis add_assoc' add_idem' distrib_left mult.assoc mult_onel mult_oner)
  also have "... = 1 + x \<cdot> x\<^sup>\<star>"
    by (metis add.assoc add.commute distrib_left less_eq_def mult.assoc star_1l star_trans_eq)
  finally show ?thesis
    by (metis B23 local.join.sup.mono local.join.sup.cobounded1 distrib_left order.eq_iff mult_1_right star_plus_one star_unfoldl)
qed

lemma star_unfoldr_eq [simp]: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
proof -
  have "(1 + x\<^sup>\<star> \<cdot> x) \<cdot> (1 + x\<^sup>\<star> \<cdot> x) = 1 \<cdot> (1 + x\<^sup>\<star> \<cdot> x) + x\<^sup>\<star> \<cdot> x \<cdot> (1 + x\<^sup>\<star> \<cdot> x)"
    by (metis distrib_right)
  also have "... = 1 + x\<^sup>\<star> \<cdot> x + (x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> x)"
    by (metis add.assoc add_idem' distrib_left mult_1_left mult_1_right mult.assoc)
  also have "... = 1 + x\<^sup>\<star> \<cdot>x"
    by (metis add_assoc' distrib_left mult.assoc mult_oner distrib_right' star_trans_eq star_unfoldl_eq)
  finally show ?thesis
    by (metis B21 B23 add.commute local.join.sup.mono local.join.sup.cobounded1 order.eq_iff eq_refl mult_1_left distrib_right' star_unfoldl_eq star_unfoldr)
qed

lemma star_prod_unfold_le: "(x \<cdot> y)\<^sup>\<star> \<le> 1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y"
proof -
  have "(1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) \<cdot> (1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) =
        1 \<cdot> (1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) + (x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) \<cdot> (1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y)"
    by (metis distrib_right')
  also have "... = 1 + x \<cdot>(y \<cdot> x)\<^sup>\<star> \<cdot> y + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<cdot> x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y"
    by (metis add.assoc local.join.sup.cobounded1  distrib_left less_eq_def mult_1_right mult.assoc mult_onel)
  finally have "(1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) \<cdot> (1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) = 1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y"
    by (metis add.assoc  distrib_left distrib_right mult.assoc mult_oner star_trans_eq star_unfoldr_eq)
  moreover have "(x \<cdot> y) \<le> 1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y"
    by (metis local.join.sup.cobounded2 mult_1_left mult.assoc mult_double_iso order_trans star_ref)
  ultimately show ?thesis
    by (simp add: local.B23)
qed

lemma star_prod_unfold [simp]: " 1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y = (x \<cdot> y)\<^sup>\<star>"
proof -
  have "1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<le> 1 + x \<cdot> (1 + y \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> x) \<cdot> y"
    by (metis local.join.sup.mono mult_double_iso order_refl star_prod_unfold_le)
  also have "... = 1 + x \<cdot> y + x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> x \<cdot> y"
    by (metis add.assoc distrib_left mult_1_left mult.assoc distrib_right')
  finally have "1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<le> (x \<cdot> y)\<^sup>\<star>"
    by (metis add.assoc distrib_left mult_1_right mult.assoc star_unfoldl_eq star_unfoldr_eq)
  thus ?thesis
    by (metis order.antisym star_prod_unfold_le)
qed

lemma star_slide1: "(x \<cdot> y)\<^sup>\<star> \<cdot> x \<le> x \<cdot> (y \<cdot> x)\<^sup>\<star>"
proof -
  have "(x \<cdot> y)\<^sup>\<star> \<cdot> x = (1 + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y) \<cdot> x"
    by (metis star_prod_unfold)
  also have "... = (x + x \<cdot> (y \<cdot> x)\<^sup>\<star> \<cdot> y \<cdot> x)"
    by (metis mult_onel distrib_right')
  also have "... = x \<cdot> (1 + (y \<cdot> x)\<^sup>\<star> \<cdot> y \<cdot> x)"
    by (metis distrib_left mult.assoc mult_oner)
  finally show ?thesis
    by (metis eq_refl mult.assoc star_unfoldr_eq)
qed

lemma star_slide_var1: "x\<^sup>\<star> \<cdot> x \<le> x \<cdot> x\<^sup>\<star>"
  by (metis mult_onel mult_oner star_slide1)

lemma star_slide: "(x \<cdot> y)\<^sup>\<star> \<cdot> x = x \<cdot> (y \<cdot> x)\<^sup>\<star>"
proof (rule order.antisym)
  show "(x \<cdot> y)\<^sup>\<star> \<cdot> x \<le> x \<cdot> (y \<cdot> x)\<^sup>\<star>"
    by (metis star_slide1)
  have "x \<cdot> (y \<cdot> x)\<^sup>\<star> = x \<cdot> (1 + y \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> x)"
    by (metis star_prod_unfold)
  also have "... = x + x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<star> \<cdot> x"
    by (metis distrib_left mult.assoc mult_oner)
  also have "... = (1 + x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<star>) \<cdot> x"
    by (metis mult_onel distrib_right')
  finally show "x \<cdot> (y \<cdot> x)\<^sup>\<star> \<le> (x \<cdot> y)\<^sup>\<star> \<cdot> x"
    by (metis mult_isor star_unfoldl)
qed

lemma star_rtc1: "1 + x + x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  using local.B21 local.join.sup_least local.star_trans by blast

lemma star_rtc1_eq: "1 + x + x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  by (metis B21 B22 less_eq_def)

lemma star_subdist_var_1: "x \<le> (x + y)\<^sup>\<star>"
  using local.join.le_supE local.star_ext by blast

lemma star_subdist_var_2: "x \<cdot> y \<le> (x + y)\<^sup>\<star>"
  by (metis (full_types) local.join.le_supE mult_isol_var star_ext star_trans_eq)

lemma star_subdist_var_3: "x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
  by (metis add.commute mult_isol_var star_subdist star_trans_eq)

lemma R_lemma:
  assumes "x \<cdot> x = x"
  shows "x\<^sup>\<star> = 1 + x"
proof (rule order.antisym)
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis B21)
  have "(1 + x) \<cdot> (1 + x) = 1 + x"
    by (metis add.commute add_idem' add.left_commute assms distrib_left mult_onel mult_oner distrib_right')
  thus "x\<^sup>\<star> \<le> 1 + x"
    by (metis B23 order_refl)
qed

lemma star_denest_var_0: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
proof (rule order.antisym)
  have one_below: "1 \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis mult_isol_var star_one star_ref star_trans_eq)
  have x_below: "x \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis mult_isol mult_oner order_trans star_ext star_ref star_slide)
  have y_below: "y \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis mult_isol_var mult_onel mult_oner order_trans star_ext star_slide star_unfoldl_eq subdistl)
  from one_below x_below y_below have "1 + x + y \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by simp
    moreover have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis star_trans_eq star_slide mult.assoc)
  ultimately show "(x + y)\<^sup>\<star> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star>"
    by (metis B23 add_assoc' mult.assoc)
  show "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> (x + y)\<^sup>\<star>"
    by (metis (full_types) add.commute mult_isol_var star_invol star_iso star_subdist_var_1 star_trans_eq)
qed

lemma star_denest: "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (metis R_lemma add.commute star_denest_var_0 star_plus_one star_prod_unfold star_slide star_trans_eq)

lemma star_sum_var: "(x + y)\<^sup>\<star>  = (x\<^sup>\<star> + y\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_denest star_invol)

lemma star_denest_var: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_denest_var_0 star_slide)

lemma star_denest_var_2: "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_denest star_denest_var)

lemma star_denest_var_3: "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y\<^sup>\<star> \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
  by (metis B22 add_comm mult.assoc star_denest star_denest_var_2)

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

lemma star_denest_var_5: "x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star> = y\<^sup>\<star> \<cdot> (x \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (metis add.commute star_denest_var)

lemma star_denest_var_6: "(x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x + y)\<^sup>\<star>"
  by (metis mult.assoc star_denest star_denest_var_3)

lemma star_denest_var_7: "(x + y)\<^sup>\<star> = (x + y)\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> y\<^sup>\<star>"
  by (metis star_denest star_denest_var star_denest_var_3 star_denest_var_5 star_slide)

lemma star_denest_var_8: "(x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star> \<cdot> y\<^sup>\<star> \<cdot> (x\<^sup>\<star> \<cdot> y\<^sup>\<star>)\<^sup>\<star>"
  by (metis star_denest star_denest_var_6)

lemma star_slide_var: "x\<^sup>\<star> \<cdot> x = x \<cdot> x\<^sup>\<star>"
  by (metis mult_1_left mult_oner star_slide)

lemma star_sum_unfold: "(x + y)\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<star>"
  by (metis distrib_left mult_1_right mult.assoc star_denest_var star_unfoldl_eq)

lemma troeger: "x\<^sup>\<star> \<cdot> (y \<cdot> ((x + y)\<^sup>\<star> \<cdot> z) + z) = (x + y)\<^sup>\<star> \<cdot> z"
proof -
  have "x\<^sup>\<star> \<cdot> (y \<cdot> ((x + y)\<^sup>\<star> \<cdot> z) + z) = (x\<^sup>\<star> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<star>) \<cdot> z"
    by (metis add_comm distrib_left mult.assoc distrib_right')
  thus ?thesis
    by (metis star_sum_unfold)
qed

lemma meyer_1: "x\<^sup>\<star> = (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
proof (rule order.antisym)
  have "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<cdot> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> = ((x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>) \<cdot> ((x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>)"
    by (metis mult.assoc mult_onel distrib_right')
  also have "... = ((x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>) \<cdot> (x \<cdot> x)\<^sup>\<star> + ((x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>) \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis distrib_left mult.assoc)
  also have "... = (x \<cdot> x) \<^sup>\<star> \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star> \<cdot> (x \<cdot> x)\<^sup>\<star> + (x \<cdot> x)\<^sup>\<star> \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star> \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis combine_common_factor distrib_right)
  also have "... = (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis add.assoc add_idem' mult.assoc star_slide star_trans_eq)
  also have "... = 1 + x \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star> + x \<cdot> x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis star_unfoldl_eq)
  also have "... = (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis add_comm add_idem' add.left_commute star_unfoldl_eq)
    finally have "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<cdot> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> = (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis mult_1_left distrib_right')
  moreover have "1 + x \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis mult_1_right star_unfoldl_eq subdistl)
  ultimately show "x\<^sup>\<star> \<le> (1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis B23 mult.assoc)
next
  have "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> = (x \<cdot> x)\<^sup>\<star> + x \<cdot> (x \<cdot> x)\<^sup>\<star>"
    by (metis mult_1_left distrib_right')
  thus "(1 + x) \<cdot> (x \<cdot> x)\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis local.add_zeror local.join.sup_least local.mult_isol_var local.mult_oner local.star_ext local.star_invol local.star_iso local.star_subdist_var_2 local.star_trans_eq local.subdistl_eq)
qed

lemma star_zero [simp]: "0\<^sup>\<star> = 1"
  by (metis add_zeror star2 star_one)

lemma star_subsum [simp]: "x\<^sup>\<star> + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  by (metis add.assoc add_idem star_slide_var star_unfoldl_eq)

lemma prod_star_closure: "x \<le> z\<^sup>\<star> \<Longrightarrow> y \<le> z\<^sup>\<star> \<Longrightarrow> x \<cdot> y \<le> z\<^sup>\<star>"
  by (metis mult_isol_var star_trans_eq)

end

sublocale B2_algebra \<subseteq> B1_algebra
  by unfold_locales (metis star_denest_var_0, metis star_prod_unfold, metis R_lemma)

context B2_algebra
begin

lemma power_le_star: "x\<^bsup>n\<^esup> \<le> x\<^sup>\<star>"
  by (induct n, simp_all add: star_ref prod_star_closure star_ext)

lemma star_power_slide:
  assumes "k \<le> n"
  shows "x\<^bsup>k \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>k\<^esup>"
proof -
  from assms have "x\<^bsup>k \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> = (x\<^bsup>k \<^esup>\<cdot> x\<^bsup>n-k\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>k\<^esup>"
    by (metis (full_types) le_add_diff_inverse2 power_add star_slide)
  with assms show ?thesis
    by (metis (full_types) le_add_diff_inverse2 ab_semigroup_add_class.add.commute power_add)
qed

lemma powsum_le_star: "x\<^bsub>m\<^esub>\<^bsup>n\<^esup> \<le> x\<^sup>\<star>"
  by (induct n, simp_all add:  powsum2, metis power_le_star, metis  power_Suc power_le_star)

lemma star_sum_power_slide:
  assumes "m \<le> n"
  shows "x\<^bsub>0\<^esub>\<^bsup>m  \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m\<^esup>"
using assms
proof (induct m)
  case 0 thus ?case
    by (metis mult_onel mult_oner powsum_00)
next
  case (Suc m) note hyp = this
  have "x\<^bsub>0\<^esub>\<^bsup>Suc m\<^esup> \<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> = (x\<^bsub>0\<^esub>\<^bsup>m\<^esup> + x\<^bsup>Suc m\<^esup>) \<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star>"
    by (simp add:powsum2)
  also have "... = x\<^bsub>0\<^esub>\<^bsup>m \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star> + x\<^bsup>Suc m \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star>"
    by (metis distrib_right')
  also have "... = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m\<^esup> + x\<^bsup>Suc m \<^esup>\<cdot> (x\<^bsup>n\<^esup>)\<^sup>\<star>"
    by (metis Suc.hyps Suc.prems Suc_leD)
  also have "... = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m\<^esup> + (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>Suc m\<^esup>"
    by (metis Suc.prems star_power_slide)
  also have "... = (x\<^bsup>n\<^esup>)\<^sup>\<star> \<cdot> (x\<^bsub>0\<^esub>\<^bsup>m\<^esup> + x\<^bsup>Suc m\<^esup>)"
    by (metis distrib_left)
  finally show ?case
    by (simp add:powsum2)
qed

lemma aarden_aux:
  assumes "y \<le> y \<cdot> x + z"
  shows "y \<le> y \<cdot> x\<^bsup>(Suc n) \<^esup>+ z \<cdot> x\<^sup>\<star>"
proof (induct n)
  case 0
  have "y \<cdot> x + z \<le> y \<cdot> x\<^bsup>(Suc 0)\<^esup>+ z \<cdot> x\<^sup>\<star>"
    by (metis (mono_tags) One_nat_def add.commute add_iso mult_1_right power_one_right star_plus_one subdistl)
  thus ?case
    by (metis assms order_trans)
next
  case (Suc n)
  have "y \<cdot> x + z \<le> (y \<cdot> x\<^bsup>(Suc n) \<^esup>+ z \<cdot> x\<^sup>\<star>) \<cdot> x + z"
    by (metis Suc add_iso mult_isor)
  also have "... = y \<cdot> x\<^bsup>(Suc n) \<^esup>\<cdot> x + z \<cdot> (x\<^sup>\<star> \<cdot> x + 1)"
    by (subst distrib_right, metis add_assoc' distrib_left mult.assoc mult_oner)
  finally show ?case
    by (metis add.commute assms mult.assoc order_trans power_Suc2 star_unfoldr_eq)
qed

lemma conway_powerstar1: "(x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n \<^esup>\<cdot> (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>  = (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>"
proof (cases n)
  case 0 thus ?thesis
    by simp
next
  case (Suc m) thus ?thesis
  proof -
    assume assm: "n = Suc m"
    have "(x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1 \<^esup>\<cdot> (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>  = (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1 \<^esup>\<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>"
      by (subgoal_tac "m + 1 \<le> m + 2", metis mult.assoc star_sum_power_slide, simp)
    also have "...  = (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1 \<^esup>\<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>"
      by (metis star_trans_eq)
    also have "...  =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>(Suc m)+(Suc m)\<^esup>"
      by (simp add: mult.assoc powsum_prod)
    also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> (x\<^bsub>0\<^esub>\<^bsup>Suc m \<^esup>+ x\<^bsub>m + 2\<^esub>\<^bsup>m\<^esup>)"
      by (metis monoid_add_class.add.left_neutral powsum_split_var3 add_2_eq_Suc')
    also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>Suc m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>(m + 2)+ 0\<^esub>\<^bsup>m\<^esup>"
     by (simp add: local.distrib_left)
    also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>Suc m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m+2 \<^esup>\<cdot> x\<^bsub>0\<^esub>\<^bsup>m\<^esup>"
      by (subst powsum_shift[THEN sym], metis mult.assoc)
   also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> (x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+  x\<^bsup>m+1\<^esup>) + (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m+2 \<^esup>\<cdot> x\<^bsub>0\<^esub>\<^bsup>m\<^esup>"
     by (simp add:powsum2)
   also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m+2 \<^esup>\<cdot> x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m+1\<^esup>"
     by (metis add.assoc add.commute add.left_commute distrib_left mult.assoc)
   also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+ (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsup>m+1\<^esup>"
     by (metis add_idem' distrib_right' star_subsum)
   also have "... =  (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> (x\<^bsub>0\<^esub>\<^bsup>m \<^esup>+ x\<^bsup>m+1\<^esup>)"
     by (metis add_idem' distrib_left)
    also have "... = (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>"
      by (simp add:powsum2)
    finally  show ?thesis
      by (simp add: assm)
  qed
qed

lemma conway_powerstar2: "1 + x \<le> (x\<^bsup>n+1\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>n\<^esup>"
proof (cases n)
  case 0 show ?thesis
    using "0" local.B21 by auto
next
  case (Suc m) show ?thesis
  proof -
    have one: "x \<le> (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>"
      by (metis Suc_eq_plus1 powsum_ext  mult_isor mult_onel order_trans star_ref)
    have two: "1 \<le> (x\<^bsup>m+2\<^esup>)\<^sup>\<star> \<cdot> x\<^bsub>0\<^esub>\<^bsup>m+1\<^esup>"
      by (metis Suc_eq_plus1 local.join.le_supE mult_isor mult_onel powsum_split_var1 star_ref)
    from one two show ?thesis
      by (metis Suc Suc_eq_plus1 add_2_eq_Suc' local.join.sup_least)
  qed
qed

end

sublocale B2_algebra \<subseteq> strong_conway_dioid
  by  unfold_locales (metis star_invol)

sublocale B2_algebra \<subseteq> C_algebra
  by unfold_locales (metis powerstar)

text \<open>The following fact could neither be verified nor falsified in Isabelle. It does not hold for other reasons.\<close>

lemma (in C_algebra) "x\<cdot>x = x \<longrightarrow> x\<^sup>\<star> = 1+x"
oops

subsection \<open>Boffa Monoid Identities\<close>

typedef ('a , 'b) boffa_mon = "{f :: 'a::{finite,monoid_mult}  \<Rightarrow> 'b::B1_algebra. True}"
  by auto

notation
  Rep_boffa_mon ("_\<^bsub>_\<^esub>")

lemma "finite (range (Rep_boffa_mon M))"
  by (metis finite_code finite_imageI)

abbreviation boffa_pair :: "('a, 'b) boffa_mon \<Rightarrow> 'a::{finite,monoid_mult} \<Rightarrow> 'a \<Rightarrow> 'b::B1_algebra" where
  "boffa_pair x i j \<equiv> \<Sum> { x\<^bsub>k\<^esub> | k. i\<cdot>k = j}"

notation
  boffa_pair ("_\<^bsub>_,_\<^esub>")

abbreviation conway_assms where
  "conway_assms x \<equiv> (\<forall> i j. (x\<^bsub>i \<^esub>\<cdot> x\<^bsub>j\<^esub> \<le> x\<^bsub>i\<cdot>j\<^esub>) \<and> (x\<^bsub>i,i\<^esub>)\<^sup>\<star> = x\<^bsub>i,i\<^esub>)"

lemma pair_one: "x\<^bsub>1,1\<^esub> = x\<^bsub>1\<^esub>"
  by (simp)

definition conway_assm1 where "conway_assm1 x = (\<forall> i j. x\<^bsub>i \<^esub>\<cdot> x\<^bsub>j\<^esub> \<le> x\<^bsub>i\<cdot>j\<^esub>)"
definition conway_assm2 where "conway_assm2 x = (\<forall>i. x\<^bsub>i,i\<^esub>\<^sup>\<star> = x\<^bsub>i,i\<^esub>)"

lemma pair_star:
  assumes "conway_assm2 x"
  shows "x\<^bsub>1\<^esub>\<^sup>\<star> = x\<^bsub>1\<^esub>"
proof -
  have "x\<^bsub>1\<^esub>\<^sup>\<star> = x\<^bsub>1,1\<^esub>\<^sup>\<star>"
    by simp
  also from assms have "... = x\<^bsub>1,1\<^esub>"
    by (metis (mono_tags) conway_assm2_def)
  finally show ?thesis
    by simp
qed

lemma conway_monoid_one:
  assumes "conway_assm2 x"
  shows "x\<^bsub>1\<^esub> = 1 + x\<^bsub>1\<^esub>"
proof -
  from assms have "x\<^bsub>1\<^esub> = x\<^bsub>1\<^esub>\<^sup>\<star>"
    by (metis pair_star)
  thus ?thesis
    by (metis star_plus_one)
qed

lemma conway_monoid_split:
  assumes "conway_assm2 x"
  shows "\<Sum> {x\<^bsub>i \<^esub>| i . i \<in> UNIV} = 1 + \<Sum> {x\<^bsub>i \<^esub>| i . i \<in> UNIV}"
proof -
  have "\<Sum> {x\<^bsub>i \<^esub>| i . i \<in> UNIV} = \<Sum> {x\<^bsub>i \<^esub>| i . i \<in> (insert 1 (UNIV - {1}))}"
    by (metis UNIV_I insert_Diff_single insert_absorb)
  also have "... = \<Sum> (Rep_boffa_mon x ` (insert 1 (UNIV - {1})))"
    by (metis fset_to_im)
  also have "... = x\<^bsub>1\<^esub> + \<Sum> (Rep_boffa_mon x ` (UNIV - {1}))"
    by (subst sum_fun_insert, auto)
  also have "... = x\<^bsub>1\<^esub> + \<Sum> { x\<^bsub>i\<^esub> | i. i\<in>(UNIV - {1})}"
    by (metis fset_to_im)
  also from assms have unfld:"... = 1 + x\<^bsub>1\<^esub> + \<Sum> { x\<^bsub>i\<^esub> | i. i\<in>(UNIV - {1})}"
    by (metis (lifting, no_types) conway_monoid_one)
  finally show ?thesis
    by (metis (lifting, no_types) ac_simps unfld)
qed

lemma boffa_mon_aux1: "{x\<^bsub>i\<cdot>j \<^esub>| i j. i \<in> UNIV \<and> j \<in> UNIV} = {x\<^bsub>i\<^esub> | i. i \<in> UNIV}"
  by (auto, metis monoid_mult_class.mult.left_neutral)

lemma sum_intro' [intro]:
  "\<lbrakk>finite (A :: 'a::join_semilattice_zero set); finite B; \<forall>a\<in>A. \<exists>b\<in>B. a \<le> b \<rbrakk> \<Longrightarrow> \<Sum>A \<le> \<Sum>B"
  by (metis sum_intro)

lemma boffa_aux2:
  "conway_assm1 x \<Longrightarrow>
  \<Sum>{x\<^bsub>i\<^esub>\<cdot>x\<^bsub>j \<^esub>| i j. i \<in> UNIV \<and> j \<in> UNIV} \<le> \<Sum>{x\<^bsub>i\<cdot>j\<^esub> | i j. i \<in> UNIV \<and> j \<in> UNIV}"
  unfolding conway_assm1_def
  using [[simproc add: finite_Collect]]
  by force

lemma boffa_aux3:
  assumes "conway_assm1 x"
  shows "(\<Sum> {x\<^bsub>i\<^esub> | i. i\<in>UNIV}) + (\<Sum> {x\<^bsub>i \<^esub>\<cdot> x\<^bsub>j\<^esub> | i j . i\<in>UNIV \<and> j\<in>UNIV}) = (\<Sum> {x\<^bsub>i\<^esub> | i. i\<in>UNIV})"
proof -
  from assms
  have "(\<Sum> {x\<^bsub>i\<^esub> | i. i\<in>UNIV}) + (\<Sum> {x\<^bsub>i \<^esub>\<cdot> x\<^bsub>j\<^esub> | i j . i\<in>UNIV \<and> j\<in>UNIV}) \<le> (\<Sum> {x\<^bsub>i\<^esub> | i. i\<in>UNIV})+(\<Sum> {x\<^bsub>i\<cdot>j\<^esub> | i j . i\<in>UNIV \<and> j\<in>UNIV})"
    apply (subst add_iso_r)
    apply (subst boffa_aux2)
    by simp_all
  also have "... = (\<Sum> {x\<^bsub>i\<^esub> | i. i\<in>UNIV})"
    by (metis (mono_tags) add_idem boffa_mon_aux1)
  ultimately show ?thesis
    by (simp add: dual_order.antisym)
qed

lemma conway_monoid_identity:
  assumes "conway_assm1 x" "conway_assm2 x"
  shows "(\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV})\<^sup>\<star> = (\<Sum> {x\<^bsub>i\<^esub>| i. i\<in>UNIV})"
proof -
  have one:"(\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}) \<cdot> (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}) = (1 + (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV})) \<cdot> (1 + (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}))"
    by (metis (mono_tags) assms(2) conway_monoid_split)
  also have "... = 1 + (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}) + ((\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}) \<cdot> (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}))"
    by (metis (lifting, no_types) calculation less_eq_def mult_isol mult_isol_equiv_subdistl mult_oner)
  also have "... = 1 + (\<Sum> {x\<^bsub>i\<^esub>|i. i\<in>UNIV}) + (\<Sum> {x\<^bsub>i \<^esub>\<cdot> x\<^bsub>j\<^esub> | i j. i\<in>UNIV \<and> j\<in>UNIV})"
    by (simp only: dioid_sum_prod finite_UNIV)
  finally have "\<Sum> {x\<^bsub>i\<^esub> |i. i \<in> UNIV} \<cdot> \<Sum> {x\<^bsub>i\<^esub> |i. i \<in> UNIV} = \<Sum> {x\<^bsub>i\<^esub> |i. i \<in> UNIV}"
    apply (simp only:)
proof -
  assume a1: "\<Sum>{x\<^bsub>i\<^esub> |i. i \<in> UNIV} \<cdot> \<Sum>{x\<^bsub>i\<^esub> |i. i \<in> UNIV} = 1 + \<Sum>{x\<^bsub>i\<^esub> |i. i \<in> UNIV} + \<Sum>{x\<^bsub>i\<^esub> \<cdot> x\<^bsub>j\<^esub> |i j. i \<in> UNIV \<and> j \<in> UNIV}"
  hence "\<Sum>{x\<^bsub>R\<^esub> |R. R \<in> UNIV} \<cdot> \<Sum>{x\<^bsub>R\<^esub> |R. R \<in> UNIV} = \<Sum>{x\<^bsub>R\<^esub> |R. R \<in> UNIV}"
    using assms(1) assms(2) boffa_aux3 conway_monoid_split by fastforce
  thus "1 + \<Sum>{x\<^bsub>i\<^esub> |i. i \<in> UNIV} + \<Sum>{x\<^bsub>i\<^esub> \<cdot> x\<^bsub>j\<^esub> |i j. i \<in> UNIV \<and> j \<in> UNIV} = \<Sum>{x\<^bsub>i\<^esub> |i. i \<in> UNIV}"
    using a1 by simp
qed
  thus ?thesis
    by (metis (mono_tags) one B1_algebra_class.R star_trans_eq)
qed

subsection \<open>Conway's Conjectures\<close>

class C0_algebra = strong_conway_dioid +
  assumes C0:  "x \<cdot> y = y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y = y \<cdot> z\<^sup>\<star>"

class C1l_algebra = strong_conway_dioid +
  assumes C1l:  "x \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"

class C1r_algebra = strong_conway_dioid +
  assumes C1r:  "y \<cdot> x \<le> z \<cdot> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> y"

class C2l_algebra = conway_dioid +
  assumes C2l: "x = y \<cdot> x \<Longrightarrow> x = y\<^sup>\<star> \<cdot> x"

class C2r_algebra = conway_dioid +
  assumes C2r: "x = x \<cdot> y \<Longrightarrow> x = x \<cdot> y\<^sup>\<star>"

class C3l_algebra = conway_dioid +
  assumes C3l:  "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"

class C3r_algebra = conway_dioid +
  assumes C3r:  "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"

sublocale C1r_algebra \<subseteq> dual: C1l_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis C13)
  show "x \<odot> y \<le> y \<odot> z \<Longrightarrow> x\<^sup>\<star> \<odot> y \<le> y \<odot> z\<^sup>\<star>"
    by (metis C1r opp_mult_def)
qed

sublocale C2r_algebra \<subseteq> dual: C2l_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show "x = y \<odot> x \<Longrightarrow> x = y\<^sup>\<star> \<odot> x"
    by (metis C2r opp_mult_def)
qed

sublocale C3r_algebra \<subseteq> dual: C3l_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star"
proof
  fix x y z :: 'a
  show "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(x + y)\<^sup>\<star> = (x\<^sup>\<star> \<odot> y)\<^sup>\<star> \<odot> x\<^sup>\<star>"
    by (metis C11_var opp_mult_def)
  show "(x \<odot> y)\<^sup>\<star> = 1 + x \<odot> (y \<odot> x)\<^sup>\<star> \<odot> y"
    by (metis C12 mult.assoc opp_mult_def)
  show " x \<odot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<odot> y \<le> y"
    by (metis C3r opp_mult_def)
qed

lemma (in C3l_algebra) k2_var: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  by (metis local.C3l local.join.le_supE local.join.sup.absorb2 local.subdistl)

instance C2l_algebra \<subseteq> B1_algebra
  by (intro_classes, metis C2l monoid_mult_class.mult.left_neutral mult_oner conway_dioid_class.C12)

instance C2r_algebra \<subseteq>  B1_algebra
  by (intro_classes, metis C2r conway_dioid_class.C12)

text \<open>The following claims are refuted by Nitpick\<close>

lemma (in conway_dioid)
  assumes "x \<cdot> y = y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y = y \<cdot> z\<^sup>\<star>"
  shows "1\<^sup>\<star> = 1"
(*  nitpick [expect=genuine] -- "3-element counterexample"*)
oops

lemma (in conway_dioid)
  assumes "x \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"
  shows "1\<^sup>\<star> = 1"
(*  nitpick [expect=genuine] -- "3-element counterexample"*)
oops

text \<open>The following fact could not be refuted by Nitpick or Quickcheck; but an infinite counterexample exists.\<close>

lemma (in B1_algebra) "x = x\<cdot>y\<longrightarrow> x = x\<cdot>y\<^sup>\<star>"
  oops

instance C3l_algebra \<subseteq> C2l_algebra
  by (intro_classes, metis C3l conway_dioid_class.C12 dual_order.antisym join.sup.cobounded1 mult_isol_var mult_onel order_refl)

sublocale C2l_algebra \<subseteq> C3l_algebra
proof
  fix x y
  show "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"
  proof -
    assume "x \<cdot> y \<le> y"
    hence "(x + 1) \<cdot> y = y"
      by (metis less_eq_def mult_onel distrib_right')
    hence "(x + 1)\<^sup>\<star> \<cdot> y = y"
      by (metis C2l)
    hence "x\<^sup>\<star> \<cdot> y = y"
      by (metis C11 C2l add_comm mult_1_left mult_1_right)
    thus "x\<^sup>\<star> \<cdot> y \<le> y"
      by (metis eq_refl)
  qed
qed

sublocale C1l_algebra \<subseteq> C3l_algebra
  by unfold_locales (metis  mult_oner C1l C12 C13 add_zeror annir)

sublocale C3l_algebra \<subseteq> C1l_algebra
proof
  fix x y z
  show "(x\<^sup>\<star>)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis local.C11_var local.C12 local.C3l order.eq_iff local.eq_refl local.join.sup.absorb2 local.join.sup_ge1 local.mult_onel local.mult_oner)
  show "x \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"
  proof -
    assume assm: "x \<cdot> y \<le> y \<cdot> z"
    have r1:"y \<le> y \<cdot> z\<^sup>\<star>"
      by (metis C12 mult_isol mult_oner order_prop)
    from assm have "x \<cdot> y \<cdot> z\<^sup>\<star> \<le> y \<cdot> z \<cdot>z\<^sup>\<star>"
      by (metis mult_isor)
    also have "... \<le> y \<cdot> z\<^sup>\<star>"
      by (metis local.C12 local.join.sup_commute local.mult_onel local.mult_oner local.subdistl mult_assoc)
    finally have "y + x \<cdot> y \<cdot> z\<^sup>\<star> \<le> y \<cdot> z\<^sup>\<star>"
      by (simp add: r1)
    thus "x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"
      by (metis k2_var mult.assoc)
  qed
qed

sublocale C1l_algebra \<subseteq> C2l_algebra
  by (unfold_locales, metis C12 C3l add.commute  local.join.sup.cobounded1 distrib_right less_eq_def mult_1_left order_refl)

sublocale C3r_algebra \<subseteq> C2r_algebra
  by (unfold_locales, metis C12 C3r add.commute  local.join.sup.cobounded1 distrib_left less_eq_def mult_1_right order_refl)

sublocale C2r_algebra \<subseteq> C3r_algebra
  by unfold_locales (metis dual.C3l opp_mult_def)

sublocale C1r_algebra \<subseteq> C3r_algebra
  by unfold_locales (metis dual.C3l opp_mult_def)

sublocale C3r_algebra \<subseteq> C1r_algebra
  by (unfold_locales, metis dual.C13, metis dual.C1l opp_mult_def)

class C1_algebra = C1l_algebra + C1r_algebra

class C2_algebra = C2l_algebra + C2r_algebra

class C3_algebra = C3l_algebra + C3r_algebra

sublocale C0_algebra \<subseteq> C2_algebra
  by unfold_locales (metis C12 C13 add_zeror annil mult_oner mult_onel C0)+

sublocale C2_algebra \<subseteq> C0_algebra
  by unfold_locales (metis C1l C1r order.eq_iff)

sublocale C2_algebra \<subseteq> C1_algebra ..

sublocale C1_algebra \<subseteq> C2_algebra ..

sublocale C2_algebra \<subseteq> C3_algebra ..

sublocale C3_algebra \<subseteq> C2_algebra ..

subsection \<open>Kozen's Kleene Algebras\<close>

text \<open>Kozen's Kleene Algebras~\<^cite>\<open>"Kozen" and "Kozensemi"\<close>.\<close>

class Kl_base = star_dioid +
  assumes Kl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"

class Kr_base = star_dioid +
  assumes Kr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"

class K1l_algebra = Kl_base +
  assumes star_inductl: "x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y"

class K1r_algebra = Kr_base +
  assumes star_inductr: "y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"

class K2l_algebra = Kl_base +
  assumes star_inductl_var: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"

class K2r_algebra = Kr_base +
  assumes star_inductr_var: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

class K1_algebra = K1l_algebra + K1r_algebra

class K2_algebra = K2l_algebra + K2r_algebra

sublocale K1r_algebra \<subseteq> dual: K1l_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star"
proof
  fix x y z :: 'a
  show  "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "1 + x \<odot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis Kr opp_mult_def)
  show "x \<odot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<odot> y \<le> y"
    by (metis star_inductr opp_mult_def)
qed

sublocale K1l_algebra \<subseteq> B2_algebra
proof
  fix x y :: 'a
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis add_iso_r  local.join.sup.cobounded1 mult_isol mult_oner order_trans Kl)
  show "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    using local.Kl order.eq_iff local.phl_cons1 local.star_inductl by fastforce
  show "\<lbrakk> 1 + x \<le> y; y \<cdot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis local.distrib_right' local.join.le_sup_iff local.join.sup.order_iff local.mult_isol local.mult_oner local.star_inductl)
qed

sublocale K1r_algebra \<subseteq> B2_algebra
  by unfold_locales (metis dual.B21 dual.B22 dual.B23 opp_mult_def)+

sublocale K1l_algebra \<subseteq> C2l_algebra
  by (unfold_locales, metis less_eq_def mult_1_left mult.assoc star_inductl star_invol star_one star_plus_one star_trans_eq troeger)

sublocale C2l_algebra \<subseteq> K1l_algebra
  by (unfold_locales, metis C12 order.eq_iff mult_1_left mult_1_right, metis C3l)

sublocale K1r_algebra \<subseteq> C2r_algebra
    by unfold_locales (metis dual.C2l opp_mult_def)

sublocale C2r_algebra \<subseteq> K1r_algebra
  by (unfold_locales, metis dual.star_unfoldl opp_mult_def, metis C3r)

sublocale K1_algebra \<subseteq> C0_algebra
  by unfold_locales (metis C1l C1r order.eq_iff)

sublocale C0_algebra \<subseteq> K1l_algebra ..

sublocale K2r_algebra \<subseteq> dual: K2l_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star"
proof
  fix x y z :: 'a
  show  "x \<odot> y \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis distrib_right opp_mult_def)
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "1 + x \<odot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
    by (metis opp_mult_def Kr)
  show "z + x \<odot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<odot> z \<le> y"
    by (metis opp_mult_def star_inductr_var)
qed

sublocale K1l_algebra \<subseteq> K2l_algebra
  by unfold_locales (metis local.join.le_supE  star_inductl order_prop subdistl)

sublocale K2l_algebra \<subseteq> K1l_algebra
  by (unfold_locales, simp add: local.star_inductl_var)

sublocale K1r_algebra \<subseteq> K2r_algebra
  by unfold_locales (metis dual.star_inductl_var opp_mult_def)

sublocale K2r_algebra \<subseteq> K1r_algebra
  by unfold_locales (metis dual.star_inductl opp_mult_def)

sublocale kleene_algebra \<subseteq> K1_algebra
  by (unfold_locales, metis star_unfoldl, metis star_inductl_var, metis star_unfoldr, metis star_inductr_var)

sublocale K1_algebra \<subseteq> K2_algebra ..

sublocale K2_algebra \<subseteq> koz: kleene_algebra
  by (unfold_locales, metis Kl, metis star_inductl_var, metis star_inductr_var)

subsection \<open>Salomaa's Axioms\<close>

text \<open>Salomaa's axiomatisations of Regular Algebra~\<^cite>\<open>"Salomaa"\<close>.\<close>

class salomaa_base = star_dioid +
  fixes ewp :: "'a \<Rightarrow> bool"
  assumes S11: "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
  and  EWP : "ewp x \<longleftrightarrow> (\<exists>y. x = 1 + y \<and> \<not> ewp y)"

class Sr_algebra = salomaa_base +
  assumes S12r: "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  and Ar : "\<lbrakk> \<not> ewp y; x = x \<cdot> y + z \<rbrakk> \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"

text \<open>The following claim is ruled out by Nitpick. The unfold law cannot be weakened as in Kleene algebra.\<close>

lemma (in salomaa_base)
  assumes S12r': "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and Ar' : "\<lbrakk> \<not> ewp y; x = x \<cdot> y + z \<rbrakk> \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"
  shows "x\<^sup>\<star> \<le> 1 + x\<^sup>\<star> \<cdot> x"
  (*nitpick [expect=genuine] -- "4-element counterexample"*)
oops

class Sl_algebra = salomaa_base +
  assumes S12l: "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  and Al : "\<lbrakk> \<not> ewp y; x = y\<cdot>x+z \<rbrakk> \<Longrightarrow> x = y\<^sup>\<star>\<cdot>z"

class S_algebra = Sl_algebra + Sr_algebra

sublocale Sl_algebra \<subseteq> dual: Sr_algebra
  "(+)" "(\<odot>)" "1" "0" "(\<le>)" "(<)" "star" "ewp"
proof
  fix x y z :: 'a
  show "(x \<odot> y) \<odot> z = x \<odot> (y \<odot> z)"
    by (metis mult.assoc opp_mult_def)
  show "(x + y) \<odot> z = x \<odot> z + y \<odot> z"
    by (metis distrib_left opp_mult_def)
  show "x + x = x"
    by (metis add_idem)
  show "1 \<odot> x = x"
    by (metis mult_oner opp_mult_def)
  show "x \<odot> 1 = x"
    by (metis mult_onel opp_mult_def)
  show "0 + x = x"
    by (metis add_zerol)
  show "0 \<odot> x = 0"
    by (metis annir times.opp_mult_def)
  show "x \<odot> (y + z) = x \<odot> y + x \<odot> z"
    by (metis opp_mult_def distrib_right')
  show "x \<odot> 0 = 0"
    by (metis annil opp_mult_def)
  show "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis S11)
  show "ewp x = (\<exists>y. x = 1 + y \<and> \<not> ewp y)"
    by (metis EWP)
  show "1 + x\<^sup>\<star> \<odot> x = x\<^sup>\<star>"
    by (metis S12l opp_mult_def)
  show "\<lbrakk> \<not> ewp y; x = x \<odot> y + z \<rbrakk> \<Longrightarrow> x = z \<odot> y\<^sup>\<star>"
    by (metis opp_mult_def Al)
qed

context Sr_algebra
begin

lemma kozen_induct_r:
  assumes "y \<cdot> x + z \<le> y"
  shows "z \<cdot> x\<^sup>\<star> \<le> y"
proof (cases "ewp x")
  case False thus ?thesis
    by (metis add_commute assms local.Ar local.join.le_supE local.join.sup.orderE local.mult_isor)
next
  case True thus ?thesis
  proof -
    assume "ewp x"
    then obtain x' where assm1: "x = 1 + x'" and assm2: "\<not> ewp x'"
      by (metis EWP)
    have "y = (z + y) \<cdot> x\<^sup>\<star>"
      by (metis S11 local.join.le_supE assm1 assm2 assms order.eq_iff less_eq_def Ar subdistl)
    thus "z \<cdot> x\<^sup>\<star> \<le> y"
      by (metis local.join.sup.cobounded1 local.mult_isor)
  qed
qed

end

context Sl_algebra
begin

lemma kozen_induct_l:
  assumes "x \<cdot> y + z \<le> y"
  shows "x\<^sup>\<star>\<cdot>z \<le> y"
  by (metis dual.kozen_induct_r times.opp_mult_def assms)

end

sublocale Sr_algebra \<subseteq> K2r_algebra
  by unfold_locales (metis S12r order_refl, metis add_comm kozen_induct_r)

sublocale Sr_algebra \<subseteq> K1r_algebra ..

sublocale Sl_algebra \<subseteq> K2l_algebra
  by unfold_locales (metis S12l order_refl, metis add_comm kozen_induct_l)

sublocale Sl_algebra \<subseteq> K1l_algebra ..

sublocale S_algebra \<subseteq> K1_algebra ..

sublocale S_algebra \<subseteq> K2_algebra ..

text \<open>The following claim could be refuted.\<close>

lemma (in K2_algebra) "(\<not> 1 \<le>  x) \<longrightarrow>  x = x \<cdot> y + z \<longrightarrow> x = z \<cdot> y\<^sup>\<star>"
oops

class salomaa_conj_r = salomaa_base +
  assumes salomaa_small_unfold:  "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
  assumes salomaa_small_r: "\<lbrakk> \<not> ewp y ; x = x \<cdot> y + 1 \<rbrakk> \<Longrightarrow> x = y\<^sup>\<star>"

sublocale Sr_algebra \<subseteq> salomaa_conj_r
  by (unfold_locales, metis S12r, metis mult_onel Ar)

lemma (in salomaa_conj_r) "(\<not> ewp y) \<and> (x = x \<cdot> y + z) \<longrightarrow> x = z \<cdot> y\<^sup>\<star>"
  (*nitpick [expect=genuine] -- "3-element counterexample"*)
oops

end


theory Graph
imports Main
begin

section\<open>Rooted Graphs\<close>

text \<open>In this section, we model rooted graphs and their sub\hyp{}paths and paths. We give a number
of lemmas that will help proofs in the following theories, but that are very specific to our
approach.\<close>

text \<open>First, we will need the following simple lemma, which is not graph related, but that will
prove useful when we will want to exhibit the last element of a non-empty sequence.\<close>

lemma neq_Nil_conv2 :
  "xs \<noteq> [] = (\<exists> x xs'. xs = xs' @ [x])"
by (induct xs rule : rev_induct, auto)

subsection \<open>Basic Definitions and Properties\<close>

subsubsection \<open>Edges\<close>

text \<open>We model edges by a record \<open>'v edge\<close> which is parameterized by the type \<open>'v\<close>
of vertices. This allows us to represent the red part
of red-black graphs as well as the black part (i.e. LTS) using extensible records (more on this later). Edges have two
components, @{term "src"} and @{term "tgt"}, which respectively give their source and target.\<close>

record 'v edge =
  src   :: "'v"
  tgt   :: "'v"

subsubsection \<open>Rooted graphs\<close>

text \<open>We model rooted graphs by the record \<open>'v rgraph\<close>. It consists of two components: its
root and its set of edges.\<close>

record 'v rgraph =
  root  :: "'v"
  edges :: "'v edge set"

subsubsection \<open>Vertices\<close>

text \<open>The set of vertices of a rooted graph is made of its root and the endpoints of its
edges. Isabelle/HOL provides \emph{extensible records}, i.e.\ it is possible to define records using
existing records by adding components. The following definition suppose that @{term "g"} is of type
\<open>('v,'x) rgraph_scheme\<close>, i.e.\ an object that has at least all the components of a
\<open>'v rgraph\<close>. The second type parameter \<open>'x\<close> stands for the hypothetical type
parameters that such an object could have in addition of the type of vertices \<open>'v\<close>.
Using \<open>('v,'x) rgraph_scheme\<close> instead of \<open>'v rgraph\<close> allows to reuse the following
definition(s) for all type of objects that have at least the components of a rooted graph. For
example, we will reuse the following definition to characterize the set of locations of a LTS (see
\verb?LTS.thy?).\<close>

definition vertices ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v set"
where
  "vertices g = {root g} \<union> src `edges g \<union> tgt ` edges g"

subsubsection \<open>Basic properties of rooted graphs\<close>

text \<open>In the following, we will be only interested in loop free rooted graphs
and in what we call
\emph{well formed rooted graphs}. A well formed rooted graph is rooted graph that has an empty set
of edges or, if this is not the case, has at least one edge whose source is its root.\<close>

abbreviation loop_free ::
  "('v,'x) rgraph_scheme \<Rightarrow> bool"
where
"loop_free g \<equiv> \<forall> e \<in> edges g. src e \<noteq> tgt e"

abbreviation wf_rgraph ::
  "('v,'x) rgraph_scheme \<Rightarrow> bool"
where
"wf_rgraph g \<equiv> root g \<in> src ` edges g = (edges g \<noteq> {})"

text \<open>Even if we are only interested in this kind of rooted graphs, we will not assume the graphs
are loop free or well formed when this is not needed.\<close>

subsubsection \<open>Out-going edges\<close>

text \<open>This abbreviation will prove handy in the following.\<close>

abbreviation out_edges ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v \<Rightarrow> 'v edge set"
where
  "out_edges g v \<equiv> {e \<in> edges g. src e = v}"

subsection \<open>Consistent Edge Sequences, Sub-paths and Paths\<close>

subsubsection \<open>Consistency of a sequence of edges\<close>

text \<open>A sequence of edges @{term "es"} is consistent from
vertex @{term "v1"} to another vertex @{term "v2"} if @{term "v1 = v2"} if it is empty, or, if it is
not empty:
\begin{itemize}
  \item @{term "v1"} is the source of its first element, and
  \item @{term "v2"} is the target of its last element, and
  \item the target of each of its elements is the source of its follower.
\end{itemize}\<close>

fun ces ::
  "'v \<Rightarrow> 'v edge list \<Rightarrow> 'v \<Rightarrow> bool"
where
  "ces v1 [] v2 = (v1 = v2)"
| "ces v1 (e#es) v2 = (src e = v1 \<and> ces (tgt e) es v2)"

subsubsection \<open>Sub-paths and paths\<close>

text \<open>Let @{term "g"} be a rooted graph, @{term "es"} a sequence of edges and @{term "v1"} and
\<open>v2\<close> two vertices. @{term "es"} is a sub-path in @{term "g"} from @{term "v1"} to
@{term "v2"} if:
\begin{itemize}
  \item it is consistent from @{term "v1"} to @{term "v2"},
  \item @{term "v1"} is a vertex of @{term "g"},
  \item all of its elements are edges of @{term "g"}.
\end{itemize}

The second constraint is needed in the case of the empty sequence: without it,
the empty sequence would be a sub-path of @{term "g"} even when @{term "v1"} is not one of
its vertices.\<close>

definition subpath ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v \<Rightarrow> 'v edge list \<Rightarrow> 'v \<Rightarrow> bool"
where
  "subpath g v1 es v2 \<equiv> ces v1 es v2 \<and> v1 \<in> vertices g \<and> set es \<subseteq> edges g"

text \<open>Let @{term "es"} be a sub-path of @{term "g"} leading from @{term "v1"} to @{term "v2"}.
@{term "v1"} and @{term "v2"} are both vertices of @{term "g"}.\<close>

lemma lst_of_sp_is_vert :
  assumes "subpath g v1 es v2"
  shows   "v2 \<in> vertices g"
using assms by (induction es arbitrary : v1, auto simp add: subpath_def vertices_def)

text \<open>The empty sequence of edges is a sub-path from @{term "v1"} to @{term "v2"} if and only if
they are equal and belong to the graph.\<close>

text \<open>The empty sequence is a sub-path from the root of any rooted graph.\<close>

lemma
  "subpath g (root g) [] (root g)"
by (auto simp add : vertices_def subpath_def)

text \<open>In the following, we will not always be interested in the final vertex of a sub-path. We
will use the abbreviation @{term "subpath_from"} whenever this final vertex has no importance, and
@{term subpath} otherwise.\<close>

abbreviation subpath_from  ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v \<Rightarrow> 'v edge list \<Rightarrow> bool"
where
  "subpath_from g v es \<equiv> \<exists> v'. subpath g v es v'"

abbreviation subpaths_from ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v \<Rightarrow> 'v edge list set"
where
  "subpaths_from g v \<equiv> {es. subpath_from g v es}"

text \<open>A path is a sub-path starting at the root of the graph.\<close>

abbreviation path ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v edge list \<Rightarrow> 'v \<Rightarrow> bool"
where
  "path g es v \<equiv> subpath g (root g) es v"

abbreviation paths ::
  "('a,'b) rgraph_scheme \<Rightarrow> 'a edge list set"
where
  "paths g \<equiv> {es. \<exists> v. path g es v}"

text \<open>The empty sequence is a path of any rooted graph.\<close>

lemma
  "[] \<in> paths g"
by (auto simp add : subpath_def vertices_def)

text \<open>Some useful simplification lemmas for @{term "subpath"}.\<close>

lemma sp_one :
  "subpath g v1 [e] v2 = (src e = v1 \<and> e \<in> edges g \<and> tgt e = v2)"
by (auto simp add : subpath_def vertices_def)

lemma sp_Cons :
  "subpath g v1 (e#es) v2 = (src e = v1 \<and> e \<in> edges g \<and> subpath g (tgt e) es v2)"
by (auto simp add : subpath_def vertices_def)

lemma sp_append_one :
  "subpath g v1 (es@[e]) v2 = (subpath g v1 es (src e) \<and> e \<in> edges g \<and> tgt e = v2)"
by (induct es arbitrary : v1, auto simp add : subpath_def vertices_def)

lemma sp_append :
  "subpath g v1 (es1@es2) v2 = (\<exists> v. subpath g v1 es1 v \<and> subpath g v es2 v2)"
by (induct es1 arbitrary : v1)
   ((simp add : subpath_def, fast),
    (auto simp add : fst_of_sp_is_vert sp_Cons))

text \<open>A sub-path leads to a unique vertex.\<close>

lemma sp_same_src_imp_same_tgt :
  assumes "subpath g v es v1"
  assumes "subpath g v es v2"
  shows   "v1 = v2"
using assms
by (induct es arbitrary : v)
   (auto simp add :  sp_Cons subpath_def vertices_def)

text \<open>In the following, we are interested in the evolution of the set of sub-paths of our symbolic
execution graph after symbolic execution of a transition from the LTS representation of the program
under analysis. Symbolic execution of a transition results in adding to the graph a new edge whose
source is already a vertex of this graph, but not its target. The following lemma describes
sub-paths ending in the target of such an edge.\<close>

text \<open>Let @{term "e"} be an edge whose target has not out-going edges. A sub-path @{term "es"}
containing @{term "e"} ends by @{term "e"} and this occurrence of @{term "e"} is unique along
@{term "es"}.\<close>

lemma sp_through_de_decomp :
  assumes "out_edges g (tgt e) = {}"
  assumes "subpath g v1 es v2"
  assumes "e \<in> set es"
  shows   "\<exists> es'. es = es' @ [e] \<and> e \<notin> set es'"
using assms(2,3)
proof (induction es arbitrary : v1)
  case Nil thus ?case by simp
next
  case (Cons e' es)

  hence "e = e' \<or> (e \<noteq> e' \<and> e \<in> set es)" by auto

  thus ?case
  proof (elim disjE, goal_cases)
    case 1 thus ?case
    using assms(1) Cons
    by (rule_tac ?x="[]" in exI) (cases es, auto simp add: sp_Cons)
  next
    case 2 thus ?case
    using assms(1) Cons(1)[of "tgt e'"] Cons(2)
    by (auto simp add : sp_Cons)
  qed
qed

subsection \<open>Adding Edges\<close>

text \<open>This definition and the following lemma are here mainly to ease the definitions and proofs
in the next theories.\<close>

abbreviation add_edge ::
  "('v,'x) rgraph_scheme \<Rightarrow> 'v edge \<Rightarrow> ('v,'x) rgraph_scheme"
where
  "add_edge g e \<equiv> rgraph.edges_update (\<lambda> edges. edges \<union> {e}) g"

text \<open>Let @{term "es"} be a sub-path from a vertex other than the target of @{term "e"} in the
graph obtained from @{term "g"} by the addition of edge @{term "e"}. Moreover, assume that the
target of @{term "e"} is not a vertex of @{term "g"}. Then @{term "e"} is an element of
@{term "es"}.\<close>

lemma sp_ends_in_tgt_imp_mem :
  assumes "tgt e \<notin> vertices g"
  assumes "v \<noteq> tgt e"
  assumes "subpath (add_edge g e) v es (tgt e)"
  shows   "e \<in> set es"
proof -
  have "es \<noteq> []" using assms(2,3) by (auto simp add : subpath_def)

  then obtain e' es' where "es = es' @ [e']" by (simp add : neq_Nil_conv2) blast

  thus ?thesis using assms(1,3) by (auto simp add : sp_append_one vertices_def image_def)
qed

subsection \<open>Trees\<close>

text \<open>We define trees as rooted-graphs in which there exists a unique path leading to each vertex.\<close>

definition is_tree ::
  "('v,'x) rgraph_scheme \<Rightarrow> bool"
where
  "is_tree g \<equiv> \<forall> l \<in> Graph.vertices g. \<exists>! p. Graph.path g p l"

text \<open>The empty graph is thus a tree.\<close>

lemma empty_graph_is_tree :
  assumes "edges g = {}"
  shows   "is_tree g"
using assms by (auto simp add : is_tree_def subpath_def vertices_def)

end


theory SymmetricR2Shapes
  imports Green
begin

context R2
begin

lemma valid_path_valid_swap:
  assumes "valid_path (\<lambda>x::real. ((f x)::real, (g x)::real))"
  shows "valid_path (prod.swap o (\<lambda>x. (f x, g x)))"
  unfolding o_def valid_path_def piecewise_C1_differentiable_on_def swap_simp
proof (intro conjI)
  show "continuous_on {0..1} (\<lambda>x. (g x, f x))"
    using assms
    using continuous_on_Pair continuous_on_componentwise[where f = "(\<lambda>x. (f x, g x))"]
    by (auto simp add: real_pair_basis valid_path_def piecewise_C1_differentiable_on_def)
  show "\<exists>S. finite S \<and> (\<lambda>x. (g x, f x)) C1_differentiable_on {0..1} - S"
  proof -
    obtain S where "finite S" and S: "(\<lambda>x. (f x, g x)) C1_differentiable_on {0..1} - S"
      using assms
      by (auto simp add: real_pair_basis valid_path_def piecewise_C1_differentiable_on_def)
    have 0: "f C1_differentiable_on {0..1} - S" using S assms
      using C1_diff_components_2[of "(1,0)" "(\<lambda>x. (f x, g x))"]
      by (auto simp add: real_pair_basis algebra_simps)
    have 1: "g C1_differentiable_on {0..1} - S" using S assms
      using C1_diff_components_2 [of "(0,1)", OF _ S] real_pair_basis by fastforce
    have *: "(\<lambda>x. (g x, f x)) C1_differentiable_on {0..1} - S"
      using 0 1 C1_differentiable_on_components[where f = "(\<lambda>x. (g x, f x))"]
      by (auto simp add: real_pair_basis valid_path_def piecewise_C1_differentiable_on_def)
    then show ?thesis using \<open>finite S\<close> by auto
  qed
qed

lemma pair_fun_components: "C = (\<lambda>x. (C x \<bullet> i, C x \<bullet> j))"
  by (simp add: i_is_x_axis inner_Pair_0 j_is_y_axis)

lemma swap_pair_fun: "(\<lambda>y. prod.swap (C (y, 0))) =  (\<lambda>x. (C (x, 0) \<bullet> j, C (x, 0) \<bullet> i))"
  by (simp add: prod.swap_def i_is_x_axis inner_Pair_0 j_is_y_axis)

lemma swap_pair_fun': "(\<lambda>y. prod.swap (C (y, 1))) =  (\<lambda>x. (C (x, 1) \<bullet> j, C (x, 1) \<bullet> i))"
  by (simp add: prod.swap_def i_is_x_axis inner_Pair_0 j_is_y_axis)

lemma swap_pair_fun'': "(\<lambda>y. prod.swap (C (0, y))) =  (\<lambda>x. (C (0,x) \<bullet> j, C (0,x) \<bullet> i))"
  by (simp add: prod.swap_def i_is_x_axis inner_Pair_0 j_is_y_axis)

lemma swap_pair_fun''': "(\<lambda>y. prod.swap (C (1, y))) =  (\<lambda>x. (C (1,x) \<bullet> j, C (1,x) \<bullet> i))"
  by (simp add: prod.swap_def i_is_x_axis inner_Pair_0 j_is_y_axis)

lemma swap_valid_boundaries:
  assumes "\<forall>(k,\<gamma>)\<in>boundary C. valid_path \<gamma>"
  assumes "(k,\<gamma>)\<in>boundary (prod.swap o C o prod.swap)"
  shows "valid_path \<gamma>"
  using assms
    valid_path_valid_swap[of "\<lambda>x. (\<lambda>x. C (x, 0)) x \<bullet> i" "\<lambda>x. (\<lambda>x. C (x, 0)) x \<bullet> j"] pair_fun_components[of "(\<lambda>x. C (x, 0))"]
    pair_fun_components[of "(\<lambda>y. C (y, 0))"]
    valid_path_valid_swap[of "\<lambda>x. (\<lambda>y. C (y, 1)) x \<bullet> i" "\<lambda>x. (\<lambda>y. C (y, 1)) x \<bullet> j"] pair_fun_components[of "(\<lambda>y. C (y, 1))"]
    pair_fun_components[of "(\<lambda>x. C (x, 1))"]
    valid_path_valid_swap[of "\<lambda>x. (\<lambda>y. C (1,y)) x \<bullet> i" "\<lambda>x. (\<lambda>y. C (1,y)) x \<bullet> j"] pair_fun_components[of "(\<lambda>y. C (1,y))"]
    pair_fun_components[of "(\<lambda>x. C (1,x))"]
    valid_path_valid_swap[of "\<lambda>x. (\<lambda>y. C (0,y)) x \<bullet> i" "\<lambda>x. (\<lambda>y. C (0,y)) x \<bullet> j"] pair_fun_components[of "(\<lambda>y. C (0,y))"]
    pair_fun_components[of "(\<lambda>x. C (0,x))"]
  by (auto simp add: boundary_def horizontal_boundary_def vertical_boundary_def
       o_def real_pair_basis swap_pair_fun swap_pair_fun' swap_pair_fun'' swap_pair_fun''')

lemma prod_comp_eq:
  assumes "f = prod.swap o g"
  shows "prod.swap o f  = g"
  using swap_comp_swap assms
  by fastforce

lemma swap_typeI_is_typeII:
  assumes "typeI_twoCube C"
  shows "typeII_twoCube (prod.swap o C o prod.swap)"
proof (simp add: typeI_twoCube_def typeII_twoCube_def)
  obtain a b g1 g2 where C: " a < b "
    "(\<forall>x\<in>{a..b}. g2 x \<le> g1 x) "
    "cubeImage C = {(x, y). x \<in> {a..b} \<and> y \<in> {g2 x..g1 x}} "
    "C = (\<lambda>(x, y). ((1 - x) * a + x * b, (1 - y) * g2 ((1 - x) * a + x * b) + y * g1 ((1 - x) * a + x * b))) "
    "g1 piecewise_C1_differentiable_on {a..b} "
    "g2 piecewise_C1_differentiable_on {a..b}"
    using typeI_cube_explicit_spec[OF assms]
    by blast
  show "\<exists>a b. a < b \<and>
              (\<exists>g1 g2. (\<forall>x\<in>{a..b}. g2 x \<le> g1 x) \<and>
                  prod.swap \<circ> C \<circ> prod.swap =
                  (\<lambda>(y, x). ((1 - y) * g2 ((1 - x) * a + x * b) + y * g1 ((1 - x) * a + x * b), (1 - x) * a + x * b)) \<and>
                  g1 piecewise_C1_differentiable_on {a..b} \<and> g2 piecewise_C1_differentiable_on {a..b})"
    using C by (fastforce simp add: prod.swap_def o_def)
qed

lemma valid_cube_valid_swap:
  assumes "valid_two_cube C"
  shows "valid_two_cube (prod.swap o C o prod.swap)"
  using assms unfolding valid_two_cube_def boundary_def horizontal_boundary_def vertical_boundary_def
  apply (auto simp: card_insert_if  split: if_split_asm)
   apply (metis swap_swap)+
  done

lemma twoChainVertDiv_of_itself:
  assumes "finite C"
    "\<forall>(k, \<gamma>)\<in>(two_chain_boundary C). valid_path \<gamma>"
  shows "only_vertical_division (two_chain_boundary C) C"
proof(clarsimp simp add: only_vertical_division_def)
  show "\<exists>\<V> \<H>. finite \<H> \<and> finite \<V> \<and>
              (\<forall>x\<in>\<V>. case x of (k, \<gamma>) \<Rightarrow> \<exists>x\<in>two_chain_vertical_boundary C. case x of (k', \<gamma>') \<Rightarrow> \<exists>a\<in>{0..1}. \<exists>b\<in>{0..1}. a \<le> b \<and> subpath a b \<gamma>' = \<gamma>) \<and>
              (common_sudiv_exists (two_chain_horizontal_boundary C) \<H> \<or>
               common_reparam_exists \<H> (two_chain_horizontal_boundary C)) \<and>
              boundary_chain \<H> \<and> two_chain_boundary C = \<V> \<union> \<H> \<and> (\<forall>(k,\<gamma>)\<in>\<H>. valid_path \<gamma>)"
  proof (intro exI)
    let ?\<H> = "two_chain_horizontal_boundary C"
    have 0: "\<forall>(k,\<gamma>)\<in>?\<H>. valid_path \<gamma>" using assms(2)
      by (auto simp add: two_chain_horizontal_boundary_def two_chain_boundary_def boundary_def)
    have "\<And>a b. (a, b) \<in> two_chain_vertical_boundary C \<Longrightarrow>
                  \<exists>x\<in>two_chain_vertical_boundary C. case x of (k', \<gamma>') \<Rightarrow> \<exists>a\<in>{0..1}. \<exists>c\<in>{0..1}. a \<le> c \<and> subpath a c \<gamma>' = b"
      by (metis (mono_tags, lifting) atLeastAtMost_iff case_prod_conv le_numeral_extra(1) order_refl subpath_trivial)
    moreover have "common_sudiv_exists ?\<H> ?\<H>"
      using gen_common_boundary_subdiv_exists_refl_twochain_boundary[OF 0 two_chain_horizontal_boundary_is_boundary_chain]
      by auto
    moreover have "boundary_chain ?\<H>"
      using two_chain_horizontal_boundary_is_boundary_chain by auto
    moreover have "\<And>a b. (a, b) \<in> two_chain_boundary C \<Longrightarrow> (a, b) \<notin> ?\<H> \<Longrightarrow> (a, b) \<in> two_chain_vertical_boundary C"
      by (auto simp add: two_chain_boundary_def two_chain_horizontal_boundary_def two_chain_vertical_boundary_def boundary_def)
    moreover have "\<And>a b. (a, b) \<in> two_chain_vertical_boundary C \<Longrightarrow> (a, b) \<in> two_chain_boundary C"
      "\<And>a b. (a, b) \<in> ?\<H> \<Longrightarrow> (a, b) \<in> two_chain_boundary C"
      by (auto simp add: two_chain_boundary_def two_chain_horizontal_boundary_def two_chain_vertical_boundary_def boundary_def)
    moreover have "\<And>a b. (a, b) \<in> ?\<H> \<Longrightarrow> valid_path b"
      using 0 by blast
    ultimately show "finite ?\<H> \<and>
           finite (two_chain_vertical_boundary C) \<and>
           (\<forall>x\<in>two_chain_vertical_boundary C.
               case x of (k, \<gamma>) \<Rightarrow> \<exists>x\<in>two_chain_vertical_boundary C. case x of (k', \<gamma>') \<Rightarrow> \<exists>a\<in>{0..1}. \<exists>b\<in>{0..1}. a \<le> b \<and> subpath a b \<gamma>' = \<gamma>) \<and>
           (common_sudiv_exists ?\<H> ?\<H> \<or>
            common_reparam_exists ?\<H> ?\<H>) \<and>
           boundary_chain ?\<H> \<and> two_chain_boundary C = two_chain_vertical_boundary C \<union> ?\<H> \<and> (\<forall>(k,\<gamma>)\<in>?\<H>. valid_path \<gamma>)"
      by (auto simp add: finite_two_chain_horizontal_boundary[OF assms(1)] finite_two_chain_vertical_boundary[OF assms(1)])
  qed
qed

end

definition x_coord where "x_coord \<equiv> (\<lambda>t::real. t - 1/2)"

lemma x_coord_smooth: "x_coord C1_differentiable_on {a..b}"
  by (simp add: x_coord_def)

lemma x_coord_bounds:
  assumes "(0::real) \<le> x" "x \<le> 1"
  shows "-1/2 \<le> x_coord x \<and> x_coord x \<le> 1/2"
  using assms by(auto simp add: x_coord_def)

lemma x_coord_img: "x_coord ` {(0::real)..1} = {-1/2 .. 1/2}"
  by (auto simp add: x_coord_def image_def algebra_simps)

lemma x_coord_back_img: "finite ({0..1} \<inter> x_coord -` {x::real})"
  by (simp add: finite_vimageI inj_on_def x_coord_def)

abbreviation "rot_x t1 t2 \<equiv> (if (t1 - 1/2) \<le> 0 then (2 * t2 - 1) * t1 + 1/2 ::real else 2 * t2 - 2 * t1 * t2 +t1 -1/2::real)"

lemma rot_x_ivl:
  assumes "0 \<le> x"
    "x \<le> 1"
    "0 \<le> y"
    "y \<le> 1"
  shows "0 \<le> rot_x x y \<and> rot_x x y \<le> 1"
proof -
  have i: "\<And>a::real. a \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1  \<Longrightarrow> -1/2 < a \<Longrightarrow> (a * (1 - 2*y) \<le> 1/2)"
  proof -
    have 0: "\<And>a::real. a \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1  \<Longrightarrow> -1/2 < a \<Longrightarrow> (-a \<le> 1/2)"
      by (sos "((((A<0 * A<1) * R<1) + (R<1 * (R<1/4 * [2*a + 1]^2))))")
    have 1: "\<And>a. a \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1  \<Longrightarrow> -1/2 < a \<Longrightarrow> (a * (1 - 2*y) \<le> -a)"
      by (sos "((((A<0 * A<1) * R<1) + (((A<=0 * (A<1 * R<1)) * (R<2/3 * [1]^2)) + (((A<=0 * (A<=2 * R<1)) * (R<2/3 * [1]^2)) + ((A<=0 * (A<=2 * (A<0 * R<1))) * (R<2/3 * [1]^2))))))")
    show "\<And>a::real. a \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1 \<Longrightarrow> -1/2 < a \<Longrightarrow> (a * (1 - 2*y) \<le> 1/2)" using 0 1 by force
  qed
  have *: "(x * 2 + y * 4 \<le> 3 + x * (y * 4)) =  ( (x-1) \<le> 1/2+ (x-1) * (y * 2))"
    by (sos "((((A<0 * R<1) + ((A<=0 * R<1) * (R<2 * [1]^2)))) & (((A<0 * R<1) + ((A<=0 * R<1) * (R<1/2 * [1]^2)))))")
  show ?thesis
    using assms
    apply(auto simp add: algebra_simps divide_simps linorder_class.not_le)
       apply (sos "(((A<0 * R<1) + (((A<=2 * (A<=3 * R<1)) * (R<1 * [1]^2)) + (((A<=1 * R<1) * (R<1 * [1]^2)) + ((A<=0 * (A<=1 * R<1)) * (R<2 * [1]^2))))))")
      apply (sos "(((A<0 * R<1) + (((A<=2 * R<1) * (R<1 * [1]^2)) + (((A<=1 * (A<=3 * R<1)) * (R<1 * [1]^2)) + ((A<=0 * (A<=2 * R<1)) * (R<2 * [1]^2))))))")
    using i[of "(x::real) - 1"] affine_ineq
     apply (fastforce simp: algebra_simps *)+
    done
qed

end


theory FilteredList
  imports MoreCoinductiveList2
begin

subsection \<open>More on filtered lists\<close>

text \<open>We will reason about (co-inductive) lists with distinct elements.
      However, for our setting, this 'distinct' property only holds on the list after filtering.
      For this reason, we need some additional lemmas.\<close>

text \<open>Taking a sublist preserves distinctness after filtering.\<close>
lemma ldistinct_lfilter_ltake[intro]:
  assumes "ldistinct (lfilter P xs)"
  shows "ldistinct (lfilter P (ltake x xs))"
  using assms
  by(induct xs,force,force
    ,(* sledgehammer found this gem to prove the inductive step via lfilter_lappend_lfinite!
        We will use this strategy ourselves later on *)
     metis lappend_ltake_ldrop ldistinct_lappend lfilter_lappend_lfinite lfinite_LConsI lfinite_ltake)

text \<open>The function lfind is used in multiple proofs, all are introduced to prove ltake_lfilter.\<close>
definition lfind where "lfind P lst = (LEAST i. P (lst $ i))"

lemma lfilter_lfind:
  assumes "lfilter P lst \<noteq> LNil"
  shows "P (lst $ lfind P lst)" (is ?g1)
        "P (lst $ y) \<Longrightarrow> lfind P lst \<le> y" (is "?a \<Longrightarrow> ?g2")
        "lfind P lst < llength lst" (is ?g3)
proof -
  let ?I = "{n. enat n < llength lst \<and> P (lst $ n)}"
  let ?xs = lst
  from assms[unfolded lfilter_conv_lnths] lset_LNil
  have "lset (lnths lst {n. enat n < llength lst \<and> P (lst $ n)}) \<noteq> {}" by auto
  hence "{?xs $ i |i. enat i < llength ?xs \<and> i \<in> ?I} \<noteq> {}" using lset_lnths[of ?xs ?I] by metis
  then obtain i where p:"P (lst $ i)" "i < llength lst" by auto
  from p show ?g1 using LeastI lfind_def by metis
  from p show "?a \<Longrightarrow> ?g2" using Least_le lfind_def by metis
  from p show ?g3 using Least_le lfind_def by (metis enat_ord_simps(1) le_less_trans)
qed

lemma ltake_lfind_lset:
  assumes "x \<in> lset (ltake (enat (lfind P lst)) lst)"
  shows "\<not> P x"
proof(cases "lfilter P (ltake (enat (lfind P lst)) lst) = LNil")
  case True
  then show ?thesis using assms unfolding lfilter_eq_LNil by auto
next
  case False
  from assms[unfolded in_lset_conv_lnth] obtain n where
    n:"enat n < llength (ltake (enat (lfind P lst)) lst)" "ltake (enat (lfind P lst)) lst $ n = x"
    by blast
  { assume a:"P x"
      (* The idea of this {block} is that the element n must come after (lfind P lst) by lfilter_lfind(2)
     but this contradicts n(1).
     However, in the last step when writing this proof, sledgehammer found one that didn't use
       any of my previous steps, so here's a one-liner: *)
    from n Coinductive_List.lset_ltake False a enat_ord_simps(1) leD lfilter_empty_conv lfilter_lfind(2,3) llength_ltake' lnth_ltake subset_eq
    have False by metis
  }
  then show ?thesis by blast
qed

lemma ltake_lfind_conv:
  assumes "lfilter P lst \<noteq> LNil"
  shows "ltake (lfind P lst) lst = ltakeWhile (Not o P) lst" (is "?t1 = ?t2")
        "ldrop (lfind P lst) lst = ldropWhile (Not o P) lst" (is "?t3 = ?t4")
proof -
  have lfin:"lfinite ?t1" by simp
  have [simp]:"min (enat (lfind P lst)) (llength lst) = (lfind P lst)"
    using lfilter_lfind(3)[OF assms] by (metis min.strict_order_iff)
  have l1:"llength ?t1 = lfind P lst" by simp
  from ltake_lfind_lset ltakeWhile_all
  have t:"ltakeWhile (Not o P) ?t1 = ?t1" unfolding o_def by metis
  have inset:"lset (ltake (enat (lfind P lst)) lst) \<subseteq> {x. (Not \<circ> P) x}"
    using ltake_lfind_lset[of _ P lst] by auto (* for use in ltakeWhile_lappend2 *)
  have isnull:"ltakeWhile (Not \<circ> P) (ldrop (enat (lfind P lst)) lst) = LNil"
    apply(cases "ldrop (enat (lfind P lst)) lst")
    using lfilter_lfind(1)[OF assms] lhd_ldrop[OF lfilter_lfind(3)[OF assms]]
    by auto
  have "ltakeWhile (Not o P) ?t1 = ltakeWhile (Not o P) (lappend ?t1 ?t3)"
    unfolding ltakeWhile_lappend2[OF inset] isnull lappend_LNil2 t..
  hence leneq:"llength ?t1 = llength ?t2" using t l1 lappend_ltake_ldrop by metis
  have "lappend ?t1 ?t3 = lappend ?t2 ?t4"
     unfolding lappend_ltakeWhile_ldropWhile[of "Not \<circ> P" lst]
               lappend_ltake_ldrop[of "lfind P lst" lst]
     by simp
  from this[unfolded lappend_eq_lappend_conv[OF leneq]] lfin
  show "?t1 = ?t2" "?t3 = ?t4" by auto
qed

lemma lfilter_hdtl:
  assumes "lfilter P lst \<noteq> LNil"
  shows "\<exists> n. LCons (lhd (lfilter P lst)) LNil = lfilter P (ltake (enat n) lst) \<and>
              ltl (lfilter P lst) = lfilter P (ldrop (enat n) lst)"
proof(standard,standard)
  note * = lfilter_lfind[OF assms]
  let ?n = "Suc (lfind P lst)"
  let ?ltake = "ltake (enat ?n) lst"
  have ltake:"lappend (ltakeWhile (Not \<circ> P) ?ltake) (ldropWhile (Not \<circ> P) ?ltake) = ?ltake"
      (is "lappend ?ltw ?ldw = _")
      using lappend_ltakeWhile_ldropWhile by blast
  have "llength ?ldw \<le> 1"
      unfolding ldropWhile_lappend ltake_Suc_conv_snoc_lnth[OF *(3)]
      using ltake_lfind_lset[of _ P lst] by (auto intro:* simp:one_eSuc)
  hence null:"lnull (ltl (ldropWhile (Not \<circ> P) ?ltake))"
      unfolding llength_eq_0[symmetric] llength_ltl
      by (metis dual_order.order_iff_strict enat_ile epred_0 epred_1 iless_Suc_eq le_zero_eq one_eSuc one_enat_def)
  have e:"enat (lfind P lst) < enat (Suc (lfind P lst))" by auto
    from * have "P (?ltake $ lfind P lst)" using lnth_ltake[OF e] by metis
  hence nonnull:"\<not> lnull (lfilter P ?ltake)" unfolding lnull_lfilter
      by (metis "*"(3) e in_lset_conv_lnth leI llength_ltake' ltake_all)

  show a:"LCons (lhd (lfilter P lst)) LNil = lfilter P ?ltake" (is "?lhs = ?rhs")
  proof -
    have "lhd (lfilter P ?ltake) = lhd (lfilter P lst)"
      by(rule lprefix_lhdD[OF lprefix_lfilterI[OF ltake_is_lprefix] nonnull])
    hence h:"lhd ?lhs = lhd ?rhs" by simp
    have "ltl ?rhs = LNil"
      unfolding ltl_lfilter using null by (metis lfilter_LNil llist.collapse(1))
    hence t:"ltl ?lhs = ltl ?rhs" by simp
    have flt:"?rhs \<noteq> LNil" using nonnull by fastforce
    show ?thesis by(rule llist_eq_lcons[of ?lhs ?rhs,OF _ flt h t],auto)
  qed

  from lappend_ltake_ldrop[of ?n lst] lappend_ltakeWhile_ldropWhile[of "Not \<circ> P" lst]
  have "lappend (ltake ?n lst) (ldrop ?n lst) = lappend (ltakeWhile (Not \<circ> P) lst) (ldropWhile (Not \<circ> P) lst)"
    by auto
  from ltake_lfind_conv(2)[OF assms]
  have "ltl (ldropWhile (Not \<circ> P) lst) = ldrop (enat (Suc (lfind P lst))) lst"
    unfolding ldrop_eSuc_conv_ltl eSuc_enat[symmetric] by simp
  thus "ltl (lfilter P lst) = lfilter P (ldrop (enat ?n) lst)" unfolding ltl_lfilter by metis
qed

lemma ltake_lfilter:
  shows "\<exists> n. ltake (enat x) (lfilter P lst) = lfilter P (ltake (enat n) lst) \<and> ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)"
proof(induct x)
  case 0
  then show ?case by (metis LNil_eq_ltake_iff ldrop_enat ldropn_0 lfilter_code(1) zero_enat_def)
next
  let ?fP = "lfilter P"
  case (Suc x)
  then obtain n where n:"ltake (enat x) (?fP lst) = ?fP (ltake (enat n) lst)"
    "ldrop (enat x) (lfilter P lst) = lfilter P (ldrop (enat n) lst)" by blast
  consider "lfilter P (ldrop (enat n) lst) \<noteq> LNil \<and> x < llength (?fP lst)" |
    "lfilter P (ldrop (enat n) lst) = LNil" | "x \<ge> llength (?fP lst)" by force
  then show ?case proof(cases)
    case 1
    hence *:"lfilter P (ldrop (enat n) lst) \<noteq> LNil" "enat x < llength (lfilter P lst)" by auto
    from lappend_ltake_ldrop have "lst = lappend (ltake (enat n) lst) (ldrop (enat n) lst)" by metis
    from lfilter_hdtl[OF *(1)] obtain delta where
      delta:"LCons (lhd (?fP (ldrop (enat n) lst))) LNil = ?fP (ltake (enat delta) (ldrop (enat n) lst))"
      "ltl (lfilter P (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta) (ldrop (enat n) lst))" by blast
    have "ltake (enat (Suc x)) (?fP lst) = lappend (?fP (ltake (enat n) lst)) (LCons (?fP lst $ x) LNil)"
      using n ltake_Suc_conv_snoc_lnth * by metis
    also have "?fP lst $ x = ?fP lst $ (the_enat x)" by auto
    also have "\<dots> = lhd (ldrop x (?fP lst))" using lhd_ldrop[symmetric] *(2) by metis
    also have "\<dots> = lhd (?fP (ldrop (enat n) lst))" using n by metis
    also note delta(1)
    finally have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat (n + delta)) lst)"
      using ltake_plus_conv_lappend
      by (metis infinite_small_llength lfilter_lappend_lfinite llength_ltake' ltake_all min.strict_order_iff not_less plus_enat_simps(1))
    have "ldrop (enat (Suc x)) (?fP lst) = ltl (ldrop x (?fP lst))" by (simp add: ltl_ldropn ldrop_eSuc_ltl ldrop_enat)
    also have "ldrop x (?fP lst) = ?fP (ldrop (enat n) lst)" using n by metis
    also note delta(2)
    also have "lfilter P (ldrop (enat delta) (ldrop (enat n) lst)) = lfilter P (ldrop (enat delta + enat n) lst)"
      by simp
    also have "(enat delta + enat n) = enat (n + delta)" by simp
    finally have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat (n + delta)) lst)".
    from take_part drop_part show ?thesis by blast
  next
  case 2
    note * = 2 lappend_ltake_ldrop[of "enat n" lst] Suc_llength infinite_small_llength
             lappend_LNil2 leI lfilter_lappend_lfinite llength_ltake' min.strict_order_iff n
    have take_part:"ltake (enat (Suc x)) (?fP lst) = ?fP (ltake (enat n) lst)"
      using * by (smt (z3) ltake_all)
    from 2 have drop_part:"ldrop (enat (Suc x)) (?fP lst) = ?fP (ldrop (enat n) lst)"
      using * by (smt (z3) ldrop_all)
    from take_part drop_part show ?thesis by blast
  next
  case 3
    then show ?thesis using n dual_order.order_iff_strict eSuc_enat iless_Suc_eq le_less_trans ltake_all ldrop_all
         by metis
  qed
qed

lemma filter_obtain_two:
  assumes "i < j" "j < length (filter P lst)"
  shows "\<exists> i2 j2. i2 < j2 \<and> j2 < length lst \<and> lst ! i2 = filter P lst ! i \<and> lst ! j2 = filter P lst ! j"
  using assms
proof(induct lst arbitrary: i j)
  case (Cons a lst)
  then obtain jprev where jprev:"j = Suc jprev" using lessE by metis
  show ?case proof(cases "P a")
    case True
    hence lnth[simp]:"length (filter P (a # lst)) = Suc (length (filter P lst))" by auto
    show ?thesis proof(cases i)
      case 0
      from jprev True Cons(3) have "jprev < length (filter P lst) " by auto
      from nth_mem[OF this]
      have "filter P lst ! jprev \<in> set lst" by auto
      from this[unfolded in_set_conv_nth] obtain j2 where
        "j2<length lst" "lst ! j2 = filter P lst ! jprev" by blast
      hence "0 < Suc j2" "Suc j2 < length (a # lst)"
        "(a # lst) ! 0 = filter P (a # lst) ! i"
        "(a # lst) ! Suc j2 = filter P (a # lst) ! j" using 0 True jprev by auto
      then show ?thesis by blast
    next
      case (Suc nat)
      then obtain jprev where jprev:"j = Suc jprev" using Cons lessE by metis
      hence "nat < jprev" "jprev < length (filter P lst)" using Cons Suc lnth by auto
      from Cons(1)[OF this] obtain i2 j2 where "i2 < j2" "j2 < length lst"
        "lst ! i2 = filter P lst ! nat" "lst ! j2 = filter P lst ! jprev" by blast
      hence "Suc i2 < Suc j2" "Suc j2 < length (a # lst)"
        "(a # lst) ! Suc i2 = filter P (a # lst) ! Suc nat"
        "(a # lst) ! Suc j2 = filter P (a # lst) ! Suc jprev" using lnth by auto
      then show ?thesis unfolding jprev[symmetric] Suc[symmetric] by blast
    qed
  next
    case False
    hence [simp]: "filter P (a # lst) = filter P lst" by auto
    from Cons(1)[OF Cons(2)] Cons(3)[unfolded this]
    obtain i2 j2 where "i2 < j2" "j2 < length lst"
      "lst ! i2 = filter P lst ! i" "lst ! j2 = filter P lst ! j" by blast
    hence "Suc i2 < Suc j2" "Suc j2 < length (a # lst)"
      "(a # lst) ! Suc i2 = filter P (a # lst) ! i"
      "(a # lst) ! Suc j2 = filter P (a # lst) ! j" by (auto simp:False)
    then show ?thesis by blast
  qed
qed auto

lemma ldistinct_lfilterI:
  assumes "\<And> i j. i < llength lst \<Longrightarrow> j < llength lst \<Longrightarrow> lst $ i = lst $ j \<Longrightarrow> P (lst $ i) \<Longrightarrow> i = j"
  shows "ldistinct (lfilter P lst)"
proof -
{ fix i j
  assume *: "enat i < llength (lfilter P lst)"
            "enat j < llength (lfilter P lst)"
            "lfilter P lst $ i = lfilter P lst $ j"
            "i < j"
  hence "lfilter P lst $ i \<in> lset (lfilter P lst)"
    unfolding in_lset_conv_lnth by auto
  with lset_lfilter
  have P:"P (lfilter P lst $ i)" by auto
  let ?maxij = "Suc (max i j)"
  from ltake_lfilter obtain maxij where
    maxij:"ltake ?maxij (lfilter P lst) = lfilter P (ltake (enat maxij) lst)"
    by blast
  let ?lst = "ltake (enat maxij) lst"
  have "lfinite ?lst" by auto
  define flst where "flst = list_of ?lst"
  hence flst:"llist_of flst = ?lst" by auto
  let ?flst = "llist_of flst"
  from * P
    have "enat i < llength (lfilter P ?flst)"
         "enat j < llength (lfilter P ?flst)"
         "lfilter P ?flst $ i = lfilter P ?flst $ j"
    and P2:"P (lfilter P ?lst $ i)"
    unfolding maxij[symmetric] flst by (auto simp add: lnth_ltake)
  hence "i < length (filter P flst)"
        "j < length (filter P flst)"
    and eq_ij: "filter P flst ! i = filter P flst ! j"
    unfolding llength_llist_of lfilter_llist_of lnth_llist_of by auto
  with filter_obtain_two[OF *(4) this(2)] obtain i2 j2
    where "i2 < length flst" "j2 < length flst"
          "flst ! i2 = filter P flst ! i"
          "flst ! j2 = filter P flst ! j"
          and ineq:"i2<j2"
    by auto
  hence "i2 < llength ?flst" "j2 < llength ?flst" "?flst $ i2 = ?flst $ j2" "?flst $ i2 = lfilter P ?flst $ i" "i2<j2"
    unfolding llength_llist_of lfilter_llist_of lnth_llist_of eq_ij by auto
  hence "enat i2 < llength lst" "enat j2 < llength lst" "lst $ i2 = lst $ j2" "P (lst $ i2)"
    using P2 unfolding flst by (auto simp add: lnth_ltake)
  from assms[OF this]
  have False using ineq by auto
}
thus ?thesis unfolding ldistinct_conv_lnth by (smt (z3) le_cases3 less_le)
qed

lemma ldistinct_lfilterE:
  assumes "ldistinct (lfilter P lst)" "e = lst $ i" "e = lst $ j"
          "i < llength lst" "j < llength lst" "P e"
  shows "i = j"
proof -
  let ?maxij = "Suc (max i j)"
  let ?lst = "ltake (enat ?maxij) lst"
  have jle:"j < length (list_of (ltake (enat (Suc (max i j))) lst))" using assms(4,5)
    apply(subst length_list_of_conv_the_enat,force)
    by(cases "llength lst", auto simp:min_enat2_conv_enat min_enat1_conv_enat)
  have ile:"i < length (list_of (ltake (enat (Suc (max i j))) lst))" using assms(4,5)
    apply(subst length_list_of_conv_the_enat,force)
    by(cases "llength lst", auto simp:min_enat2_conv_enat min_enat1_conv_enat)
  have "enat i < ?maxij" "enat j < ?maxij" by auto
  from this[THEN lnth_ltake,of lst] assms
  have "ldistinct (lfilter P ?lst)" "e = ?lst $ i" "e = ?lst $ j" by auto
  hence d:"distinct (filter P (list_of ?lst))"
       "(list_of ?lst) ! j = e" "(list_of ?lst) ! i = e"
    using lfilter_llist_of[of P "list_of ?lst"] by auto
  show ?thesis by(rule distinct_filterD[OF d(1) jle ile assms(6) d(2,3)])
qed

lemma ldistinct_lfilter_conv:
  "ldistinct (lfilter P lst) = (\<forall> i j. i < llength lst \<longrightarrow> j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j)"
proof
  show "ldistinct (lfilter P lst) \<Longrightarrow> \<forall>i j. enat i < llength lst \<longrightarrow> enat j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j"
    by (auto simp add: ldistinct_lfilterE)
  show "\<forall>i j. enat i < llength lst \<longrightarrow> enat j < llength lst \<longrightarrow> P (lst $ i) \<longrightarrow> lst $ i = lst $ j \<longrightarrow> i = j \<Longrightarrow> ldistinct (lfilter P lst) "
    using ldistinct_lfilterI by blast
qed

end