chapter \<open>Homework 3\<close>
theory Homework3_1sol
imports Main
begin

  (*
    This file is intended to be viewed within the Isabelle/jEdit IDE.
    In a standard text-editor, it is pretty unreadable!
  *)

  (*
    HOMEWORK #3 PART I/II
    RELEASED: Tue, Aug 26 2017
    DUE:      Wed, Feb 4, 2017, 11:59pm

    To be submitted via canvas.
  *)

section \<open>General Hints\<close>
(*
  The best way to work on this homework is to fill in the missing gaps in this file.

  Try to go for simple function definitions, as simple definitions mean simple proofs!
  In particular, do not go for a more complicated definition only b/c it may be more efficient!

*)

section \<open>Arithmetic Expressions with Side-Effects\<close>

text \<open>Model arithmetic expressions that contain
  constants, variables, addition, and the prefix \<open>++\<close>-operator known from
  C++ and Java. The expression \<open>++x\<close> where \<open>x\<close> must be a variable,
  increments \<open>x\<close> and evaluates to the incremented value of \<open>x\<close>.
\<close>
type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

datatype aexp = N val | V vname | Inc vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<times> state" where
  "aval (N v) s = (v,s)"
| "aval (V x) s = (s x, s)"
| "aval (Inc x) s = (s x + 1, s( x:= s x + 1))"
| "aval (Plus a1 a2) s = (let (v1,s) = aval a1 s; (v2,s) = aval a2 s in (v1+v2,s)) "

(* Like in the tutorial, it was important to change both the state, and return the incremented value.

  The most frequent mistake here was to not change the state, making Inc x just an alias for
  Plus (V x) (N 1). Then, of course, the compiler was straightforward, and the STORE instruction
  was actually not needed. I still gave 3 points for such solutions.
*)

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval (Plus a1 a2) s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Inc x) = Inc x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a arbitrary: s) (** The only difference to the original proof
  is that you need to generalize over the state s, as this is changed during execution. *)
apply simp_all
done

section \<open>Compiling with Side-Effect\<close>

datatype instr = LOADI val | LOAD vname | STORE vname | ADD
type_synonym stack = "val list"

fun exec1  :: "instr \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
  "exec1 (LOADI n) (s, stk)  =  (s, n # stk)"
| "exec1 (LOAD x) (s, stk)  =  (s, s(x) # stk)"
| "exec1 (STORE x) (s, a#stk) = (s(x:=a), stk)"
| "exec1 (STORE _) _ = undefined"
| "exec1 ADD (s, a#b#stk) = (s,(a+b)#stk)"
| "exec1 ADD _ = undefined"

fun exec :: "instr list \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
"exec [] sxstk = sxstk" |
"exec (i#is) sxstk = exec is (exec1 i sxstk)"

lemma exec_append[simp]:
  "exec (is1@is2) sxstk = exec is2 (exec is1 sxstk)"
apply(induction is1 arbitrary: sxstk)
apply (auto)
done

hide_const (open) comp

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Inc x) = [LOAD x, LOADI 1, ADD, STORE x, LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

(** The code for Inc will add one, store the result in variable x, and immediately load it from x.
  This changes both the state and places the incremented result on top of the stack.
*)

theorem exec_comp:
  "aval a s = (v,s') \<Longrightarrow> exec (comp a) (s,stk) = (s',v#stk)"
  apply (induction a arbitrary: v s s' stk)
  apply (auto split: prod.splits)
  done

(** You have to generalize over all variables that will change during execution.
  The split: prod.splits takes care of the remaining
  "case aval a1 s of (v1, s) \<Rightarrow> \<dots>" (and, similar for a2, v2)
 *)

end


theory P03
imports Main
begin

thm notE
lemma "n = 0 \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> n = 3" by (rule notE)
using [[simp_trace_new mode=full]]
proof -
assume a: "n = 0"
assume b: "n \<noteq> 0"
from a b have False by (simp )
from a and b have "0 \<noteq> 0" by simp

thm simp_thms
fun p03_2 :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option " where
"p03_2 [] _ = None"|
"p03_2 (x#xs) n = (if n = 1 then Some x else  p03_2 xs (n -1))"

value  "p03_2 [1,2,3,4] 3 :: int option"

lemma "p03_2 [] n = None"
proof -
  show ?thesis by (subst p03_2.simps(1); rule refl)
qed
thm subst
lemma "p03_2 [x] 1  = Some x" by simp

thm
lemma " length ls  \<ge> n  \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p03_2 ls n = Some a"
using [[simp_trace_new mode=full]]
proof (induct ls)
 case Nil
  assume a:"\<not>(n = 0)"
  assume "n \<le> length []"
  with list.size(3) have "n \<le> 0" by (rule subst)
  with le_0_eq have "n = 0"  by (rule subst)
  with a show "p03_2 [] n = Some a"  by (rule notE)
 next
show "\<And>aa ls. (n \<le> length ls \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p03_2 ls n = Some a) \<Longrightarrow> n \<le> length (aa # ls) \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p03_2 (aa # ls) n = Some a" by auto
  fix aa ls
  assume "n \<le> length ls \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> p03_2 ls n = Some a"
  assume " n \<le> length (aa # ls)"
  assume "n \<noteq> 0"


theory Ex18
imports Main
begin

(*associativity of or*)
lemma "(A \<or> B) \<or> C \<longleftrightarrow> A \<or> (B \<or> C)"
proof -
{
  assume "(A \<or> B) \<or> C"
  {
    assume "A \<or> B"
    {
      assume A
      hence "A \<or> (B \<or> C)" by (rule disjI1)
    }
    moreover
    {
      assume B
      hence "B \<or> C" by (rule disjI1)
      hence "A \<or> (B \<or> C)" by (rule disjI2)
    }
    from \<open>A \<or> B\<close> and calculation and this  have "A \<or> (B \<or> C)" by (rule disjE)
  }
  moreover
  {
    assume C
    hence "B \<or> C" by (rule disjI2)
    hence "A \<or> (B \<or> C)" by (rule disjI2)
  }
  from \<open>(A \<or> B) \<or> C\<close> and calculation and this  have "A \<or> (B \<or> C)" by (rule disjE)
}
moreover
{
  assume "A \<or> (B \<or> C)"
  {
    assume A
    hence "A \<or> B" by (rule disjI1)
    hence "(A \<or> B) \<or> C" by (rule disjI1)
  }
  moreover
  {
    assume "B \<or> C"
    {
      assume B
      hence "A \<or> B" by (rule disjI2)
      hence "(A \<or> B) \<or> C" by (rule disjI1)
    }
    moreover
    {
      assume C
      hence "(A \<or> B) \<or> C" by (rule disjI2)
    }
    from \<open>B \<or> C\<close> and calculation and this have "(A \<or> B) \<or> C" by (rule disjE)
  }
  from \<open>A \<or> (B \<or> C)\<close> and calculation and this have "(A \<or> B) \<or> C" by (rule disjE)
}
ultimately show ?thesis by (rule iffI)
qed


theory chapter4
imports Main
begin

type_synonym vname = string
(* expression arithemetique*)
(*    5 + 7      *)
(*    Plus (N 5) (N 7)     *)
datatype aexp =
  N int
  |V vname
  |Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n"
| "aval (V x) s = s x"
| "aval (Plus a1 a2) s = aval a1 s + aval a2 s"

(* boolean expressions *)
datatype bexp =
  Bc bool
  |Not bexp
  |And bexp bexp
  |Less aexp aexp

datatype com =
  SKIP
  |Assign vname aexp
  |Seq com com
  |If bexp com com
  |While bexp com

(*theorem "P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q"
  apply (rule conjI)
   apply (assumption)
  apply (assumption)
  done*)
theorem "\<forall>x. \<exists>y. x = y"
  apply (rule allI)
  apply (rule exI)
  apply (rule refl)
  done

theorem "\<forall>x. \<exists>y. x = y"
  apply (rule allI)
方法      apply (rule refl)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_13
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop (S n) (cons2 x xs)) = (drop n xs))"
  find_proof DInd
  apply (induct)
   apply auto
  done

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_38
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun z :: "'a list => 'a list => 'a list" where
  "z (nil2) y2 = y2"
| "z (cons2 z2 xs) y2 = cons2 z2 (z xs y2)"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x22) (Z) = False"
| "y (S x22) (S y22) = y x22 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem x2 (nil2) = False"
| "elem x2 (cons2 z2 xs) = x (y x2 z2) (elem x2 xs)"

theorem property0 :
  "((elem x2 y2) ==> ((elem x2 z2) ==> (elem x2 (z y2 z2))))"
  oops

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>The Mignotte Bound\<close>
theory Factor_Bound
imports
  Mahler_Measure
  Polynomial_Factorization.Gauss_Lemma
  Subresultants.Coeff_Int
begin

lemma binomial_mono_left: "n \<le> N \<Longrightarrow> n choose k \<le> N choose k"
proof (induct n arbitrary: k N)
  case (0 k N)
  thus ?case by (cases k, auto)
next
  case (Suc n k N) note IH = this
  show ?case
  proof (cases k)
    case (Suc kk)
    from IH obtain NN where N: "N = Suc NN" and le: "n \<le> NN" by (cases N, auto)
    show ?thesis unfolding N Suc using IH(1)[OF le]
      by (simp add: add_le_mono)
  qed auto
qed

definition choose_int where "choose_int m n = (if n < 0 then 0 else m choose (nat n))"

lemma choose_int_suc[simp]:
  "choose_int (Suc n) i = choose_int n (i-1) + choose_int n i"
proof(cases "nat i")
  case 0 thus ?thesis by (simp add:choose_int_def) next
  case (Suc v) hence "nat (i - 1) = v" "i\<noteq>0" by simp_all
    thus ?thesis unfolding choose_int_def Suc by simp
qed

lemma sum_le_1_prod: assumes d: "1 \<le> d" and c: "1 \<le> c"
  shows "c + d \<le> 1 + c * (d :: real)"
proof -
  from d c have "(c - 1) * (d - 1) \<ge> 0" by auto
  thus ?thesis by (auto simp: field_simps)
qed

lemma mignotte_helper_coeff_int: "cmod (coeff_int (\<Prod>a\<leftarrow>lst. [:- a, 1:]) i)
    \<le> choose_int (length lst - 1) i * (\<Prod>a\<leftarrow>lst. (max 1 (cmod a)))
    + choose_int (length lst - 1) (i - 1)"
proof(induct lst arbitrary:i)
  case Nil thus ?case by (auto simp:coeff_int_def choose_int_def)
  case (Cons v xs i)
  show ?case
  proof (cases "xs = []")
    case True
    show ?thesis unfolding True
      by (cases "nat i", cases "nat (i - 1)", auto simp: coeff_int_def choose_int_def)
  next
    case False
    hence id: "length (v # xs) - 1 = Suc (length xs - 1)" by auto
    have id': "choose_int (length xs) i = choose_int (Suc (length xs - 1)) i" for i
      using False by (cases xs, auto)
    let ?r = "(\<Prod>a\<leftarrow>xs. [:- a, 1:])"
    let ?mv = "(\<Prod>a\<leftarrow>xs. (max 1 (cmod a)))"
    let ?c1 = "real (choose_int (length xs - 1) (i - 1 - 1))"
    let ?c2 = "real (choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i)"
    let "?m xs n" = "choose_int (length xs - 1) n * (\<Prod>a\<leftarrow>xs. (max 1 (cmod a)))"
    have le1:"1 \<le> max 1 (cmod v)" by auto
    have le2:"cmod v \<le> max 1 (cmod v)" by auto
    have mv_ge_1:"1 \<le> ?mv" by (rule prod_list_ge1, auto)
    obtain a b c d where abcd :
      "a = real (choose_int (length xs - 1) i)"
      "b = real (choose_int (length xs - 1) (i - 1))"
      "c = (\<Prod>a\<leftarrow>xs. max 1 (cmod a))"
      "d = cmod v" by auto
    {
      have c1: "c \<ge> 1" unfolding abcd by (rule mv_ge_1)
      have b: "b = 0 \<or> b \<ge> 1" unfolding abcd by auto
      have a: "a = 0 \<or> a \<ge> 1" unfolding abcd by auto
      hence a0: "a \<ge> 0" by auto
      have acd: "a * (c * d) \<le> a * (c * max 1 d)" using a0 c1
        by (simp add: mult_left_mono)
      from b have "b * (c + d) \<le> b * (1  + (c * max 1 d))"
      proof
        assume "b \<ge> 1"
        hence "?thesis = (c + d \<le> 1 + c * max 1 d)" by simp
        also have \<dots>
        proof (cases "d \<ge> 1")
          case False
          hence id: "max 1 d = 1" by simp
          show ?thesis using False unfolding id by simp
        next
          case True
          hence id: "max 1 d = d" by simp
          show ?thesis using True c1 unfolding id by (rule sum_le_1_prod)
        qed
        finally show ?thesis .
      qed auto
      with acd have "b * c + (b * d + a * (c * d)) \<le> b + (a * (c * max 1 d) + b * (c * max 1 d))"
        by (auto simp: field_simps)
    } note abcd_main = this
    have "cmod (coeff_int ([:- v, 1:] * ?r) i) \<le> cmod (coeff_int ?r (i - 1)) + cmod (coeff_int (smult v ?r) i)"
      using norm_triangle_ineq4 by auto
    also have "\<dots> \<le> ?m xs (i - 1) + (choose_int (length xs - 1) (i - 1 - 1)) + cmod (coeff_int (smult v ?r) i)"
      using Cons[of "i-1"] by auto
    also have "choose_int (length xs - 1) (i - 1) = choose_int (length (v # xs) - 1) i - choose_int (length xs - 1) i"
      unfolding id choose_int_suc by auto
    also have "?c2 * (\<Prod>a\<leftarrow>xs. max 1 (cmod a)) + ?c1 +
       cmod (coeff_int (smult v (\<Prod>a\<leftarrow>xs. [:- a, 1:])) i) \<le>
       ?c2 * (\<Prod>a\<leftarrow>xs. max 1 (cmod a)) + ?c1 + cmod v * (
         real (choose_int (length xs - 1) i) * (\<Prod>a\<leftarrow>xs. max 1 (cmod a)) +
         real (choose_int (length xs - 1) (i - 1)))"
      using mult_mono'[OF order_refl Cons, of "cmod v" i, simplified] by (auto simp: norm_mult)
    also have "\<dots> \<le> ?m (v # xs) i + (choose_int (length xs) (i - 1))" using abcd_main[unfolded abcd]
      by (simp add: field_simps id')
    finally show ?thesis by simp
  qed
qed

lemma mignotte_helper_coeff_int': "cmod (coeff_int (\<Prod>a\<leftarrow>lst. [:- a, 1:]) i)
    \<le> ((length lst - 1) choose i) * (\<Prod>a\<leftarrow>lst. (max 1 (cmod a)))
    + min i 1 * ((length lst - 1) choose (nat (i - 1)))"
  by (rule order.trans[OF mignotte_helper_coeff_int], auto simp: choose_int_def min_def)

lemma mignotte_helper_coeff:
  "cmod (coeff h i) \<le> (degree h - 1 choose i) * mahler_measure_poly h
      + min i 1 * (degree h - 1 choose (i - 1)) * cmod (lead_coeff h)"
proof -
  let ?r = "complex_roots_complex h"
  have "cmod (coeff h i) = cmod (coeff (smult (lead_coeff h) (\<Prod>a\<leftarrow>?r. [:- a, 1:])) i)"
    unfolding complex_roots by auto
  also have "\<dots> = cmod (lead_coeff h) * cmod (coeff (\<Prod>a\<leftarrow>?r. [:- a, 1:]) i)" by(simp add:norm_mult)
  also have "\<dots> \<le> cmod (lead_coeff h) * ((degree h - 1 choose i) * mahler_measure_monic h +
    (min i 1 * ((degree h - 1) choose nat (int i - 1))))"
    unfolding mahler_measure_monic_def
    by (rule mult_left_mono, insert mignotte_helper_coeff_int'[of ?r i], auto)
  also have "\<dots> = (degree h - 1 choose i) * mahler_measure_poly h + cmod (lead_coeff h) * (
    min i 1 * ((degree h - 1) choose nat (int i - 1)))"
    unfolding mahler_measure_poly_via_monic by (simp add: field_simps)
  also have "nat (int i - 1) = i - 1" by (cases i, auto)
  finally show ?thesis by (simp add: ac_simps split: if_splits)
qed

lemma mignotte_coeff_helper:
  "abs (coeff h i) \<le>
   (degree h - 1 choose i) * mahler_measure h +
   (min i 1 * (degree h - 1 choose (i - 1)) * abs (lead_coeff h))"
  unfolding mahler_measure_def
  using mignotte_helper_coeff[of "of_int_poly h" i]
  by auto

lemma cmod_through_lead_coeff[simp]:
  "cmod (lead_coeff (of_int_poly h)) = abs (lead_coeff h)"
  by simp

lemma choose_approx: "n \<le> N \<Longrightarrow> n choose k \<le> N choose (N div 2)"
  by (rule order.trans[OF binomial_mono_left binomial_maximum])

text \<open>For Mignotte's factor bound, we currently do not support queries for individual coefficients,
  as we do not have a combined factor bound algorithm.\<close>

definition mignotte_bound :: "int poly \<Rightarrow> nat \<Rightarrow> int" where
  "mignotte_bound f d = (let d' = d - 1; d2 = d' div 2; binom = (d' choose d2) in
     (mahler_approximation 2 binom f + binom * abs (lead_coeff f)))"

lemma mignotte_bound_main:
  assumes "f \<noteq> 0" "g dvd f" "degree g \<le> n"
  shows "\<bar>coeff g k\<bar> \<le> \<lfloor>real (n - 1 choose k) * mahler_measure f\<rfloor> +
       int (min k 1 * (n - 1 choose (k - 1))) * \<bar>lead_coeff f\<bar>"
proof-
  let ?bnd = 2
  let ?n = "(n - 1) choose k"
  let ?n' = "min k 1 * ((n - 1) choose (k - 1))"
  let ?approx = "mahler_approximation ?bnd ?n f"
  obtain h where gh:"g * h = f" using assms by (metis dvdE)
  have nz:"g\<noteq>0" "h\<noteq>0" using gh assms(1) by auto
  have g1:"(1::real) \<le> mahler_measure h" using mahler_measure_poly_ge_1 gh assms(1) by auto
  note g0 = mahler_measure_ge_0
  have to_n: "(degree g - 1 choose k) \<le> real ?n"
    using binomial_mono_left[of "degree g - 1" "n - 1" k] assms(3) by auto
  have to_n': "min k 1 * (degree g - 1 choose (k - 1)) \<le> real ?n'"
    using binomial_mono_left[of "degree g - 1" "n - 1" "k - 1"] assms(3)
    by (simp add: min_def)
  have "\<bar>coeff g k\<bar> \<le> (degree g - 1 choose k) * mahler_measure g
    + (real (min k 1 * (degree g - 1 choose (k - 1))) * \<bar>lead_coeff g\<bar>)"
    using mignotte_coeff_helper[of g k] by simp
  also have "\<dots> \<le> ?n * mahler_measure f + real ?n' * \<bar>lead_coeff f\<bar>"
  proof (rule add_mono[OF mult_mono[OF to_n] mult_mono[OF to_n']])
    have "mahler_measure g  \<le> mahler_measure g * mahler_measure h" using g1 g0[of g]
      using mahler_measure_poly_ge_1 nz(1) by force
    thus "mahler_measure g \<le> mahler_measure f"
      using measure_eq_prod[of "of_int_poly g" "of_int_poly h"]
      unfolding mahler_measure_def gh[symmetric] by (auto simp: hom_distribs)
    have *: "lead_coeff f = lead_coeff g * lead_coeff h"
      unfolding arg_cong[OF gh, of lead_coeff, symmetric] by (rule lead_coeff_mult)
    have "\<bar>lead_coeff h\<bar> \<noteq> 0" using nz(2) by auto
    hence lh: "\<bar>lead_coeff h\<bar> \<ge> 1" by linarith
    have "\<bar>lead_coeff f\<bar> = \<bar>lead_coeff g\<bar> * \<bar>lead_coeff h\<bar>" unfolding * by (rule abs_mult)
    also have "\<dots> \<ge> \<bar>lead_coeff g\<bar> * 1"
      by (rule mult_mono, insert lh, auto)
    finally have "\<bar>lead_coeff g\<bar> \<le> \<bar>lead_coeff f\<bar>" by simp
    thus "real_of_int \<bar>lead_coeff g\<bar> \<le> real_of_int \<bar>lead_coeff f\<bar>" by simp
  qed (auto simp: g0)
  finally have "\<bar>coeff g k\<bar> \<le> ?n * mahler_measure f + real_of_int (?n' * \<bar>lead_coeff f\<bar>)" by simp
  from floor_mono[OF this, folded floor_add_int]
  have "\<bar>coeff g k\<bar> \<le> floor (?n * mahler_measure f) + ?n' * \<bar>lead_coeff f\<bar>" by linarith
  thus ?thesis unfolding mignotte_bound_def Let_def using mahler_approximation[of ?n f ?bnd] by auto
qed

lemma Mignotte_bound:
  shows "of_int \<bar>coeff g k\<bar> \<le> (degree g choose k) * mahler_measure g"
proof (cases "k \<le> degree g \<and> g \<noteq> 0")
  case False
  hence "coeff g k = 0" using le_degree by (cases "g = 0", auto)
  thus ?thesis using mahler_measure_ge_0[of g] by auto
next
  case kg: True
  hence g: "g \<noteq> 0" "g dvd g" by auto
  from mignotte_bound_main[OF g le_refl, of k]
  have "real_of_int \<bar>coeff g k\<bar>
    \<le> of_int \<lfloor>real (degree g - 1 choose k) * mahler_measure g\<rfloor> +
      of_int (int (min k 1 * (degree g - 1 choose (k - 1))) * \<bar>lead_coeff g\<bar>)" by linarith
  also have "\<dots> \<le> real (degree g - 1 choose k) * mahler_measure g
     + real (min k 1 * (degree g - 1 choose (k - 1))) * (of_int \<bar>lead_coeff g\<bar> * 1)"
    by (rule add_mono, force, auto)
  also have "\<dots> \<le> real (degree g - 1 choose k) * mahler_measure g
     + real (min k 1 * (degree g - 1 choose (k - 1))) * mahler_measure g"
    by (rule add_left_mono[OF mult_left_mono],
    unfold mahler_measure_def mahler_measure_poly_def,
    rule mult_mono, auto intro!: prod_list_ge1)
  also have "\<dots> =
    (real ((degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))))) * mahler_measure g"
    by (auto simp: field_simps)
  also have "(degree g - 1 choose k) + (min k 1 * (degree g - 1 choose (k - 1))) = degree g choose k"
  proof (cases "k = 0")
    case False
    then obtain kk where k: "k = Suc kk" by (cases k, auto)
    with kg obtain gg where g: "degree g = Suc gg" by (cases "degree g", auto)
    show ?thesis unfolding k g by auto
  qed auto
  finally show ?thesis .
qed

lemma mignotte_bound:
  assumes "f \<noteq> 0" "g dvd f" "degree g \<le> n"
  shows "\<bar>coeff g k\<bar> \<le> mignotte_bound f n"
proof -
  let ?bnd = 2
  let ?n = "(n - 1) choose ((n - 1) div 2)"
  have to_n: "(n - 1 choose k) \<le> real ?n" for k
    using choose_approx[OF le_refl] by auto
  from mignotte_bound_main[OF assms, of k]
  have "\<bar>coeff g k\<bar> \<le>
    \<lfloor>real (n - 1 choose k) * mahler_measure f\<rfloor> +
    int (min k 1 * (n - 1 choose (k - 1))) * \<bar>lead_coeff f\<bar>" .
  also have "\<dots> \<le> \<lfloor>real (n - 1 choose k) * mahler_measure f\<rfloor> +
    int ((n - 1 choose (k - 1))) * \<bar>lead_coeff f\<bar>"
    by (rule add_left_mono[OF mult_right_mono], cases k, auto)
  also have "\<dots> \<le> mignotte_bound f n"
    unfolding mignotte_bound_def Let_def
    by (rule add_mono[OF order.trans[OF floor_mono[OF mult_right_mono]
    mahler_approximation[of ?n f ?bnd]] mult_right_mono], insert to_n mahler_measure_ge_0, auto)
  finally show ?thesis .
qed

text \<open>As indicated before, at the moment the only available factor bound is Mignotte's one.
  As future work one might use a combined bound.\<close>

definition factor_bound :: "int poly \<Rightarrow> nat \<Rightarrow> int" where
  "factor_bound = mignotte_bound"

lemma factor_bound: assumes "f \<noteq> 0" "g dvd f" "degree g \<le> n"
  shows "\<bar>coeff g k\<bar> \<le> factor_bound f n"
  unfolding factor_bound_def by (rule mignotte_bound[OF assms])

text \<open>We further prove a result for factor bounds and scalar multiplication.\<close>

lemma factor_bound_ge_0: "f \<noteq> 0 \<Longrightarrow> factor_bound f n \<ge> 0"
  using factor_bound[of f 1 n 0] by auto

lemma factor_bound_smult: assumes f: "f \<noteq> 0" and d: "d \<noteq> 0"
  and dvd: "g dvd smult d f" and deg: "degree g \<le> n"
  shows "\<bar>coeff g k\<bar> \<le> \<bar>d\<bar> * factor_bound f n"
proof -
  let ?nf = "primitive_part f" let ?cf = "content f"
  let ?ng = "primitive_part g" let ?cg = "content g"
  from content_dvd_contentI[OF dvd] have "?cg dvd abs d * ?cf"
    unfolding content_smult_int .
  hence dvd_c: "?cg dvd d * ?cf" using d
    by (metis abs_content_int abs_mult dvd_abs_iff)
  from primitive_part_dvd_primitive_partI[OF dvd] have "?ng dvd smult (sgn d) ?nf" unfolding primitive_part_smult_int .
  hence dvd_n: "?ng dvd ?nf" using d
    by (metis content_eq_zero_iff dvd dvd_smult_int f mult_eq_0_iff content_times_primitive_part smult_smult)
  define gc where "gc = gcd ?cf ?cg"
  define cg where "cg = ?cg div gc"
  from dvd d f have g: "g \<noteq> 0" by auto
  from f have cf: "?cf \<noteq> 0" by auto
  from g have cg: "?cg \<noteq> 0" by auto
  hence gc: "gc \<noteq> 0" unfolding gc_def by auto
  have cg_dvd: "cg dvd ?cg" unfolding cg_def gc_def using g by (simp add: div_dvd_iff_mult)
  have cg_id: "?cg = cg * gc" unfolding gc_def cg_def using g cf by simp
  from dvd_smult_int[OF d dvd] have ngf: "?ng dvd f" .
  have gcf: "\<bar>gc\<bar> dvd content f" unfolding gc_def by auto
  have dvd_f: "smult gc ?ng dvd f"
  proof (rule dvd_content_dvd,
      unfold content_smult_int content_primitive_part[OF g]
      primitive_part_smult_int primitive_part_idemp)
    show "\<bar>gc\<bar> * 1 dvd content f" using gcf by auto
    show "smult (sgn gc) (primitive_part g) dvd primitive_part f"
      using dvd_n cf gc using zsgn_def by force
  qed
  have "cg dvd d" using dvd_c unfolding gc_def cg_def using cf cg d
    by (simp add: div_dvd_iff_mult dvd_gcd_mult)
  then obtain h where dcg: "d = cg * h" unfolding dvd_def by auto
  with d have "h \<noteq> 0" by auto
  hence h1: "\<bar>h\<bar> \<ge> 1" by simp
  have "degree (smult gc (primitive_part g)) = degree g"
    using gc by auto
  from factor_bound[OF f dvd_f, unfolded this, OF deg, of k, unfolded coeff_smult]
  have le: "\<bar>gc * coeff ?ng k\<bar> \<le> factor_bound f n" .
  note f0 = factor_bound_ge_0[OF f, of n]
  from mult_left_mono[OF le, of "abs cg"]
  have "\<bar>cg * gc * coeff ?ng k\<bar> \<le> \<bar>cg\<bar> * factor_bound f n"
    unfolding abs_mult[symmetric] by simp
  also have "cg * gc * coeff ?ng k = coeff (smult ?cg ?ng) k" unfolding cg_id by simp
  also have "\<dots> = coeff g k" unfolding content_times_primitive_part by simp
  finally have "\<bar>coeff g k\<bar> \<le> 1 * (\<bar>cg\<bar> * factor_bound f n)" by simp
  also have "\<dots> \<le> \<bar>h\<bar> * (\<bar>cg\<bar> * factor_bound f n)"
    by (rule mult_right_mono[OF h1], insert f0, auto)
  also have "\<dots> = (\<bar>cg * h\<bar>) * factor_bound f n" by (simp add: abs_mult)
  finally show ?thesis unfolding dcg .
qed

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Kruskal's Tree Theorem *}

theory Kruskal
imports Well_Quasi_Orders
begin

locale kruskal_tree =
  fixes F :: "('b \<times> nat) set"
    and mk :: "'b \<Rightarrow> 'a list \<Rightarrow> ('a::size)"
    and root :: "'a \<Rightarrow> 'b \<times> nat"
    and args :: "'a \<Rightarrow> 'a list"
    and trees :: "'a set"
  assumes size_arg: "t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> size s < size t"
    and root_mk: "(f, length ts) \<in> F \<Longrightarrow> root (mk f ts) = (f, length ts)"
    and args_mk: "(f, length ts) \<in> F \<Longrightarrow> args (mk f ts) = ts"
    and mk_root_args: "t \<in> trees \<Longrightarrow> mk (fst (root t)) (args t) = t"
    and trees_root: "t \<in> trees \<Longrightarrow> root t \<in> F"
    and trees_arity: "t \<in> trees \<Longrightarrow> length (args t) = snd (root t)"
    and trees_args: "\<And>s. t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> s \<in> trees"
begin

lemma mk_inject [iff]:
  assumes "(f, length ss) \<in> F" and "(g, length ts) \<in> F"
  shows "mk f ss = mk g ts \<longleftrightarrow> f = g \<and> ss = ts"
proof -
  { assume "mk f ss = mk g ts"
    then have "root (mk f ss) = root (mk g ts)"
      and "args (mk f ss) = args (mk g ts)" by auto }
  show ?thesis
    using root_mk [OF assms(1)] and root_mk [OF assms(2)]
      and args_mk [OF assms(1)] and args_mk [OF assms(2)] by auto
qed

inductive emb for P
where
  arg: "\<lbrakk>(f, m) \<in> F; length ts = m; \<forall>t\<in>set ts. t \<in> trees;
    t \<in> set ts; emb P s t\<rbrakk> \<Longrightarrow> emb P s (mk f ts)" |
  list_emb: "\<lbrakk>(f, m) \<in> F; (g, n) \<in> F; length ss = m; length ts = n;
    \<forall>s \<in> set ss. s \<in> trees; \<forall>t \<in> set ts. t \<in> trees;
    P (f, m) (g, n); list_emb (emb P) ss ts\<rbrakk> \<Longrightarrow> emb P (mk f ss) (mk g ts)"
  monos list_emb_mono

lemma almost_full_on_trees:
  assumes "almost_full_on P F"
  shows "almost_full_on (emb P) trees" (is "almost_full_on ?P ?A")
proof (rule ccontr)
  interpret mbs ?A .
  assume "\<not> ?thesis"
  from mbs' [OF this] obtain m
    where bad: "m \<in> BAD ?P"
    and min: "\<forall>g. (m, g) \<in> gseq \<longrightarrow> good ?P g" ..
  then have trees: "\<And>i. m i \<in> trees" by auto

  def r \<equiv> "\<lambda>i. root (m i)"
  def a \<equiv> "\<lambda>i. args (m i)"
  def S \<equiv> "\<Union>{set (a i) | i. True}"

  have m: "\<And>i. m i = mk (fst (r i)) (a i)"
   by (simp add: r_def a_def mk_root_args [OF trees])
  have lists: "\<forall>i. a i \<in> lists S" by (auto simp: a_def S_def)
  have arity: "\<And>i. length (a i) = snd (r i)"
    using trees_arity [OF trees] by (auto simp: r_def a_def)
  then have sig: "\<And>i. (fst (r i), length (a i)) \<in> F"
    using trees_root [OF trees] by (auto simp: a_def r_def)
  have a_trees: "\<And>i. \<forall>t \<in> set (a i). t \<in> trees" by (auto simp: a_def trees_args [OF trees])

  have "almost_full_on ?P S"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain s :: "nat \<Rightarrow> 'a"
      where S: "\<And>i. s i \<in> S" and bad_s: "bad ?P s" by (auto simp: almost_full_on_def)

    def n \<equiv> "LEAST n. \<exists>k. s k \<in> set (a n)"
    have "\<exists>n. \<exists>k. s k \<in> set (a n)" using S by (force simp: S_def)
    from LeastI_ex [OF this] obtain k
      where sk: "s k \<in> set (a n)" by (auto simp: n_def)
    have args: "\<And>k. \<exists>m \<ge> n. s k \<in> set (a m)"
      using S by (auto simp: S_def) (metis Least_le n_def)

    def m' \<equiv> "\<lambda>i. if i < n then m i else s (k + (i - n))"

    have m'_less: "\<And>i. i < n \<Longrightarrow> m' i = m i" by (simp add: m'_def)
    have m'_geq: "\<And>i. i \<ge> n \<Longrightarrow> m' i = s (k + (i - n))" by (simp add: m'_def)

    have "bad ?P m'"
    proof
      assume "good ?P m'"
      then obtain i j where "i < j" and emb: "?P (m' i) (m' j)" by auto
      { assume "j < n"
        with `i < j` and emb have "?P (m i) (m j)" by (auto simp: m'_less)
        with `i < j` and bad have False by blast }
      moreover
      { assume "n \<le> i"
        with `i < j` and emb have "?P (s (k + (i - n))) (s (k + (j - n)))"
          and "k + (i - n) < k + (j - n)" by (auto simp: m'_geq)
        with bad_s have False by auto }
      moreover
      { assume "i < n" and "n \<le> j"
        with `i < j` and emb have *: "?P (m i) (s (k + (j - n)))" by (auto simp: m'_less m'_geq)
        with args obtain l where "l \<ge> n" and **: "s (k + (j - n)) \<in> set (a l)" by blast
        from emb.arg [OF sig [of l] _ a_trees [of l] ** *]
          have "?P (m i) (m l)" by (simp add: m)
        moreover have "i < l" using `i < n` and `n \<le> l` by auto
        ultimately have False using bad by blast }
      ultimately show False using `i < j` by arith
    qed
    moreover have "(m, m') \<in> gseq"
    proof -
      have "m \<in> SEQ ?A" using trees by auto
      moreover have "m' \<in> SEQ ?A"
        using trees and S and trees_args [OF trees] by (auto simp: m'_def a_def S_def)
      moreover have "\<forall>i < n. m i = m' i" by (auto simp: m'_less)
      moreover have "size (m' n) < size (m n)"
        using sk and size_arg [OF trees, unfolded m]
        by (auto simp: m m'_geq root_mk [OF sig] args_mk [OF sig])
      ultimately show ?thesis by (auto simp: gseq_def)
    qed
    ultimately show False using min by blast
  qed
  from almost_full_on_lists [OF this, THEN almost_full_on_imp_homogeneous_subseq, OF lists]
    obtain \<phi> :: "nat \<Rightarrow> nat"
    where less: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
      and lemb: "\<And>i j. i < j \<Longrightarrow> list_emb ?P (a (\<phi> i)) (a (\<phi> j))" by blast
  have roots: "\<And>i. r (\<phi> i) \<in> F" using trees [THEN trees_root] by (auto simp: r_def)
  then have "r \<circ> \<phi> \<in> SEQ F" by auto
  with assms have "good P (r \<circ> \<phi>)" by (auto simp: almost_full_on_def)
  then obtain i j
    where "i < j" and "P (r (\<phi> i)) (r (\<phi> j))" by auto
  with lemb [OF `i < j`] have "?P (m (\<phi> i)) (m (\<phi> j))"
    using sig and arity and a_trees by (auto simp: m intro!: emb.list_emb)
  with less [OF `i < j`] and bad show False by blast
qed

inductive_cases
  emb_mk2 [consumes 1, case_names arg list_emb]: "emb P s (mk g ts)"

inductive_cases
  list_emb_Nil2_cases: "list_emb P xs []" and
  list_emb_Cons_cases: "list_emb P xs (y#ys)"

lemma list_emb_trans_right:
  assumes "list_emb P xs ys" and "list_emb (\<lambda>y z. P y z \<and> (\<forall>x. P x y \<longrightarrow> P x z)) ys zs"
  shows "list_emb P xs zs"
  using assms(2, 1) by (induct arbitrary: xs) (auto elim!: list_emb_Nil2_cases list_emb_Cons_cases)

lemma emb_trans:
  assumes trans: "\<And>f g h. f \<in> F \<Longrightarrow> g \<in> F \<Longrightarrow> h \<in> F \<Longrightarrow> P f g \<Longrightarrow> P g h \<Longrightarrow> P f h"
  assumes "emb P s t" and "emb P t u"
  shows "emb P s u"
using assms(3, 2)
proof (induct arbitrary: s)
  case (arg f m ts v)
  then show ?case by (auto intro: emb.arg)
next
  case (list_emb f m g n ss ts)
  note IH = this
  from `emb P s (mk f ss)`
    show ?case
  proof (cases rule: emb_mk2)
    case arg
    then show ?thesis using IH by (auto elim!: list_emb_set intro: emb.arg)
  next
    case list_emb
    then show ?thesis using IH by (auto intro: emb.intros dest: trans list_emb_trans_right)
  qed
qed

lemma transp_on_emb:
  assumes "transp_on P F"
  shows "transp_on (emb P) trees"
  using assms and emb_trans [of P] unfolding transp_on_def by blast

lemma kruskal:
  assumes "wqo_on P F"
  shows "wqo_on (emb P) trees"
  using almost_full_on_trees [of P] and assms by (metis transp_on_emb wqo_on_def)

end

end


(*  Title:       Enable Checking of Equivalence of Regular Expressions with Variables
    Author:      Max Haslbeck
    Reference:   http://www4.in.tum.de/lehre/vorlesungen/theo/SS10/vorlesung.shtml p.96ff
*)
section \<open>Equivalence of Regular Expression with Variables\<close>

theory RExp_Var
imports "Regular-Sets.Equivalence_Checking"
begin

(* even Atoms \<rightarrow> normal Atoms
    odd Atoms \<rightarrow> Variables *)
fun castdown :: "nat rexp \<Rightarrow> nat rexp" where
  "castdown Zero = Zero"
| "castdown One = One"
| "castdown (Plus a b) = Plus (castdown a) (castdown b)"
| "castdown (Times a b) = Times (castdown a) (castdown b)"
| "castdown (Star a) = Star (castdown a)"
| "castdown (Atom x) = (Atom (x div 2))"

fun castup :: "nat rexp \<Rightarrow> nat rexp" where
  "castup Zero = Zero"
| "castup One = One"
| "castup (Plus a b) = Plus (castup a) (castup b)"
| "castup (Times a b) = Times (castup a) (castup b)"
| "castup (Star a) = Star (castup a)"
| "castup (Atom x) = Atom (2*x)"

lemma "castdown (castup r) = r"
apply(induct r) by(auto)

fun substvar :: "nat \<Rightarrow> (nat \<Rightarrow> ((nat rexp) option)) \<Rightarrow> nat rexp" where
  "substvar i \<sigma> = (case \<sigma> i of Some x \<Rightarrow> x
                              | None \<Rightarrow> Atom (2*i+1))"

fun w2rexp :: "nat list \<Rightarrow> nat rexp" where
  "w2rexp [] = One"
| "w2rexp (a#as) = Times (Atom a) (w2rexp as)"

lemma "lang (w2rexp as) = { as }"
apply(induct as)
  apply(simp)
  by(simp add: conc_def)

fun subst :: "nat rexp \<Rightarrow> (nat \<Rightarrow> nat rexp option) \<Rightarrow> nat rexp" where
  "subst Zero _ = Zero"
| "subst One _ = One"
| "subst (Atom i) \<sigma> = (if i mod 2 = 0 then Atom i else substvar (i div 2) \<sigma>)"
| "subst (Plus a b) \<sigma> = Plus (subst a \<sigma>) (subst b \<sigma>)"
| "subst (Times a b) \<sigma> = Times (subst a \<sigma>) (subst b \<sigma>)"
| "subst (Star a) \<sigma> = Star (subst a \<sigma>)"

fun substW :: "nat list \<Rightarrow> (nat \<Rightarrow> nat rexp option) \<Rightarrow> nat rexp" where
  "substW as \<sigma> = subst (w2rexp as) \<sigma>"

fun substL :: "nat lang \<Rightarrow> (nat \<Rightarrow> nat rexp option) \<Rightarrow> nat rexp set" where
  "substL S \<sigma> = {substW a \<sigma>|a. a \<in> S}"

fun L :: "nat rexp set \<Rightarrow> nat lang" where
  "L S = (\<Union>r\<in>S. lang r)"

lemma L_mono: "S1 \<subseteq> S2 \<Longrightarrow> L S1 \<subseteq> L S2"
apply(simp) by blast

definition concS :: "'b rexp set \<Rightarrow> 'b rexp set \<Rightarrow> 'b rexp set" where
  "concS S1 S2 = {Times a b|a b. a\<in>S1 \<and> b\<in>S2}"

lemma substL_conc: "L (substL (L1 @@ L2) \<sigma>) = L (concS (substL L1 \<sigma>) (substL L2 \<sigma>))"
apply(simp add: concS_def conc_def)
apply(auto)
proof (goal_cases)
  case (1 x xs ys)
  show ?case
    apply(rule exI[where x="Times (subst (w2rexp xs) \<sigma>) (subst (w2rexp ys) \<sigma>)"])
    apply(simp)
    apply(safe)
     apply(rule exI[where x="xs"]) apply(simp add: 1(2))
     apply(rule exI[where x="ys"]) apply(simp add: 1(3))
     using 1(1) subst_w2rexp by auto
next
  case (2 x xs ys)
  show ?case
    apply(rule exI[where x="subst (w2rexp (xs @ ys)) \<sigma>"])
    apply(safe)
      apply(rule exI[where x="xs@ys"]) apply(simp)
        apply(rule exI[where x="xs"])
        apply(rule exI[where x="ys"]) using 2(2,3) apply(simp)
      using 2(1) subst_w2rexp by(auto)
qed

lemma L_conc: "L(concS M1 M2) = (L M1) @@ (L M2)"
proof -
  have "L(concS M1 M2) = (\<Union>x\<in>{Times a b |a b. a \<in> M1 \<and> b \<in> M2}. lang x)" unfolding concS_def by(simp)
  also have "\<dots> = (\<Union>{lang (Times a b) |a b. a \<in> M1 \<and> b \<in> M2} )" by blast
  also have "\<dots> = (\<Union>{lang a @@ lang b |a b. a \<in> M1 \<and> b \<in> M2} )" by simp
  also have "\<dots> = (\<Union>{{xs@ys | xs ys. xs \<in> lang a & ys \<in> lang b} |a b. a \<in> M1 \<and> b \<in> M2} )" unfolding conc_def by simp
  also have "\<dots> = {xs@ys | xs ys. xs\<in> (\<Union>r\<in>M1. lang r) \<and> ys \<in> (\<Union>r\<in>M2. lang r) }" by blast
  also have "\<dots> = {xs@ys | xs ys. xs\<in> L(M1) \<and> ys \<in> L(M2) }" by simp
  also have "\<dots> = (L M1) @@ (L M2)" unfolding conc_def by simp
  finally show ?thesis .
qed

lemma "L(M1 \<union> M2) = (L M1) \<union> (L M2)"
by simp

fun verund :: "'b rexp list \<Rightarrow> 'b rexp" where
  "verund [] = Zero"
| "verund [r] = r"
| "verund (r#rs) = Plus r (verund rs)"

lemma lang_verund: "r \<in> L (set rs) = (r \<in> lang (verund rs))"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

lemma obtainit:
  assumes "r \<in> lang (verund rs)"
  shows "\<exists>x\<in>(set (rs::nat rexp list)). r \<in> lang x"
proof -
  from assms have "r \<in> L (set rs)" by(simp only: lang_verund)
  then show ?thesis by(auto)
qed

lemma lang_verund4: "L (set rs) = lang (verund rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

lemma lang_verund1: "r \<in> L (set rs) \<Longrightarrow> r \<in> lang (verund rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto
lemma lang_verund2: "r \<in> lang (verund rs) \<Longrightarrow> r \<in> L (set rs)"
apply(induct rs)
  apply(simp)
  apply(case_tac rs) by auto

definition starS :: "'b rexp set \<Rightarrow> 'b rexp set" where
  "starS S = {Star (verund xs)|xs. set xs \<subseteq> S}"

lemma "[] \<in> L (starS S)"
unfolding starS_def apply(simp)
  apply(rule exI[where x="Star(verund [])"])
  apply(simp)
    apply(rule exI[where x="[]"])
    by (simp)

lemma power_mono: "L1 \<subseteq> L2 \<Longrightarrow> (L1::'a lang) ^^ n \<subseteq> L2 ^^ n"
apply(auto) apply(induct n) by(auto simp: conc_def)

lemma star_mono: "L1 \<subseteq> L2 \<Longrightarrow> star L1 \<subseteq> star L2"
  apply (simp add: star_def)
  apply (rule UN_mono)
  apply (auto simp: power_mono)
  done

lemma Lstar: "L(starS M) = star ( L(M) )"
unfolding starS_def apply(auto)
proof (goal_cases)
  case (1 x xs)
  from 1(2) have "L (set xs) \<subseteq> L (M)" by(rule L_mono)
  then have a: "star (L (set xs)) \<subseteq> star (L (M))" by (rule star_mono)
  from 1(1) obtain n where "x \<in> (lang (verund xs)) ^^ n" unfolding star_def by(auto)
  thm lang_verund4
  then have "x \<in> (L (set xs)) ^^ n" by(simp only: lang_verund4)
  then have "x \<in> star (L (set xs))" unfolding star_def by auto
  with a have "x \<in> star (L (M))" by auto
  then show "x \<in> star (\<Union>x\<in>M. lang x)" unfolding starS_def by auto
next
  case (2 x)
  then obtain n where "x \<in> (\<Union>x\<in>M. lang x) ^^ n" unfolding star_def by auto
  then show ?case
  proof (induct n arbitrary: x)
    case 0
    then have t: "x=[]" by(simp)
    show ?case
      apply(rule exI[where x="Star Zero"])
      apply(auto simp: t) apply(rule exI[where x="[]"]) by(simp)
  next
    case (Suc n)
    from Suc(2) have t: "x \<in> (\<Union>a\<in>M. lang a) @@ (\<Union>a\<in>M. lang a) ^^ n" by (simp)
    then obtain A B where x: "x = A @ B" and A: "A \<in> (\<Union>a\<in>M. lang a)" and B: "B \<in> (\<Union>a\<in>M. lang a) ^^ n" by(auto simp: conc_def)
    then obtain m where am: "A \<in> lang m" and mM: "m\<in>M" by(auto)
    from Suc(1)[OF B] obtain b bs where "b = Star (verund bs)" and bsM: "set bs \<subseteq> M" "B \<in> lang b" by auto
    then have Bin:  "B \<in> lang (Star (verund bs))" by simp
    let ?c = "Star (verund (m#bs))"

    have ac: "lang m \<subseteq> lang (Star (verund (m # bs)))"
      apply(cases bs) by(auto)
    have ad: "(lang (Star (verund bs))) \<subseteq> lang (Star (verund (m # bs)))"
      apply (simp add: star_def)
      apply (rule UN_mono)
      apply simp_all
      proof -
        fix n
        have t: "(lang (verund bs) ^^ n) \<subseteq> (lang m \<union> lang (verund bs)) ^^ n"
          by (rule power_mono) simp
        then show "lang (verund bs) ^^ n
          \<subseteq> lang (verund (m # bs)) ^^ n" by (cases bs) simp_all
      qed

    from Bin am mM x have "x \<in> lang m @@ (lang (Star (verund bs)))" by auto
    then have " x \<in> lang (Star (verund (m # bs))) @@ lang (Star (verund (m # bs)))" using ac ad by blast
    then have x_in: "x \<in> lang (Star (verund (m # bs)))" by (auto)

    show ?case
      apply(rule exI[where x="?c"])
      apply(safe)
        apply(rule exI[where x="m#bs"]) apply(simp add: bsM mM)
        by(fact x_in)
  qed
qed

lemma substL_star: "L (substL (star L1) \<sigma>) = L (starS (substL L1 \<sigma>))"
apply (simp add: concS_def conc_def starS_def star_def)
apply auto unfolding star_def
proof -
  fix x a n
  assume "x \<in> lang (subst (w2rexp a) \<sigma>)"
  moreover assume "a \<in> L1 ^^ n"
  ultimately show "\<exists>xa. (\<exists>xs. xa = Star (verund xs) \<and> set xs
    \<subseteq> {subst (w2rexp a) \<sigma> | a. a \<in> L1}) \<and> x \<in> lang xa"
  proof(induct n arbitrary: x a)
    case 0
    then have "a=[]" by auto
    with 0 show ?case apply(simp)
    apply(rule exI[where x="Star (Zero)"])
    apply(simp)
      apply(rule exI[where x="[]"])
      by(simp)
  next
    case (Suc n)
    then have a1: "a \<in> L1 @@ L1 ^^ n" by auto
    then obtain A B where a2: "a = A @ B" and A: "A \<in> L1" and B: "B \<in> L1 ^^ n" by auto

    thm subst_w2rexp
    from Suc(2) have "x \<in> lang (subst (w2rexp A) \<sigma>) @@ lang (subst (w2rexp B) \<sigma>)" unfolding a2
          by(simp only: subst_w2rexp)
    then obtain x1 x2 where x: "x = x1@x2" and x1: "x1 \<in> lang (subst (w2rexp A) \<sigma>)"
                    and  x2: "x2 \<in> lang (subst (w2rexp B) \<sigma>)" by auto
    from Suc(1)[OF x2 B] obtain R li where
          R: "R = Star (verund li)" and li: "set li \<subseteq> {subst (w2rexp a) \<sigma> |a. a \<in> L1}"
              and x2R: "x2 \<in> lang R" by auto

    show ?case
      apply(rule exI[where x="Star (verund ((subst (w2rexp A) \<sigma>)#li))"])
      apply(simp)
      apply(safe)
        apply(rule exI[where x="((subst (w2rexp A) \<sigma>)#li)"])
        apply(simp add: li)
          apply(rule exI[where x="A"]) apply(simp add: A)
        unfolding x
        proof (goal_cases)
          case 1
          let ?L = "(lang (subst (w2rexp A) \<sigma>) \<union> lang (verund li))"
          have t1: "x1 \<in> ?L" using x1 star_mono by blast
          have t2: "x2 \<in> star ?L" using x2R R star_mono apply(simp) by blast
          have "x1 @ x2 \<in> (?L @@ star ?L)" using t1 t2 by auto
          then show ?case
          apply(cases li) by(auto)
        qed
    qed
next
  fix x and xs :: "nat rexp list"
  assume "x \<in> (\<Union>n. lang (verund xs) ^^ n)"
  then obtain n where "x \<in> lang (verund xs) ^^ n" by auto
  moreover assume "set xs \<subseteq> {subst (w2rexp a) \<sigma> |a. a \<in> L1}"
  ultimately show "\<exists>xa. (\<exists>a. xa = subst (w2rexp a) \<sigma> \<and>
    (\<exists>n. a \<in> L1 ^^ n)) \<and> x \<in> lang xa"
  proof (induct n arbitrary: x)
    case 0
    then have xe: "x=[]" by auto
    show ?case
      apply(rule exI[where x="One"])
      apply(simp add: xe)
        apply(rule exI[where x="[]"])
        apply(simp)
          apply(rule exI[where x="0"])
          by(simp)
  next
    case (Suc n)
    then have "x \<in> lang (verund xs) @@ (lang (verund xs) ^^ n)" by auto
    then obtain x1 x2 where x: "x=x1@x2" and x1: "x1\<in>lang (verund xs)"
                      and x2: "x2 \<in> (lang (verund xs) ^^ n)" by auto
    from obtainit [OF x1] obtain el
      where "el \<in> set xs" and "x1 \<in> lang el" by auto
    with Suc.prems obtain elem
      where x1elem: "x1 \<in> lang (subst (w2rexp elem) \<sigma>)"
      and elemL1: "elem \<in> L1" by auto
    from Suc.hyps [OF x2 Suc.prems(2)] obtain R word n where
         R: "R = subst (w2rexp word) \<sigma>" and word: "word \<in> L1 ^^ n" and x2: "x2 \<in> lang R" by auto

    show ?case
      apply(rule exI[where x="subst (w2rexp (elem@word)) \<sigma>"])
      apply(safe)
        apply(rule exI[where x="elem@word"])
        apply(simp)
          apply(rule exI[where x="Suc n"])
          proof (goal_cases)
            case 1
            have "elem \<in> L1" by(fact elemL1)
            with word
            show "elem @ word \<in> L1 ^^ Suc n" by simp
          next
            case 2
            have "x1 \<in> lang (subst (w2rexp elem) \<sigma>)" by(fact x1elem)
            with x2[unfolded R] show ?case unfolding x apply(simp only: subst_w2rexp) by blast
          qed
  qed
qed

lemma substituitionslemma:
  fixes E :: "nat rexp"
  shows "L (substL ( lang(E) ) \<sigma>) = lang (subst E \<sigma>)"
proof (induct E)
  case (Star e)
  have "L (substL (lang (Star e)) \<sigma>) = L (substL (star (lang e)) \<sigma>)" by auto
  also have "\<dots> = L (starS (substL (lang e) \<sigma>))" by(simp only: substL_star)
  also have "\<dots> = star ( L (substL (lang e) \<sigma>))" by(simp only: Lstar)
  also have "\<dots> = star (lang (subst e \<sigma>))" by(simp only: Star)
  also have "\<dots> = lang ((subst (Star e) \<sigma>))" by auto
  finally show ?case .
next
  case (Plus e1 e2)
  have "L (substL (lang (Plus e1 e2)) \<sigma>) = L (substL (lang e1 \<union> lang e2) \<sigma>)" by simp
  also have "\<dots> =  L ( substL (lang e1) \<sigma> \<union> substL (lang e2) \<sigma>)" by auto
  also have "\<dots> = L (substL (lang e1) \<sigma>) \<union> L (substL (lang e2) \<sigma>)" by auto
  also have "\<dots> = lang (subst e1 \<sigma>) \<union> lang (subst e2 \<sigma>)" by(simp only: Plus)
  also have "\<dots> = lang (subst (Plus e1 e2) \<sigma>)" by auto
  finally show ?case .
next
  case (Times e1 e2)
  have "L (substL (lang (Times e1 e2)) \<sigma>) = L (substL (lang e1 @@ lang e2) \<sigma>)" by(simp)
  also have "\<dots> =  L (concS (substL (lang e1) \<sigma>) (substL (lang e2) \<sigma>))" by(simp only: substL_conc)
  thm L_conc
  also have "\<dots> = L (substL (lang e1) \<sigma>) @@ L (substL (lang e2) \<sigma>)" by(simp only: L_conc)
  also have "\<dots> = lang (subst e1 \<sigma>) @@ lang (subst e2 \<sigma>)" by(simp only: Times)
  also have "\<dots> = lang (Times (subst e1 \<sigma>) (subst e2 \<sigma>))" by auto
  also have "\<dots> = lang (subst (Times e1 e2) \<sigma>)" by auto
  finally show ?case .
qed simp_all

corollary lift: "lang e1 = lang e2 \<Longrightarrow> lang (subst e1 \<sigma>) = lang (subst e2 \<sigma>)"
proof -
  assume eq: "lang e1 = lang e2"
  thm substituitionslemma
  have "lang (subst e1 \<sigma>) = L (substL (lang e1) \<sigma>)" by(simp only: substituitionslemma)
  also have "\<dots> = L (substL (lang e2) \<sigma>)" using eq by simp
  also have "\<dots> = lang (subst e2 \<sigma>)" by(simp only: substituitionslemma)
  finally show ?thesis .
qed

subsection \<open>Examples\<close>

lemma "lang (Plus (Atom (x::nat)) (Atom x))  = lang (Atom x)"
proof -
  let ?\<sigma> = "(\<lambda>i. (if i=0 then Some (Atom x) else None))"
  let ?e1 = "Plus (Atom 1) (Atom 1)"
  let ?e2 = "Atom 1"
  have "lang (Plus (Atom x) (Atom x)) = lang (subst ?e1 ?\<sigma>)" by (simp)
  thm soundness
  also have "\<dots> = lang (subst ?e2 ?\<sigma>)"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have "\<dots> = lang (Atom x)" by auto
  finally show ?thesis .
qed

fun seq :: "'a rexp list \<Rightarrow> 'a rexp" where
"seq [] = One" |
"seq [r] = r" |
"seq (r#rs) = Times r (seq rs)"

abbreviation question where "question x == Plus x One"

definition "L_4cases (x::nat) y=
    verund [seq[question (Atom x),(Atom y), (Atom y)],
            seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)],
            seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)],
            seq[(Atom x),(Atom x)] ]"

definition "L_A x y = seq[question (Atom x),(Atom y), (Atom y)]"
definition "L_B x y = seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]"
definition "L_C x y = seq[question (Atom x),(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]"
definition "L_D x y = seq[(Atom x),(Atom x)]"

lemma "L_4cases x y = verund [L_A x y, L_B x y, L_C x y, L_D x y]"
unfolding L_A_def L_B_def L_C_def L_D_def L_4cases_def by auto

definition "L_lasthasxx x y = (Plus (seq[question (Atom x), Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)])
       (seq[question (Atom y), Star(Times(Atom x) (Atom y)),(Atom x),(Atom x)]))"

lemma lastxx_com: "lang (L_lasthasxx (x::nat) y) = lang (L_lasthasxx y x)" (is "lang ?A = lang ?B")
proof -
  let ?\<sigma> = "(\<lambda>i. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"

  let ?e1 = "Plus (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
       (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])"
  let ?e2 = "Plus (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])
           (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])"
  have "lang ?A = lang (subst ?e1 ?\<sigma>)" by(simp add: L_lasthasxx_def)
  thm soundness
  also have "\<dots> = lang (subst ?e2 ?\<sigma>)"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have "\<dots> = lang ?B" by (simp add: L_lasthasxx_def)
  finally show ?thesis .
qed

lemma lastxx_is_4cases: "lang (L_4cases x y) = lang (L_lasthasxx x y)" (is "lang ?A = lang ?B")
proof -
  let ?\<sigma> = "(\<lambda>i. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"

  let ?e1 = "(Plus (seq[Plus (Atom 1) One,(Atom 3), (Atom 3)])
            (Plus (seq[Plus (Atom 1) One,(Atom 3),(Atom 1),Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
            (Plus (seq[Plus (Atom 1) One,(Atom 3),(Atom 1),Star(Times (Atom 3) (Atom 1)),(Atom 1)])
                  (seq[(Atom 1),(Atom 1)]))))"
  let ?e2 = "Plus (seq[Plus (Atom 1) One, Star(Times (Atom 3) (Atom 1)),(Atom 3),(Atom 3)])
       (seq[Plus (Atom 3) One, Star(Times (Atom 1) (Atom 3)),(Atom 1),(Atom 1)])"
  have "lang ?A = lang (subst ?e1 ?\<sigma>)" by (simp add: L_4cases_def)
  thm soundness
  also have "\<dots> = lang (subst ?e2 ?\<sigma>)"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have "\<dots> = lang ?B" by (simp add: L_lasthasxx_def)
  finally show ?thesis .
qed

definition "myUNIV x y = Star (Plus (Atom x) (Atom y))"

lemma myUNIV_alle: "lang (myUNIV x y) = {xs. set xs \<subseteq> {x,y}}"
proof -
  have "star {[y], [x]}  = {concat ws |ws. set ws \<subseteq> {[y], [x]}}" by(simp only: star_conv_concat)
  also have "\<dots> = {xs. set xs \<subseteq> {x, y}}" apply(auto) apply(cases "x=y") apply(simp)
        apply(case_tac ws)
          apply(simp)
          apply(auto)
        proof (goal_cases)
          case (1 as)
          then show ?case
            proof (induct as)
              case (Cons a as)
              then have as: "set as \<subseteq> {x,y}" and axy: "a \<in> {x,y}" by auto
              from Cons(1)[OF as] obtain ws where asco: "as = concat ws" and ws: "set ws \<subseteq> {[y],[x]}" by auto
              show ?case
                apply(rule exI[where x="[a]#ws"])
                using axy by(auto simp add: asco ws)
            qed (rule exI[where x="[]"], simp)
          qed
   finally show ?thesis by(simp add: myUNIV_def)
qed

definition "nodouble x y = (Plus
                   (seq[question (Atom x), Star(Times(Atom y)(Atom x)),(Atom y)])
                   (seq[question (Atom y), Star(Times(Atom x) (Atom y)),(Atom x)]))"

lemma myUNIV_char: "lang (myUNIV (x::nat) y) = lang (Times (Star (L_lasthasxx x y)) (Plus One (nodouble x y)))" (is "lang ?A = lang ?B")
proof -
  let ?\<sigma> = "(\<lambda>i. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"

  let ?e1 = "Star (Plus (Atom 1) (Atom 3))"
  let ?e2 = "(Times (Star (Plus (seq [Plus (Atom 1) One, Star  (Times (Atom 3) (Atom 1)), Atom 3, Atom 3])
           (seq [Plus (Atom 3) One, Star (Times (Atom 1) (Atom 3)), Atom 1, Atom 1])))
       (Plus One
         (Plus
           (seq
             [Plus (Atom 1)
               One,
              Star
               (Times (Atom 3)
 (Atom 1)),
              Atom 3])
           (seq
             [Plus (Atom 3)
               One,
              Star
               (Times (Atom 1)
 (Atom 3)),
              Atom 1]))))"
  have "lang ?A = lang (subst ?e1 ?\<sigma>)" by(simp add: myUNIV_def)
  thm soundness
  also have "\<dots> = lang (subst ?e2 ?\<sigma>)"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have "\<dots> = lang ?B" by (simp add: L_lasthasxx_def nodouble_def)
  finally show ?thesis .
qed

definition "mycasexxy x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x, Atom x, Atom y])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom y, Atom x])"
definition "mycasexyx x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x, Atom y, Atom x])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom x, Atom y])"
definition "mycasexx x y = Plus (seq[Star (Plus (Atom x) (Atom y)), Atom x,  Atom x])
                (seq[Star (Plus (Atom x) (Atom y)), Atom y, Atom y])"
definition "mycasexy x y = Plus (seq[Atom x,  Atom y]) (seq[Atom y, Atom x])"
definition "mycasex x y = Plus (Atom y) (Atom x)"

definition "mycases x y = Plus
                   (mycasexxy x y)
              (Plus (mycasexyx x y)
              (Plus (mycasexx x y)
                    (Plus (mycasexy x y) (Plus (mycasex x y) (One)))))"

lemma mycases_char: "lang (myUNIV (x::nat) y) = lang (mycases x y)" (is "lang ?A = lang ?B")
proof -
  let ?\<sigma> = "(\<lambda>i. (if i=0 then Some (Atom x) else (if i=1 then Some (Atom y) else None)))"

  let ?e1 = "Star (Plus (Atom 1) (Atom 3))"
  let ?e2 = "Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 1, Atom 3])
           (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 3, Atom 1]))
     (Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 3, Atom 1])
             (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 1, Atom 3]))
       (Plus (Plus (seq [Star (Plus (Atom 1) (Atom 3)), Atom 1, Atom 1])
               (seq [Star (Plus (Atom 1) (Atom 3)), Atom 3, Atom 3]))
         (Plus (Plus (seq [Atom 1, Atom 3]) (seq [Atom 3, Atom 1])) (Plus (Plus (Atom 3) (Atom 1)) One))))"

  have "lang ?A = lang (subst ?e1 ?\<sigma>)" by(simp add: myUNIV_def)
  thm soundness
  also have "\<dots> = lang (subst ?e2 ?\<sigma>)"
        apply(rule lift)
        apply(rule soundness)
        by eval
  also have "\<dots> = lang ?B" by (simp add:  mycases_def mycasexxy_def mycasexyx_def
                                          mycasexx_def mycasex_def mycasexy_def)
  finally show ?thesis .
qed

end


(* Title:      Applications of Modal Kleene Algebras
   Author:     Victor B. F. Gomes, Walter Guttmann, Peter Höfner, Georg Struth, Tjark Weber
   Maintainer: Walter Guttmann <walter.guttman at canterbury.ac.nz>
               Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Applications of Modal Kleene Algebras\<close>

theory Modal_Kleene_Algebra_Applications
imports Antidomain_Semiring
begin

text \<open>This file collects some applications of the theories developed so far. These are described
 in~\<^cite>\<open>"guttmannstruthweber11algmeth"\<close>.\<close>

context antidomain_kleene_algebra
begin

subsection \<open>A Reachability Result\<close>

text \<open>This example is taken from~\<^cite>\<open>"desharnaismoellerstruth06kad"\<close>.\<close>

lemma opti_iterate_var [simp]: "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof (rule order.antisym)
  show "|(ad y \<cdot> x)\<^sup>\<star>\<rangle> y \<le> |x\<^sup>\<star>\<rangle> y"
    by (simp add: a_subid_aux1' ds.fd_iso2 star_iso)
  have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = d y + ad y \<cdot> |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.ads_d_def local.d_6 local.fdia_def by auto
  also have "... = d y + |ad y \<cdot> x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (simp add: fdia_export_2)
  finally have "d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y = |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by simp
  thus "|x\<^sup>\<star>\<rangle> y \<le> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    using local.dka.fd_def local.dka.fdia_star_induct_eq by auto
qed

lemma opti_iterate [simp]: "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = |x\<^sup>\<star>\<rangle> y"
proof -
  have "d y + |(x \<cdot> ad y)\<^sup>\<star>\<rangle> |x\<rangle> y = d y + |x\<rangle> |(ad y \<cdot> x)\<^sup>\<star>\<rangle> y"
    by (metis local.conway.dagger_slide local.ds.fdia_mult)
  also have "... = d y + |x\<rangle> |x\<^sup>\<star>\<rangle> y"
    by simp
  finally show ?thesis
    by force
qed

lemma opti_iterate_var_2 [simp]: "d y + |ad y \<cdot> x\<rangle> |x\<^sup>\<star>\<rangle> y = |x\<^sup>\<star>\<rangle> y"
  by (metis local.dka.fdia_star_unfold_var opti_iterate_var)

subsection \<open>Derivation of Segerberg's Formula\<close>

text \<open>This example is taken from~\<^cite>\<open>"DesharnaisMoellerStruthLMCS"\<close>.\<close>

definition Alpha :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("A")
  where "A x y = d (x \<cdot> y) \<cdot> ad y"

lemma A_dom [simp]: "d (A x y) = A x y"
  using Alpha_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma A_fdia: "A x y = |x\<rangle> y \<cdot> ad y"
  by (simp add: Alpha_def local.dka.fd_def)

lemma A_fdia_var: "A x y = |x\<rangle> d y \<cdot> ad y"
  by (simp add: A_fdia)

lemma a_A: "ad (A x (ad y)) = |x] y + ad y"
  using Alpha_def local.a_6 local.a_d_closed local.apd_d_def local.fbox_def by force

lemma fsegerberg [simp]: "d y + |x\<^sup>\<star>\<rangle> A x y = |x\<^sup>\<star>\<rangle> y"
proof (rule order.antisym)
  have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<rangle> y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia add_assoc local.ds.fdia_add1)
  also have "... = d y + |x\<rangle> y \<cdot> ad y + |x\<rangle> |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (metis local.am2 local.d_6 local.dka.fd_def local.fdia_def)
  finally have "d y + |x\<rangle> (d y + |x\<^sup>\<star>\<rangle> A x y) = d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis A_dom A_fdia add_assoc local.dka.fdia_star_unfold_var)
  thus "|x\<^sup>\<star>\<rangle> y \<le> d y + |x\<^sup>\<star>\<rangle> A x y"
    by (metis local.a_d_add_closure local.ads_d_def local.dka.fdia_star_induct_eq local.fdia_def)
  have "d y + |x\<^sup>\<star>\<rangle> A x y = d y + |x\<^sup>\<star>\<rangle> ( |x\<rangle> y \<cdot> ad y )"
    by (simp add: A_fdia)
  also have "... \<le> d y + |x\<^sup>\<star>\<rangle> |x\<rangle> y"
    using local.dpdz.domain_1'' local.ds.fd_iso1 local.join.sup_mono by blast
  finally show "d y + |x\<^sup>\<star>\<rangle> A x y \<le> |x\<^sup>\<star>\<rangle> y"
    by simp
qed

lemma fbox_segerberg [simp]: "d y \<cdot> |x\<^sup>\<star>] ( |x] y + ad y ) = |x\<^sup>\<star>] y"
proof -
  have "|x\<^sup>\<star>] ( |x] y + ad y ) = d ( |x\<^sup>\<star>] ( |x] y + ad y ) )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by auto
  hence f1: "|x\<^sup>\<star>] ( |x] y + ad y ) = ad ( |x\<^sup>\<star>\<rangle> (A x (ad y)) )"
    by (simp add: a_A local.fdia_fbox_de_morgan_2)
  have "ad y + |x\<^sup>\<star>\<rangle> (A x (ad y)) = |x\<^sup>\<star>\<rangle> ad y"
    by (metis fsegerberg local.a_d_closed local.ads_d_def local.apd_d_def)
  thus ?thesis
    by (metis f1 local.ads_d_def local.ans4 local.fbox_simp local.fdia_fbox_de_morgan_2)
qed

subsection \<open>Wellfoundedness and Loeb's Formula\<close>

text \<open>This example is taken from~\<^cite>\<open>"DesharnaisStruthSCP"\<close>.\<close>

definition Omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Omega>")
  where "\<Omega> x y = d y \<cdot> ad (x \<cdot> y)"

text \<open>If $y$ is a set, then $\Omega(x,y)$ describes those elements in $y$ from which no further $x$ transitions are possible.\<close>

lemma omega_fdia: "\<Omega> x y = d y \<cdot> ad ( |x\<rangle> y )"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def local.dka.fd_def by auto

lemma omega_fbox: "\<Omega> x y = d y \<cdot> |x] (ad y)"
  by (simp add: fdia_fbox_de_morgan_2 omega_fdia)

lemma omega_absorb1 [simp]: "\<Omega> x y \<cdot> ad ( |x\<rangle> y ) = \<Omega> x y"
  by (simp add: mult_assoc omega_fdia)

lemma omega_absorb2 [simp]: "\<Omega> x y \<cdot> ad (x \<cdot> y) = \<Omega> x y"
  by (simp add: Omega_def mult_assoc)

lemma omega_le_1: "\<Omega> x y \<le> d y"
  by (simp add: Omega_def d_a_galois1)

lemma omega_subid: "\<Omega> x (d y) \<le> d y"
  by (simp add: Omega_def local.a_subid_aux2)

lemma omega_le_2: "\<Omega> x y \<le> ad ( |x\<rangle> y )"
  by (simp add: local.dka.dom_subid_aux2 omega_fdia)

lemma omega_dom [simp]: "d (\<Omega> x y) = \<Omega> x y"
  using Omega_def local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma a_omega: "ad (\<Omega> x y) = ad y + |x\<rangle> y"
  by (simp add: Omega_def local.a_6 local.ds.fd_def)

lemma omega_fdia_3 [simp]: "d y \<cdot> ad (\<Omega> x y) = d y \<cdot> |x\<rangle> y"
  using Omega_def local.ads_d_def local.fdia_def local.s4 by presburger

lemma omega_zero_equiv_1: "\<Omega> x y = 0 \<longleftrightarrow> d y \<le> |x\<rangle> y"
  by (simp add: Omega_def local.a_gla local.ads_d_def local.fdia_def)

definition Loebian :: "'a \<Rightarrow> bool"
  where "Loebian x = (\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y)"

definition PreLoebian :: "'a \<Rightarrow> bool"
  where "PreLoebian x = (\<forall>y. d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y)"

definition Noetherian :: "'a \<Rightarrow> bool"
  where "Noetherian x = (\<forall>y. \<Omega> x y = 0 \<longrightarrow> d y = 0)"

lemma noetherian_alt: "Noetherian x \<longleftrightarrow> (\<forall>y. d y \<le> |x\<rangle> y \<longrightarrow> d y = 0)"
  by (simp add: Noetherian_def omega_zero_equiv_1)

lemma Noetherian_iff_PreLoebian: "Noetherian x \<longleftrightarrow> PreLoebian x"
proof
  assume hyp: "Noetherian x"
  {
    fix y
    have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = d y \<cdot> ad (\<Omega> x y + |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y)"
      by (metis local.dka.fdia_star_unfold_var omega_dom)
    also have "... = d y \<cdot> ad (\<Omega> x y) \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      using ans4 mult_assoc by presburger
    also have "... \<le> |x\<rangle> d y \<cdot> ad ( |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y )"
      by (simp add: local.dka.dom_subid_aux2 local.mult_isor)
    also have "... \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by (simp add: local.dia_diff)
    finally have "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) \<le> |x\<rangle> (d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ))"
      by blast
    hence "d y \<cdot> ad ( |x\<^sup>\<star>\<rangle> \<Omega> x y ) = 0"
      by (metis hyp local.ads_d_def local.dpdz.dom_mult_closed local.fdia_def noetherian_alt)
    hence "d y \<le> |x\<^sup>\<star>\<rangle> \<Omega> x y"
      by (simp add: local.a_gla local.ads_d_def local.dka.fd_def)
  }
  thus "PreLoebian x"
    using PreLoebian_def by blast
next
  assume a: "PreLoebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    hence "d y = 0"
      by (metis (no_types) PreLoebian_def a b a_one a_zero add_zeror annir fdia_def less_eq_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma Loebian_imp_Noetherian: "Loebian x \<Longrightarrow> Noetherian x"
proof -
  assume a: "Loebian x"
  {
    fix y
    assume b: "\<Omega> x y = 0"
    hence "d y \<le> |x\<rangle> d y"
      using omega_zero_equiv_1 by auto
    also have "... \<le> |x\<rangle> (\<Omega> x y)"
      using Loebian_def a by auto
    finally have "d y = 0"
      by (simp add: b order.antisym fdia_def)
  }
  thus "Noetherian x"
    by (simp add: Noetherian_def)
qed

lemma d_transitive: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<^sup>\<star>\<rangle> |x\<rangle> y)"
proof -
  assume a: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  {
    fix y
    have "|x\<rangle> y + |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      by (simp add: a)
    hence "|x\<^sup>\<star>\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
      using local.dka.fd_def local.dka.fdia_star_induct_var by auto
    have "|x\<rangle> y \<le> |x\<^sup>\<star>\<rangle> |x\<rangle> y"
      using local.dka.fd_def local.order_prop opti_iterate by force
  }
  thus ?thesis
    using a order.antisym dka.fd_def dka.fdia_star_induct_var by auto
qed

lemma d_transitive_var: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> (\<forall>y. |x\<rangle> y = |x\<rangle> |x\<^sup>\<star>\<rangle> y)"
proof -
  assume "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y"
  then have "\<forall>a. |x\<rangle> |x\<^sup>\<star>\<rangle> a = |x\<rangle> a"
    by (metis (full_types) d_transitive local.dka.fd_def local.dka.fdia_d_simp local.star_slide_var mult_assoc)
  then show ?thesis
    by presburger
qed

lemma d_transitive_PreLoebian_imp_Loebian: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y) \<Longrightarrow> PreLoebian x \<Longrightarrow> Loebian x"
proof -
  assume wt: "(\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y)"
  and "PreLoebian x"
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> |x\<^sup>\<star>\<rangle> \<Omega> x y"
    using PreLoebian_def local.ads_d_def local.dka.fd_def local.ds.fd_iso1 by auto
  hence "\<forall>y. |x\<rangle> y \<le> |x\<rangle> \<Omega> x y"
    by (metis wt d_transitive_var)
  then show "Loebian x"
    using Loebian_def fdia_def by auto
qed

lemma d_transitive_Noetherian_iff_Loebian: "\<forall>y. |x\<rangle> |x\<rangle> y \<le> |x\<rangle> y \<Longrightarrow> Noetherian x \<longleftrightarrow> Loebian x"
  using Loebian_imp_Noetherian Noetherian_iff_PreLoebian d_transitive_PreLoebian_imp_Loebian by blast

lemma Loeb_iff_box_Loeb: "Loebian x \<longleftrightarrow> (\<forall>y. |x] (ad ( |x] y ) + d y) \<le> |x] y)"
proof -
  have "Loebian x \<longleftrightarrow> (\<forall>y. |x\<rangle> y \<le> |x\<rangle> (d y \<cdot> |x] (ad y)))"
    using Loebian_def omega_fbox by auto
  also have "... \<longleftrightarrow> (\<forall>y. ad ( |x\<rangle> (d y \<cdot> |x] (ad y)) ) \<le> ad ( |x\<rangle> y ))"
    using a_antitone' fdia_def by fastforce
  also have "... \<longleftrightarrow> (\<forall>y. |x] ad (d y \<cdot> |x] (ad y)) \<le> |x] (ad y))"
    by (simp add: fdia_fbox_de_morgan_2)
  also have "... \<longleftrightarrow> (\<forall>y. |x] (d (ad y) + ad ( |x] (ad y) )) \<le> |x] (ad y))"
    by (simp add: local.ads_d_def local.fbox_def)
  finally show ?thesis
    by (metis add_commute local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def)
qed

end

subsection \<open>Divergence Kleene Algebras and Separation of Termination\<close>

text \<open>The notion of divergence has been added to modal Kleene algebras in~\<^cite>\<open>"DesharnaisMoellerStruthLMCS"\<close>.
More facts about divergence could be added in the future. Some could be adapted from omega algebras.\<close>

class nabla_op =
  fixes nabla :: "'a \<Rightarrow> 'a" ("\<nabla>_" [999] 1000)

class fdivergence_kleene_algebra = antidomain_kleene_algebra + nabla_op +
  assumes nabla_closure [simp]: "d \<nabla> x = \<nabla> x"
  and nabla_unfold: "\<nabla> x \<le> |x\<rangle> \<nabla> x"
  and nabla_coinduction: "d y \<le> |x\<rangle> y + d z \<Longrightarrow> d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"

begin

lemma nabla_coinduction_var: "d y \<le> |x\<rangle> y \<Longrightarrow> d y \<le> \<nabla> x"
proof -
  assume "d y \<le> |x\<rangle> y"
  hence "d y \<le> |x\<rangle> y + d 0"
    by simp
  hence "d y \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> 0"
    using nabla_coinduction by blast
  thus "d y \<le> \<nabla> x"
    by (simp add: fdia_def)
qed

lemma nabla_unfold_eq [simp]: "|x\<rangle> \<nabla> x = \<nabla> x"
proof -
  have f1: "ad (ad (x \<cdot> \<nabla>x)) = ad (ad (x \<cdot> \<nabla>x)) + \<nabla>x"
    using local.ds.fd_def local.join.sup.order_iff local.nabla_unfold by presburger
  then have "ad (ad (x \<cdot> \<nabla>x)) \<cdot> ad (ad \<nabla>x) = \<nabla>x"
    by (metis local.ads_d_def local.dpdz.dns5 local.dpdz.dsg4 local.join.sup_commute local.nabla_closure)
  then show ?thesis
    using f1 by (metis local.ads_d_def local.ds.fd_def local.ds.fd_subdist_2 local.join.sup.order_iff local.join.sup_commute nabla_coinduction_var)
qed

lemma nabla_subdist: "\<nabla> x \<le> \<nabla> (x + y)"
proof -
  have "d \<nabla> x \<le> \<nabla> (x + y)"
    by (metis local.ds.fd_iso2 local.join.sup.cobounded1 local.nabla_closure nabla_coinduction_var nabla_unfold_eq)
  thus ?thesis
    by simp
qed

lemma nabla_iso: "x \<le> y \<Longrightarrow> \<nabla> x \<le> \<nabla> y"
  by (metis less_eq_def nabla_subdist)

lemma nabla_omega: "\<Omega> x (d y) = 0 \<Longrightarrow> d y \<le> \<nabla> x"
  using omega_zero_equiv_1 nabla_coinduction_var by fastforce

lemma nabla_noether: "\<nabla> x = 0 \<Longrightarrow> Noetherian x"
  using local.join.le_bot local.noetherian_alt nabla_coinduction_var by blast

lemma nabla_preloeb: "\<nabla> x = 0 \<Longrightarrow> PreLoebian x"
  using Noetherian_iff_PreLoebian nabla_noether by auto

lemma star_nabla_1 [simp]: "|x\<^sup>\<star>\<rangle> \<nabla> x = \<nabla> x"
proof (rule order.antisym)
  show "|x\<^sup>\<star>\<rangle> \<nabla> x \<le> \<nabla> x"
    by (metis dka.fdia_star_induct_var order.eq_iff nabla_closure nabla_unfold_eq)
  show "\<nabla> x \<le> |x\<^sup>\<star>\<rangle> \<nabla> x"
    by (metis ds.fd_iso2 star_ext nabla_unfold_eq)
qed

lemma nabla_sum_expand [simp]: "|x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "d ((x + y) \<cdot> \<nabla>(x + y)) = \<nabla>(x + y)"
    using local.dka.fd_def nabla_unfold_eq by presburger
  thus ?thesis
    by (simp add: local.dka.fd_def)
qed

lemma wagner_3:
  assumes "d z + |x\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
  shows "\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> z"
proof (rule order.antisym)
  have "d \<nabla>(x + y) \<le> d z + |x\<rangle> \<nabla>(x + y)"
    by (simp add: assms)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> z"
    by (metis add_commute nabla_closure nabla_coinduction)
  have "d z + |x\<rangle> \<nabla> (x + y) \<le> \<nabla> (x + y)"
    using assms by auto
  hence "|x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (metis local.dka.fdia_star_induct local.nabla_closure)
  thus "\<nabla> x + |x\<^sup>\<star>\<rangle> z \<le> \<nabla> (x + y)"
    by (simp add: sup_least nabla_subdist)
qed

lemma nabla_sum_unfold [simp]: "\<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y) = \<nabla> (x + y)"
proof -
  have "\<nabla> (x + y) = |x\<rangle> \<nabla> (x + y) + |y\<rangle> \<nabla> (x + y)"
    by simp
  thus ?thesis
    by (metis add_commute local.dka.fd_def local.ds.fd_def local.ds.fdia_d_simp wagner_3)
qed

lemma nabla_separation: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> (\<nabla> (x + y) = \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y)"
proof (rule order.antisym)
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  hence a: "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using quasicomm_var by blast
  have "\<nabla> (x + y) = \<nabla> y + |y\<^sup>\<star>\<cdot> x\<rangle> \<nabla> (x + y)"
    by (metis local.ds.fdia_mult local.join.sup_commute nabla_sum_unfold)
  also have "... \<le> \<nabla> y + |x \<cdot> (x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    using a local.ds.fd_iso2 local.join.sup.mono by blast
  also have "... = \<nabla> y + |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally have "\<nabla> (x + y) \<le> \<nabla> y + |x\<rangle> \<nabla> (x + y)"
    by (metis star_nabla_1)
  thus "\<nabla> (x + y) \<le> \<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y"
    by (metis add_commute nabla_closure nabla_coinduction)
next
  have "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> y"
    by simp
  also have "... = \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> y"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> \<nabla> x + |x\<^sup>\<star> \<cdot> y\<rangle> \<nabla> (x + y)"
    using dpdz.dom_iso eq_refl fdia_def join.sup_ge2 join.sup_mono mult_isol nabla_iso by presburger
  also have "... = \<nabla> x + |x\<^sup>\<star>\<rangle> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def mult_assoc)
  finally show "\<nabla> x + |x\<^sup>\<star>\<rangle> \<nabla> y \<le> \<nabla> (x + y)"
    by (metis nabla_sum_unfold)
qed

text \<open>The next lemma is a separation of termination theorem by Bachmair and Dershowitz~\<^cite>\<open>"bachmair86commutation"\<close>.\<close>

lemma bachmair_dershowitz: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> \<Longrightarrow> \<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof -
  assume quasi_comm: "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  have "\<forall>x. |x\<rangle> 0 = 0"
    by (simp add: fdia_def)
  hence "\<nabla>y = 0 \<Longrightarrow> \<nabla>x + \<nabla>y = 0 \<longleftrightarrow> \<nabla>(x + y) = 0"
    using quasi_comm nabla_separation by presburger
  thus ?thesis
    using add_commute local.join.le_bot nabla_subdist by fastforce
qed

text \<open>The next lemma is a more complex separation of termination theorem by Doornbos,
Backhouse and van der Woude~\<^cite>\<open>"doornbos97calculational"\<close>.\<close>

lemma separation_of_termination:
assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star> + y"
shows "\<nabla> x + \<nabla> y = 0 \<longleftrightarrow> \<nabla> (x + y) = 0"
proof
  assume xy_wf: "\<nabla> x + \<nabla> y = 0"
  hence x_preloeb: "\<nabla> (x + y) \<le> |x\<^sup>\<star>\<rangle> \<Omega> x (\<nabla> (x + y))"
    by (metis PreLoebian_def no_trivial_inverse nabla_closure nabla_preloeb)
  hence y_div: "\<nabla> y = 0"
    using add_commute no_trivial_inverse xy_wf by blast
  have "\<nabla> (x + y) \<le> |y\<rangle> \<nabla> (x + y) + |x\<rangle> \<nabla> (x + y)"
    by (simp add: local.join.sup_commute)
  hence "\<nabla> (x + y) \<cdot> ad ( |x\<rangle> \<nabla> (x + y) ) \<le> |y\<rangle> \<nabla>(x + y)"
    by (simp add: local.da_shunt1 local.dka.fd_def local.join.sup_commute)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> \<nabla> (x + y)"
    by (simp add: fdia_def omega_fdia)
  also have "... \<le> |y\<rangle> |x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.dpdz.dom_iso local.ds.fd_iso1 x_preloeb by blast
  also have "... = |y \<cdot> x\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  also have "... \<le> |x \<cdot> (x + y)\<^sup>\<star> + y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using assms local.ds.fd_iso2 local.lazycomm_var by blast
  also have "... = |x \<cdot> (x + y)\<^sup>\<star>\<rangle> (\<Omega> x \<nabla>(x + y)) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.dka.fd_def)
  also have "... \<le> |(x \<cdot> (x + y)\<^sup>\<star>)\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    using local.add_iso local.dpdz.domain_1'' local.ds.fd_iso1 local.omega_fdia by auto
  also have "... \<le> |x\<rangle> |(x + y)\<^sup>\<star>\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: fdia_def mult_assoc)
  finally have "\<Omega> x \<nabla>(x + y) \<le> |x\<rangle> \<nabla>(x + y) + |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (metis star_nabla_1)
  hence "\<Omega> x \<nabla>(x + y) \<cdot> ad ( |x\<rangle> \<nabla>(x + y) ) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: local.da_shunt1 local.dka.fd_def)
  hence "\<Omega> x \<nabla>(x + y) \<le> |y\<rangle> (\<Omega> x \<nabla>(x + y))"
    by (simp add: omega_fdia mult_assoc)
  hence "(\<Omega> x \<nabla>(x + y)) = 0"
    by (metis noetherian_alt omega_dom nabla_noether y_div)
  thus "\<nabla> (x + y) = 0"
    using local.dka.fd_def local.join.le_bot x_preloeb by auto
next
  assume "\<nabla> (x + y) = 0"
  thus "(\<nabla> x) + (\<nabla> y) = 0"
    by (metis local.join.le_bot local.join.sup.order_iff local.join.sup_commute nabla_subdist)
qed

text \<open>The final examples can be found in~\<^cite>\<open>"guttmannstruthweber11algmeth"\<close>.\<close>

definition T :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("_ \<leadsto> _ \<leadsto> _" [61,61,61] 60)
  where "p\<leadsto>x\<leadsto>q \<equiv> ad p + |x] d q"

lemma T_d [simp]: "d (p\<leadsto>x\<leadsto>q) = p\<leadsto>x\<leadsto>q"
  using T_def local.a_d_add_closure local.fbox_def by auto

lemma T_p: "d p \<cdot> (p\<leadsto>x\<leadsto>q) = d p \<cdot> |x] d q"
proof -
  have "d p \<cdot> (p\<leadsto>x\<leadsto>q) = ad (ad p + ad (p\<leadsto>x\<leadsto>q))"
    using T_d local.ads_d_def by auto
  thus ?thesis
    using T_def add_commute local.a_mult_add local.ads_d_def by auto
qed

lemma T_a [simp]: "ad p \<cdot> (p\<leadsto>x\<leadsto>q) = ad p"
  by (metis T_d T_def local.a_d_closed local.ads_d_def local.apd_d_def local.dpdz.dns5 local.join.sup.left_idem)

lemma T_seq: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> p\<leadsto>x \<cdot> y\<leadsto>s"
proof -
  have f1: "|x] q = |x] d q"
    using local.fbox_simp by auto
  have "ad p \<cdot> ad (x \<cdot> ad (q\<leadsto>y\<leadsto>s)) + |x] d q \<cdot> |x] (ad q + |y] d s) \<le> ad p + |x] d q \<cdot> |x] (ad q + |y] d s)"
    using local.a_subid_aux2 local.add_iso by blast
  hence "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>y\<leadsto>s) \<le> ad p + |x](d q \<cdot> (q\<leadsto>y\<leadsto>s))"
    by (metis T_d T_def f1 local.distrib_right' local.fbox_add1 local.fbox_def)
  also have "... = ad p + |x](d q \<cdot> (ad q + |y] d s))"
    by (simp add: T_def)
  also have "... = ad p + |x](d q \<cdot> |y] d s)"
    using T_def T_p by auto
  also have "... \<le> ad p + |x] |y] d s"
    by (metis (no_types, lifting) dka.dom_subid_aux2 dka.dsg3 order.eq_iff fbox_iso join.sup.mono)
  finally show ?thesis
    by (simp add: T_def fbox_mult)
qed

lemma T_square: "(p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<le> p\<leadsto>x\<cdot>x\<leadsto>p"
  by (simp add: T_seq)

lemma T_segerberg [simp]: "d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p) = |x\<^sup>\<star>] d p"
  using T_def add_commute local.fbox_segerberg local.fbox_simp by force

lemma lookahead [simp]: "|x\<^sup>\<star>](d p \<cdot> |x] d p) = |x\<^sup>\<star>] d p"
  by (metis (full_types) local.dka.dsg3 local.fbox_add1 local.fbox_mult local.fbox_simp local.fbox_star_unfold_var local.star_slide_var local.star_trans_eq)

lemma alternation: "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
proof -
  have fbox_simp_2: "\<And>x p. |x]p = d( |x] p )"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.fbox_def by fastforce
  have "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p))"
    using local.dka.domain_1'' local.fbox_iso local.order_trans by blast
  also have "... \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)"
    using T_seq local.dka.dom_iso local.fbox_iso by blast
  finally have 1: "|(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q)) \<le> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p)".
  have "d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) = d p \<cdot> |1+x] |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (metis (full_types) fbox_mult meyer_1)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    using fbox_simp_2 fbox_mult fbox_add2 mult_assoc by auto
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>\<cdot>x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: star_slide)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p))"
    by (simp add: fbox_mult)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x]((p\<leadsto>x\<leadsto>q) \<cdot> (q\<leadsto>x\<leadsto>p)))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1 mult_assoc)
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)"
      by (metis (full_types) T_d fbox_simp_2 local.dka.dsg3)
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))"
      by (metis (full_types) fbox_simp_2 local.fbox_add1)
    then have f2: "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = ad ((x \<cdot> x)\<^sup>\<star> \<cdot> ad ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) + (x \<cdot> x)\<^sup>\<star> \<cdot> ad (d ( |x] (q \<leadsto> x \<leadsto> p))))"
      by (simp add: add_commute local.fbox_def)
    have "d ( |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d ( |x] (q \<leadsto> x \<leadsto> p)) = |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      by (metis (no_types) T_d fbox_simp_2 local.fbox_add1)
    then have "d ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q)) \<cdot> d (d ( |x] (q \<leadsto> x \<leadsto> p))) = (q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p))"
      using f1 fbox_simp_2 mult_assoc by force
    then have "|(x \<cdot> x)\<^sup>\<star>] (d ( |x] (q \<leadsto> x \<leadsto> p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] (p \<leadsto> x \<leadsto> q))) = |(x \<cdot> x)\<^sup>\<star>] ((q \<leadsto> x \<leadsto> p) \<cdot> |x] ((p \<leadsto> x \<leadsto> q) \<cdot> (q \<leadsto> x \<leadsto> p)))"
      using f2 by (metis (no_types) local.ans4 local.fbox_add1 local.fbox_def)
    then show ?thesis
      by (metis (no_types) T_d fbox_simp_2 local.dka.dsg3 local.fbox_add1 mult_assoc)
  qed
  also have "... = d p \<cdot> |(x\<cdot>x)\<^sup>\<star>](p\<leadsto>x\<cdot>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>]((p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))" using "1"
    by (metis fbox_simp_2 dka.dns5 dka.dsg4 join.sup.absorb2 mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (p\<leadsto>x\<leadsto>q) \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    using T_segerberg local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x](q\<leadsto>x\<leadsto>p) \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (simp add: T_p)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x] d q \<cdot> |x] |x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](p\<leadsto>x\<leadsto>q))"
    by (metis T_d T_p fbox_simp_2 fbox_add1 fbox_simp mult_assoc)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x] d q \<cdot> |x](p\<leadsto>x\<leadsto>q))"
  proof -
    have f1: "ad (x \<cdot> ad ( |x] d p)) = |x \<cdot> x] d p"
      using local.fbox_def local.fbox_mult by presburger
    have f2: "ad (d q \<cdot> d (x \<cdot> ad (d p))) = q \<leadsto> x \<leadsto> p"
      by (simp add: T_def local.a_de_morgan_var_4 local.fbox_def)
    have "ad q + |x] d p = ad (d q \<cdot> d (x \<cdot> ad (d p)))"
      by (simp add: local.a_de_morgan_var_4 local.fbox_def)
    then have "ad (x \<cdot> ad ( |x] d p)) \<cdot> ((q \<leadsto> x \<leadsto> p) \<cdot> |x] d q) = ad (x \<cdot> ad ( |x] d p)) \<cdot> ad (x \<cdot> ad (d q)) \<cdot> (ad q + |x] d p)"
      using f2 by (metis (no_types) local.am2 local.fbox_def mult_assoc)
    then show ?thesis
      using f1 by (simp add: T_def local.am2 local.fbox_def mult_assoc)
  qed
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p \<cdot> (q\<leadsto>x\<leadsto>p) \<cdot> |x](d q \<cdot> (p\<leadsto>x\<leadsto>q)))"
    using local.a_d_closed local.ads_d_def local.apd_d_def local.distrib_left local.fbox_def mult_assoc by auto
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> |x\<cdot>x] d p) \<cdot> |(x\<cdot>x)\<^sup>\<star>](q\<leadsto>x\<leadsto>p) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x](d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d fbox_simp_2 local.dka.dom_mult_closed local.fbox_add1)
  also have "... = |(x\<cdot>x)\<^sup>\<star>](d p \<cdot> (q\<leadsto>x\<leadsto>p)) \<cdot> |(x\<cdot>x)\<^sup>\<star>] |x] (d q \<cdot> (p\<leadsto>x\<leadsto>q))"
    by (metis T_d local.fbox_add1 local.fbox_simp lookahead)
  finally show ?thesis
    by (metis fbox_mult star_slide)
qed

lemma "|(x\<cdot>x)\<^sup>\<star>] d p \<cdot> |x\<cdot>(x\<cdot>x)\<^sup>\<star>] ad p = d p \<cdot> |x\<^sup>\<star>]((p\<leadsto>x\<leadsto>ad p) \<cdot> (ad p\<leadsto>x\<leadsto>p))"
  using alternation local.a_d_closed local.ads_d_def local.apd_d_def by auto

lemma "|x\<^sup>\<star>] d p = d p \<cdot> |x\<^sup>\<star>](p\<leadsto>x\<leadsto>p)"
  by (simp add: alternation)

end

end