(*
    Title:      Code_Cayley_Hamilton_IArrays.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Code Cayley Hamilton\<close>

theory Code_Cayley_Hamilton_IArrays
  imports
  Cayley_Hamilton.Cayley_Hamilton
  Echelon_Form_Det_IArrays
begin

subsection\<open>Implementations over immutable arrays of some definitions
  presented in the Cayley-Hamilton development\<close>

definition scalar_matrix_mult_iarrays :: "('a::ab_semigroup_mult) \<Rightarrow> ('a iarray iarray) \<Rightarrow> ('a iarray iarray)"
  (infixl "*ssi" 70) where "c *ssi A = tabulate2 (nrows_iarray A) (ncols_iarray A) (% i j. c * (A !! i !! j))"

definition "minorM_iarrays A i j = tabulate2  (nrows_iarray A) (ncols_iarray A)
  (%k l. if k = i \<and> l = j then 1 else if k = i \<or> l = j then 0 else A !! k !! l)"
definition "cofactor_iarrays A i j = det_iarrays_rings (minorM_iarrays A i j)"
definition "cofactorM_iarrays A = tabulate2 (nrows_iarray A) (nrows_iarray A)
  (%i j. cofactor_iarrays A i j)"
definition "adjugate_iarrays A = transpose_iarray (cofactorM_iarrays A)"

lemma matrix_to_iarray_scalar_matrix_mult[code_unfold]:
  "matrix_to_iarray (k *k A) = k *ssi (matrix_to_iarray A)"
proof -
  have n_rw: "nrows_iarray (IArray (map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<CARD('c)]))
    = CARD('c)" unfolding nrows_iarray_def by auto
  have n_rw2: "nrows_iarray (IArray (map (\<lambda>x. IArray (map (\<lambda>i. A $ from_nat x $ from_nat i)
    [0..<CARD('b)])) [0..<CARD('c)])) = CARD('c)"   unfolding nrows_iarray_def by auto
  have n_rw3: "ncols_iarray (IArray (map (\<lambda>x. IArray (map (\<lambda>i. A $ from_nat x $ from_nat i)
    [0..<CARD('b)])) [0..<CARD('c)])) = CARD('b)"
    unfolding ncols_iarray_def by auto
  show ?thesis
    unfolding matrix_to_iarray_def o_def matrix_scalar_mult_def scalar_matrix_mult_iarrays_def
      tabulate2_def vec_to_iarray_def
    by (simp add: n_rw n_rw2 n_rw3)
qed

lemma matrix_to_iarray_minorM[code_unfold]:
  "matrix_to_iarray (minorM A i j) = minorM_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j)"
proof -
  have n_rw: "nrows_iarray (IArray (map (\<lambda>x. IArray (map (\<lambda>i. A $ from_nat x $ from_nat i)
    [0..<CARD('b)])) [0..<CARD('c)])) = CARD('c)"
    unfolding nrows_iarray_def by auto
  have n_rw2: "ncols_iarray (IArray (map (\<lambda>x. IArray (map (\<lambda>i. A $ from_nat x $ from_nat i)
    [0..<CARD('b)])) [0..<CARD('c)])) = CARD('b)"
    unfolding ncols_iarray_def by simp
  show ?thesis
    unfolding matrix_to_iarray_def o_def
    minorM_def minorM_iarrays_def
    tabulate2_def vec_to_iarray_def
    by (auto simp add: n_rw n_rw2 to_nat_from_nat_id)
qed

lemma matrix_to_iarray_cofactor[code_unfold]:
  "(cofactor A i j) = cofactor_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j)"
   unfolding o_def cofactor_iarrays_def cofactor_def cofactorM_def
   unfolding matrix_to_iarray_minorM[symmetric]
   unfolding matrix_to_iarray_det_euclidean_ring[symmetric] by simp

lemma matrix_to_iarray_cofactorM[code_unfold]:
  "matrix_to_iarray (cofactorM A) = cofactorM_iarrays (matrix_to_iarray A)"
proof -
  have n_rw: "nrows_iarray (IArray (map (\<lambda>x. IArray (map (\<lambda>i. A $ from_nat x $ from_nat i)
    [0..<CARD('b)])) [0..<CARD('b)])) = CARD('b)"
    unfolding nrows_iarray_def by simp
  show ?thesis
    unfolding cofactorM_iarrays_def tabulate2_def cofactorM_def
    by (auto simp add: n_rw matrix_to_iarray_cofactor
        matrix_to_iarray_def o_def vec_to_iarray_def to_nat_from_nat_id)
qed

lemma matrix_to_iarray_adjugate[code_unfold]:
  "matrix_to_iarray (adjugate A) = adjugate_iarrays (matrix_to_iarray A)"
  unfolding adjugate_def adjugate_iarrays_def
  unfolding matrix_to_iarray_cofactorM[symmetric]
  unfolding matrix_to_iarray_transpose[symmetric] ..

end


(*  Title:      HOL/Nonstandard_Analysis/HSeries.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge

Converted to Isar and polished by lcp
*)

section \<open>Finite Summation and Infinite Series for Hyperreals\<close>

theory HSeries
  imports HSEQ
begin

definition sumhr :: "hypnat \<times> hypnat \<times> (nat \<Rightarrow> real) \<Rightarrow> hypreal"
  where "sumhr = (\<lambda>(M,N,f). starfun2 (\<lambda>m n. sum f {m..<n}) M N)"

definition NSsums :: "(nat \<Rightarrow> real) \<Rightarrow> real \<Rightarrow> bool"  (infixr "NSsums" 80)
  where "f NSsums s = (\<lambda>n. sum f {..<n}) \<longlonglongrightarrow>\<^sub>N\<^sub>S s"

definition NSsummable :: "(nat \<Rightarrow> real) \<Rightarrow> bool"
  where "NSsummable f \<longleftrightarrow> (\<exists>s. f NSsums s)"

definition NSsuminf :: "(nat \<Rightarrow> real) \<Rightarrow> real"
  where "NSsuminf f = (THE s. f NSsums s)"

lemma sumhr_app: "sumhr (M, N, f) = ( *f2* (\<lambda>m n. sum f {m..<n})) M N"
  by (simp add: sumhr_def)

text \<open>Base case in definition of \<^term>\<open>sumr\<close>.\<close>
lemma sumhr_zero [simp]: "\<And>m. sumhr (m, 0, f) = 0"
  unfolding sumhr_app by transfer simp

text \<open>Recursive case in definition of \<^term>\<open>sumr\<close>.\<close>
lemma sumhr_if:
  "\<And>m n. sumhr (m, n + 1, f) = (if n + 1 \<le> m then 0 else sumhr (m, n, f) + ( *f* f) n)"
  unfolding sumhr_app by transfer simp

lemma sumhr_Suc_zero [simp]: "\<And>n. sumhr (n + 1, n, f) = 0"
  unfolding sumhr_app by transfer simp

lemma sumhr_eq_bounds [simp]: "\<And>n. sumhr (n, n, f) = 0"
  unfolding sumhr_app by transfer simp

lemma sumhr_Suc [simp]: "\<And>m. sumhr (m, m + 1, f) = ( *f* f) m"
  unfolding sumhr_app by transfer simp

lemma sumhr_add_lbound_zero [simp]: "\<And>k m. sumhr (m + k, k, f) = 0"
  unfolding sumhr_app by transfer simp

lemma sumhr_add: "\<And>m n. sumhr (m, n, f) + sumhr (m, n, g) = sumhr (m, n, \<lambda>i. f i + g i)"
  unfolding sumhr_app by transfer (rule sum.distrib [symmetric])

lemma sumhr_mult: "\<And>m n. hypreal_of_real r * sumhr (m, n, f) = sumhr (m, n, \<lambda>n. r * f n)"
  unfolding sumhr_app by transfer (rule sum_distrib_left)

lemma sumhr_split_add: "\<And>n p. n < p \<Longrightarrow> sumhr (0, n, f) + sumhr (n, p, f) = sumhr (0, p, f)"
  unfolding sumhr_app by transfer (simp add: sum.atLeastLessThan_concat)

lemma sumhr_split_diff: "n < p \<Longrightarrow> sumhr (0, p, f) - sumhr (0, n, f) = sumhr (n, p, f)"
  by (drule sumhr_split_add [symmetric, where f = f]) simp

lemma sumhr_hrabs: "\<And>m n. \<bar>sumhr (m, n, f)\<bar> \<le> sumhr (m, n, \<lambda>i. \<bar>f i\<bar>)"
  unfolding sumhr_app by transfer (rule sum_abs)

text \<open>Other general version also needed.\<close>
lemma sumhr_fun_hypnat_eq:
  "(\<forall>r. m \<le> r \<and> r < n \<longrightarrow> f r = g r) \<longrightarrow>
    sumhr (hypnat_of_nat m, hypnat_of_nat n, f) =
    sumhr (hypnat_of_nat m, hypnat_of_nat n, g)"
  unfolding sumhr_app by transfer simp

lemma sumhr_const: "\<And>n. sumhr (0, n, \<lambda>i. r) = hypreal_of_hypnat n * hypreal_of_real r"
  unfolding sumhr_app by transfer simp

lemma sumhr_less_bounds_zero [simp]: "\<And>m n. n < m \<Longrightarrow> sumhr (m, n, f) = 0"
  unfolding sumhr_app by transfer simp

lemma sumhr_minus: "\<And>m n. sumhr (m, n, \<lambda>i. - f i) = - sumhr (m, n, f)"
  unfolding sumhr_app by transfer (rule sum_negf)

lemma sumhr_shift_bounds:
  "\<And>m n. sumhr (m + hypnat_of_nat k, n + hypnat_of_nat k, f) =
    sumhr (m, n, \<lambda>i. f (i + k))"
  unfolding sumhr_app by transfer (rule sum.shift_bounds_nat_ivl)

subsection \<open>Nonstandard Sums\<close>

text \<open>Infinite sums are obtained by summing to some infinite hypernatural
  (such as \<^term>\<open>whn\<close>).\<close>
lemma sumhr_hypreal_of_hypnat_omega: "sumhr (0, whn, \<lambda>i. 1) = hypreal_of_hypnat whn"
  by (simp add: sumhr_const)

lemma whn_eq_\<omega>m1: "hypreal_of_hypnat whn = \<omega> - 1"
  unfolding star_class_defs omega_def hypnat_omega_def of_hypnat_def star_of_def
  by (simp add: starfun_star_n starfun2_star_n)

lemma sumhr_hypreal_omega_minus_one: "sumhr(0, whn, \<lambda>i. 1) = \<omega> - 1"
  by (simp add: sumhr_const whn_eq_\<omega>m1)

lemma sumhr_minus_one_realpow_zero [simp]: "\<And>N. sumhr (0, N + N, \<lambda>i. (-1) ^ (i + 1)) = 0"
  unfolding sumhr_app
  by transfer (induct_tac N, auto)

lemma sumhr_interval_const:
  "(\<forall>n. m \<le> Suc n \<longrightarrow> f n = r) \<and> m \<le> na \<Longrightarrow>
    sumhr (hypnat_of_nat m, hypnat_of_nat na, f) = hypreal_of_nat (na - m) * hypreal_of_real r"
  unfolding sumhr_app by transfer simp

lemma starfunNat_sumr: "\<And>N. ( *f* (\<lambda>n. sum f {0..<n})) N = sumhr (0, N, f)"
  unfolding sumhr_app by transfer (rule refl)

lemma sumhr_hrabs_approx [simp]: "sumhr (0, M, f) \<approx> sumhr (0, N, f) \<Longrightarrow> \<bar>sumhr (M, N, f)\<bar> \<approx> 0"
  using linorder_less_linear [where x = M and y = N]
  by (metis (no_types, lifting) abs_zero approx_hrabs approx_minus_iff approx_refl approx_sym sumhr_eq_bounds sumhr_less_bounds_zero sumhr_split_diff)

subsection \<open>Infinite sums: Standard and NS theorems\<close>

lemma sums_NSsums_iff: "f sums l \<longleftrightarrow> f NSsums l"
  by (simp add: sums_def NSsums_def LIMSEQ_NSLIMSEQ_iff)

lemma summable_NSsummable_iff: "summable f \<longleftrightarrow> NSsummable f"
  by (simp add: summable_def NSsummable_def sums_NSsums_iff)

lemma suminf_NSsuminf_iff: "suminf f = NSsuminf f"
  by (simp add: suminf_def NSsuminf_def sums_NSsums_iff)

lemma NSsums_NSsummable: "f NSsums l \<Longrightarrow> NSsummable f"
  unfolding NSsums_def NSsummable_def by blast

lemma NSsummable_NSsums: "NSsummable f \<Longrightarrow> f NSsums (NSsuminf f)"
  unfolding NSsummable_def NSsuminf_def NSsums_def
  by (blast intro: theI NSLIMSEQ_unique)

lemma NSsums_unique: "f NSsums s \<Longrightarrow> s = NSsuminf f"
  by (simp add: suminf_NSsuminf_iff [symmetric] sums_NSsums_iff sums_unique)

lemma NSseries_zero: "\<forall>m. n \<le> Suc m \<longrightarrow> f m = 0 \<Longrightarrow> f NSsums (sum f {..<n})"
  by (auto simp add: sums_NSsums_iff [symmetric] not_le[symmetric] intro!: sums_finite)

lemma NSsummable_NSCauchy:
  "NSsummable f \<longleftrightarrow> (\<forall>M \<in> HNatInfinite. \<forall>N \<in> HNatInfinite. \<bar>sumhr (M, N, f)\<bar> \<approx> 0)" (is "?L=?R")
proof -
  have "?L = (\<forall>M\<in>HNatInfinite. \<forall>N\<in>HNatInfinite. sumhr (0, M, f) \<approx> sumhr (0, N, f))"
    by (auto simp add: summable_iff_convergent convergent_NSconvergent_iff NSCauchy_def starfunNat_sumr
        simp flip: NSCauchy_NSconvergent_iff summable_NSsummable_iff atLeast0LessThan)
  also have "... \<longleftrightarrow> ?R"
    by (metis approx_hrabs_zero_cancel approx_minus_iff approx_refl approx_sym linorder_less_linear sumhr_hrabs_approx sumhr_split_diff)
  finally show ?thesis .
qed

text \<open>Terms of a convergent series tend to zero.\<close>
lemma NSsummable_NSLIMSEQ_zero: "NSsummable f \<Longrightarrow> f \<longlonglongrightarrow>\<^sub>N\<^sub>S 0"
  by (metis HNatInfinite_add NSLIMSEQ_def NSsummable_NSCauchy approx_hrabs_zero_cancel star_of_zero sumhr_Suc)

text \<open>Nonstandard comparison test.\<close>
lemma NSsummable_comparison_test: "\<exists>N. \<forall>n. N \<le> n \<longrightarrow> \<bar>f n\<bar> \<le> g n \<Longrightarrow> NSsummable g \<Longrightarrow> NSsummable f"
  by (metis real_norm_def summable_NSsummable_iff summable_comparison_test)

lemma NSsummable_rabs_comparison_test:
  "\<exists>N. \<forall>n. N \<le> n \<longrightarrow> \<bar>f n\<bar> \<le> g n \<Longrightarrow> NSsummable g \<Longrightarrow> NSsummable (\<lambda>k. \<bar>f k\<bar>)"
  by (rule NSsummable_comparison_test) auto

end


(*  Title:      HOL/Hoare/SepLogHeap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Heap abstractions (at the moment only Path and List)
for Separation Logic.
*)

theory SepLogHeap
imports Main
begin

type_synonym heap = "(nat \<Rightarrow> nat option)"

text{* @{text "Some"} means allocated, @{text "None"} means
free. Address @{text "0"} serves as the null reference. *}

subsection "Paths in the heap"

primrec Path :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x\<noteq>0 \<and> a=x \<and> (\<exists>b. h x = Some b \<and> Path h b as y))"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by (induct as) auto

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by (induct as) simp_all

subsection "Lists on the heap"

definition List :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
  where "List h x as = Path h x as 0"

lemma [simp]: "List h x [] = (x = 0)"
by (simp add: List_def)

lemma [simp]:
 "List h x (a#as) = (x\<noteq>0 \<and> a=x \<and> (\<exists>y. h x = Some y \<and> List h y as))"
by (simp add: List_def)

lemma [simp]: "List h 0 as = (as = [])"
by (cases as) simp_all

lemma List_non_null: "a\<noteq>0 \<Longrightarrow>
 List h a as = (\<exists>b bs. as = a#bs \<and> h a = Some b \<and> List h b bs)"
by (cases as) simp_all

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by (induct as) (auto simp add:List_non_null)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by (blast intro: List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by (induct as) auto

lemma List_hd_not_in_tl[simp]: "List h b as \<Longrightarrow> h a = Some b \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
by (induct as) (auto dest:List_hd_not_in_tl)

lemma list_in_heap: "\<And>p. List h p ps \<Longrightarrow> set ps \<subseteq> dom h"
by (induct ps) auto

lemma list_ortho_sum1[simp]:
 "\<And>p. \<lbrakk> List h1 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

lemma list_ortho_sum2[simp]:
 "\<And>p. \<lbrakk> List h2 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

end


(* Title:      Prim's Minimum Spanning Tree Algorithm
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Prim's Minimum Spanning Tree Algorithm\<close>

text \<open>
In this theory we prove total correctness of Prim's minimum spanning tree algorithm.
The proof has the same overall structure as the total-correctness proof of Kruskal's algorithm \<^cite>\<open>"Guttmann2018c"\<close>.
The partial-correctness proof of Prim's algorithm is discussed in \<^cite>\<open>"Guttmann2016c" and "Guttmann2018b"\<close>.
\<close>

theory Prim

imports "HOL-Hoare.Hoare_Logic" Aggregation_Algebras.Aggregation_Algebras

begin

context m_kleene_algebra
begin

abbreviation "component g r \<equiv> r\<^sup>T * (--g)\<^sup>\<star>"
definition "spanning_tree t g r \<equiv> forest t \<and> t \<le> (component g r)\<^sup>T * (component g r) \<sqinter> --g \<and> component g r \<le> r\<^sup>T * t\<^sup>\<star> \<and> regular t"
definition "minimum_spanning_tree t g r \<equiv> spanning_tree t g r \<and> (\<forall>u . spanning_tree u g r \<longrightarrow> sum (t \<sqinter> g) \<le> sum (u \<sqinter> g))"
definition "prim_precondition g r \<equiv> g = g\<^sup>T \<and> injective r \<and> vector r \<and> regular r"
definition "prim_spanning_invariant t v g r \<equiv> prim_precondition g r \<and> v\<^sup>T = r\<^sup>T * t\<^sup>\<star> \<and> spanning_tree t (v * v\<^sup>T \<sqinter> g) r"
definition "prim_invariant t v g r \<equiv> prim_spanning_invariant t v g r \<and> (\<exists>w . minimum_spanning_tree w g r \<and> t \<le> w)"

lemma span_tree_split:
  assumes "vector r"
    shows "t \<le> (component g r)\<^sup>T * (component g r) \<sqinter> --g \<longleftrightarrow> (t \<le> (component g r)\<^sup>T \<and> t \<le> component g r \<and> t \<le> --g)"
proof -
  have "(component g r)\<^sup>T * (component g r) = (component g r)\<^sup>T \<sqinter> component g r"
    by (metis assms conv_involutive covector_mult_closed vector_conv_covector vector_covector)
  thus ?thesis
    by simp
qed

lemma span_tree_component:
  assumes "spanning_tree t g r"
    shows "component g r = component t r"
  using assms by (simp add: order.antisym mult_right_isotone star_isotone spanning_tree_def)

text \<open>
We first show three verification conditions which are used in both correctness proofs.
\<close>

lemma prim_vc_1:
  assumes "prim_precondition g r"
    shows "prim_spanning_invariant bot r g r"
proof (unfold prim_spanning_invariant_def, intro conjI)
  show "prim_precondition g r"
    using assms by simp
next
  show "r\<^sup>T = r\<^sup>T * bot\<^sup>\<star>"
    by (simp add: star_absorb)
next
  let ?ss = "r * r\<^sup>T \<sqinter> g"
  show "spanning_tree bot ?ss r"
  proof (unfold spanning_tree_def, intro conjI)
    show "injective bot"
      by simp
  next
    show "acyclic bot"
      by simp
  next
    show "bot \<le> (component ?ss r)\<^sup>T * (component ?ss r) \<sqinter> --?ss"
      by simp
  next
    have "component ?ss r \<le> component (r * r\<^sup>T) r"
      by (simp add: mult_right_isotone star_isotone)
    also have "... \<le> r\<^sup>T * 1\<^sup>\<star>"
      using assms by (metis order.eq_iff p_antitone regular_one_closed star_sub_one prim_precondition_def)
    also have "... = r\<^sup>T * bot\<^sup>\<star>"
      by (simp add: star.circ_zero star_one)
    finally show "component ?ss r \<le> r\<^sup>T * bot\<^sup>\<star>"
      .
  next
    show "regular bot"
      by simp
  qed
qed

lemma prim_vc_2:
  assumes "prim_spanning_invariant t v g r"
      and "v * -v\<^sup>T \<sqinter> g \<noteq> bot"
    shows "prim_spanning_invariant (t \<squnion> minarc (v * -v\<^sup>T \<sqinter> g)) (v \<squnion> minarc (v * -v\<^sup>T \<sqinter> g)\<^sup>T * top) g r \<and> card { x . regular x \<and> x \<le> component g r \<and> x \<le> -(v \<squnion> minarc (v * -v\<^sup>T \<sqinter> g)\<^sup>T * top)\<^sup>T } < card { x . regular x \<and> x \<le> component g r \<and> x \<le> -v\<^sup>T }"
proof -
  let ?vcv = "v * -v\<^sup>T \<sqinter> g"
  let ?e = "minarc ?vcv"
  let ?t = "t \<squnion> ?e"
  let ?v = "v \<squnion> ?e\<^sup>T * top"
  let ?c = "component g r"
  let ?g = "--g"
  let ?n1 = "card { x . regular x \<and> x \<le> ?c \<and> x \<le> -v\<^sup>T }"
  let ?n2 = "card { x . regular x \<and> x \<le> ?c \<and> x \<le> -?v\<^sup>T }"
  have 1: "regular v \<and> regular (v * v\<^sup>T) \<and> regular (?v * ?v\<^sup>T) \<and> regular (top * ?e)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive regular_closed_top regular_closed_sup minarc_regular)
  hence 2: "t \<le> v * v\<^sup>T \<sqinter> ?g"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  hence 3: "t \<le> v * v\<^sup>T"
    by simp
  have 4: "t \<le> ?g"
    using 2 by simp
  have 5: "?e \<le> v * -v\<^sup>T \<sqinter> ?g"
    using 1 by (metis minarc_below pp_dist_inf regular_mult_closed regular_closed_p)
  hence 6: "?e \<le> v * -v\<^sup>T"
    by simp
  have 7: "vector v"
    using assms(1) prim_spanning_invariant_def prim_precondition_def by (simp add: covector_mult_closed vector_conv_covector)
  hence 8: "?e \<le> v"
    using 6 by (metis conv_complement inf.boundedE vector_complement_closed vector_covector)
  have 9: "?e * t = bot"
    using 3 6 7 et(1) by blast
  have 10: "?e * t\<^sup>T = bot"
    using 3 6 7 et(2) by simp
  have 11: "arc ?e"
    using assms(2) minarc_arc by simp
  have "r\<^sup>T \<le> r\<^sup>T * t\<^sup>\<star>"
    by (metis mult_right_isotone order_refl semiring.mult_not_zero star.circ_separate_mult_1 star_absorb)
  hence 12: "r\<^sup>T \<le> v\<^sup>T"
    using assms(1) by (simp add: prim_spanning_invariant_def)
  have 13: "vector r \<and> injective r \<and> v\<^sup>T = r\<^sup>T * t\<^sup>\<star>"
    using assms(1) prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def reachable_restrict by simp
  have "g = g\<^sup>T"
    using assms(1) prim_invariant_def prim_spanning_invariant_def prim_precondition_def by simp
  hence 14: "?g\<^sup>T = ?g"
    using conv_complement by simp
  show "prim_spanning_invariant ?t ?v g r \<and> ?n2 < ?n1"
  proof (rule conjI)
    show "prim_spanning_invariant ?t ?v g r"
    proof (unfold prim_spanning_invariant_def, intro conjI)
      show "prim_precondition g r"
        using assms(1) prim_spanning_invariant_def by simp
    next
      show "?v\<^sup>T = r\<^sup>T * ?t\<^sup>\<star>"
        using assms(1) 6 7 9 by (simp add: reachable_inv prim_spanning_invariant_def prim_precondition_def spanning_tree_def)
    next
      let ?G = "?v * ?v\<^sup>T \<sqinter> g"
      show "spanning_tree ?t ?G r"
      proof (unfold spanning_tree_def, intro conjI)
        show "injective ?t"
          using assms(1) 10 11 by (simp add: injective_inv prim_spanning_invariant_def spanning_tree_def)
      next
        show "acyclic ?t"
          using assms(1) 3 6 7 acyclic_inv prim_spanning_invariant_def spanning_tree_def by simp
      next
        show "?t \<le> (component ?G r)\<^sup>T * (component ?G r) \<sqinter> --?G"
          using 1 2 5 7 13 prim_subgraph_inv inf_pp_commute mst_subgraph_inv_2 by auto
      next
        show "component (?v * ?v\<^sup>T \<sqinter> g) r \<le> r\<^sup>T * ?t\<^sup>\<star>"
        proof -
          have 15: "r\<^sup>T * (v * v\<^sup>T \<sqinter> ?g)\<^sup>\<star> \<le> r\<^sup>T * t\<^sup>\<star>"
            using assms(1) 1 by (metis prim_spanning_invariant_def spanning_tree_def inf_pp_commute)
          have "component (?v * ?v\<^sup>T \<sqinter> g) r = r\<^sup>T * (?v * ?v\<^sup>T \<sqinter> ?g)\<^sup>\<star>"
            using 1 by simp
          also have "... \<le> r\<^sup>T * ?t\<^sup>\<star>"
            using 2 6 7 11 12 13 14 15 by (metis span_inv)
          finally show ?thesis
            .
        qed
      next
        show "regular ?t"
          using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def regular_closed_sup minarc_regular)
      qed
    qed
  next
    have 16: "top * ?e \<le> ?c"
    proof -
      have "top * ?e = top * ?e\<^sup>T * ?e"
        using 11 by (metis arc_top_edge mult_assoc)
      also have "... \<le> v\<^sup>T * ?e"
        using 7 8 by (metis conv_dist_comp conv_isotone mult_left_isotone symmetric_top_closed)
      also have "... \<le> v\<^sup>T * ?g"
        using 5 mult_right_isotone by auto
      also have "... = r\<^sup>T * t\<^sup>\<star> * ?g"
        using 13 by simp
      also have "... \<le> r\<^sup>T * ?g\<^sup>\<star> * ?g"
        using 4 by (simp add: mult_left_isotone mult_right_isotone star_isotone)
      also have "... \<le> ?c"
        by (simp add: comp_associative mult_right_isotone star.right_plus_below_circ)
      finally show ?thesis
        by simp
    qed
    have 17: "top * ?e \<le> -v\<^sup>T"
      using 6 7 by (simp add: schroeder_4_p vTeT)
    have 18: "\<not> top * ?e \<le> -(top * ?e)"
      by (metis assms(2) inf.orderE minarc_bot_iff conv_complement_sub_inf inf_p inf_top.left_neutral p_bot symmetric_top_closed vector_top_closed)
    have 19: "-?v\<^sup>T = -v\<^sup>T \<sqinter> -(top * ?e)"
      by (simp add: conv_dist_comp conv_dist_sup)
    hence 20: "\<not> top * ?e \<le> -?v\<^sup>T"
      using 18 by simp
    show "?n2 < ?n1"
      apply (rule psubset_card_mono)
      using finite_regular apply simp
      using 1 16 17 19 20 by auto
  qed
qed

lemma prim_vc_3:
  assumes "prim_spanning_invariant t v g r"
      and "v * -v\<^sup>T \<sqinter> g = bot"
    shows "spanning_tree t g r"
proof -
  let ?g = "--g"
  have 1: "regular v \<and> regular (v * v\<^sup>T)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  have 2: "v * -v\<^sup>T \<sqinter> ?g = bot"
    using assms(2) pp_inf_bot_iff pp_pp_inf_bot_iff by simp
  have 3: "v\<^sup>T = r\<^sup>T * t\<^sup>\<star> \<and> vector v"
    using assms(1) by (simp add: covector_mult_closed prim_invariant_def prim_spanning_invariant_def vector_conv_covector prim_precondition_def)
  have 4: "t \<le> v * v\<^sup>T \<sqinter> ?g"
    using assms(1) 1 by (metis prim_spanning_invariant_def inf_pp_commute spanning_tree_def inf.boundedE)
  have "r\<^sup>T * (v * v\<^sup>T \<sqinter> ?g)\<^sup>\<star> \<le> r\<^sup>T * t\<^sup>\<star>"
    using assms(1) 1 by (metis prim_spanning_invariant_def inf_pp_commute spanning_tree_def)
  hence 5: "component g r = v\<^sup>T"
    using 1 2 3 4 by (metis span_post)
  have "regular (v * v\<^sup>T)"
    using assms(1) by (metis prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  hence 6: "t \<le> v * v\<^sup>T \<sqinter> ?g"
    by (metis assms(1) prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  show "spanning_tree t g r"
    apply (unfold spanning_tree_def, intro conjI)
    using assms(1) prim_spanning_invariant_def spanning_tree_def apply simp
    using assms(1) prim_spanning_invariant_def spanning_tree_def apply simp
    using 5 6 apply simp
    using assms(1) 5 prim_spanning_invariant_def apply simp
    using assms(1) prim_spanning_invariant_def spanning_tree_def by simp
qed

text \<open>
The following result shows that Prim's algorithm terminates and constructs a spanning tree.
We cannot yet show that this is a minimum spanning tree.
\<close>

theorem prim_spanning:
  "VARS t v e
  [ prim_precondition g r ]
  t := bot;
  v := r;
  WHILE v * -v\<^sup>T \<sqinter> g \<noteq> bot
    INV { prim_spanning_invariant t v g r }
    VAR { card { x . regular x \<and> x \<le> component g r \<sqinter> -v\<^sup>T } }
     DO e := minarc (v * -v\<^sup>T \<sqinter> g);
        t := t \<squnion> e;
        v := v \<squnion> e\<^sup>T * top
     OD
  [ spanning_tree t g r ]"
  apply vcg_tc_simp
  apply (simp add: prim_vc_1)
  using prim_vc_2 apply blast
  using prim_vc_3 by auto

text \<open>
Because we have shown total correctness, we conclude that a spanning tree exists.
\<close>

lemma prim_exists_spanning:
  "prim_precondition g r \<Longrightarrow> \<exists>t . spanning_tree t g r"
  using tc_extract_function prim_spanning by blast

text \<open>
This implies that a minimum spanning tree exists, which is used in the subsequent correctness proof.
\<close>

text \<open>
Prim's minimum spanning tree algorithm terminates and is correct.
This is the same algorithm that is used in the previous correctness proof, with the same precondition and variant, but with a different invariant and postcondition.
\<close>

theorem prim:
  "VARS t v e
  [ prim_precondition g r \<and> (\<exists>w . minimum_spanning_tree w g r) ]
  t := bot;
  v := r;
  WHILE v * -v\<^sup>T \<sqinter> g \<noteq> bot
    INV { prim_invariant t v g r }
    VAR { card { x . regular x \<and> x \<le> component g r \<sqinter> -v\<^sup>T } }
     DO e := minarc (v * -v\<^sup>T \<sqinter> g);
        t := t \<squnion> e;
        v := v \<squnion> e\<^sup>T * top
     OD
  [ minimum_spanning_tree t g r ]"
proof vcg_tc_simp
  assume "prim_precondition g r \<and> (\<exists>w . minimum_spanning_tree w g r)"
  thus "prim_invariant bot r g r"
    using prim_invariant_def prim_vc_1 by simp
next
  fix t v
  let ?vcv = "v * -v\<^sup>T \<sqinter> g"
  let ?vv = "v * v\<^sup>T \<sqinter> g"
  let ?e = "minarc ?vcv"
  let ?t = "t \<squnion> ?e"
  let ?v = "v \<squnion> ?e\<^sup>T * top"
  let ?c = "component g r"
  let ?g = "--g"
  let ?n1 = "card { x . regular x \<and> x \<le> ?c \<and> x \<le> -v\<^sup>T }"
  let ?n2 = "card { x . regular x \<and> x \<le> ?c \<and> x \<le> -?v\<^sup>T }"
  assume 1: "prim_invariant t v g r \<and> ?vcv \<noteq> bot"
  hence 2: "regular v \<and> regular (v * v\<^sup>T)"
    by (metis (no_types, opaque_lifting) prim_invariant_def prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  have 3: "t \<le> v * v\<^sup>T \<sqinter> ?g"
    using 1 2 by (metis (no_types, opaque_lifting) prim_invariant_def prim_spanning_invariant_def spanning_tree_def inf_pp_commute inf.boundedE)
  hence 4: "t \<le> v * v\<^sup>T"
    by simp
  have 5: "t \<le> ?g"
    using 3 by simp
  have 6: "?e \<le> v * -v\<^sup>T \<sqinter> ?g"
    using 2 by (metis minarc_below pp_dist_inf regular_mult_closed regular_closed_p)
  hence 7: "?e \<le> v * -v\<^sup>T"
    by simp
  have 8: "vector v"
    using 1 prim_invariant_def prim_spanning_invariant_def prim_precondition_def by (simp add: covector_mult_closed vector_conv_covector)
  have 9: "arc ?e"
    using 1 minarc_arc by simp
  from 1 obtain w where 10: "minimum_spanning_tree w g r \<and> t \<le> w"
    by (metis prim_invariant_def)
  hence 11: "vector r \<and> injective r \<and> v\<^sup>T = r\<^sup>T * t\<^sup>\<star> \<and> forest w \<and> t \<le> w \<and> w \<le> ?c\<^sup>T * ?c \<sqinter> ?g \<and> r\<^sup>T * (?c\<^sup>T * ?c \<sqinter> ?g)\<^sup>\<star> \<le> r\<^sup>T * w\<^sup>\<star>"
    using 1 2 prim_invariant_def prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def reachable_restrict by simp
  hence 12: "w * v \<le> v"
    using predecessors_reachable reachable_restrict by auto
  have 13: "g = g\<^sup>T"
    using 1 prim_invariant_def prim_spanning_invariant_def prim_precondition_def by simp
  hence 14: "?g\<^sup>T = ?g"
    using conv_complement by simp
  show "prim_invariant ?t ?v g r \<and> ?n2 < ?n1"
  proof (unfold prim_invariant_def, intro conjI)
    show "prim_spanning_invariant ?t ?v g r"
      using 1 prim_invariant_def prim_vc_2 by blast
  next
    show "\<exists>w . minimum_spanning_tree w g r \<and> ?t \<le> w"
    proof
      let ?f = "w \<sqinter> v * -v\<^sup>T \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>"
      let ?p = "w \<sqinter> -v * -v\<^sup>T \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>"
      let ?fp = "w \<sqinter> -v\<^sup>T \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>"
      let ?w = "(w \<sqinter> -?fp) \<squnion> ?p\<^sup>T \<squnion> ?e"
      have 15: "regular ?f \<and> regular ?fp \<and> regular ?w"
        using 2 10 by (metis regular_conv_closed regular_closed_star regular_mult_closed regular_closed_top regular_closed_inf regular_closed_sup minarc_regular minimum_spanning_tree_def spanning_tree_def)
      show "minimum_spanning_tree ?w g r \<and> ?t \<le> ?w"
      proof (intro conjI)
        show "minimum_spanning_tree ?w g r"
        proof (unfold minimum_spanning_tree_def, intro conjI)
          show "spanning_tree ?w g r"
          proof (unfold spanning_tree_def, intro conjI)
            show "injective ?w"
              using 7 8 9 11 exchange_injective by blast
          next
            show "acyclic ?w"
              using 7 8 11 12 exchange_acyclic by blast
          next
            show "?w \<le> ?c\<^sup>T * ?c \<sqinter> --g"
            proof -
              have 16: "w \<sqinter> -?fp \<le> ?c\<^sup>T * ?c \<sqinter> --g"
                using 10 by (simp add: le_infI1 minimum_spanning_tree_def spanning_tree_def)
              have "?p\<^sup>T \<le> w\<^sup>T"
                by (simp add: conv_isotone inf.sup_monoid.add_assoc)
              also have "... \<le> (?c\<^sup>T * ?c \<sqinter> --g)\<^sup>T"
                using 11 conv_order by simp
              also have "... = ?c\<^sup>T * ?c \<sqinter> --g"
                using 2 14 conv_dist_comp conv_dist_inf by simp
              finally have 17: "?p\<^sup>T \<le> ?c\<^sup>T * ?c \<sqinter> --g"
                .
              have "?e \<le> ?c\<^sup>T * ?c \<sqinter> ?g"
                using 5 6 11 mst_subgraph_inv by auto
              thus ?thesis
                using 16 17 by simp
            qed
          next
            show "?c \<le> r\<^sup>T * ?w\<^sup>\<star>"
            proof -
              have "?c \<le> r\<^sup>T * w\<^sup>\<star>"
                using 10 minimum_spanning_tree_def spanning_tree_def by simp
              also have "... \<le> r\<^sup>T * ?w\<^sup>\<star>"
                using 4 7 8 10 11 12 15 by (metis mst_reachable_inv)
              finally show ?thesis
                .
            qed
          next
            show "regular ?w"
              using 15 by simp
          qed
        next
          have 18: "?f \<squnion> ?p = ?fp"
            using 2 8 epm_1 by fastforce
          have "arc (w \<sqinter> --v * -v\<^sup>T \<sqinter> top * ?e * w\<^sup>T\<^sup>\<star>)"
            using 5 6 8 9 11 12 reachable_restrict arc_edge by auto
          hence 19: "arc ?f"
            using 2 by simp
          hence "?f = bot \<longrightarrow> top = bot"
            by (metis mult_left_zero mult_right_zero)
          hence "?f \<noteq> bot"
            using 1 le_bot by auto
          hence "?f \<sqinter> v * -v\<^sup>T \<sqinter> ?g \<noteq> bot"
            using 2 11 by (simp add: inf.absorb1 le_infI1)
          hence "g \<sqinter> (?f \<sqinter> v * -v\<^sup>T) \<noteq> bot"
            using inf_commute pp_inf_bot_iff by simp
          hence 20: "?f \<sqinter> ?vcv \<noteq> bot"
            by (simp add: inf_assoc inf_commute)
          hence 21: "?f \<sqinter> g = ?f \<sqinter> ?vcv"
            using 2 by (simp add: inf_assoc inf_commute inf_left_commute)
          have 22: "?e \<sqinter> g = minarc ?vcv \<sqinter> ?vcv"
            using 7 by (simp add: inf.absorb2 inf.assoc inf.commute)
          hence 23: "sum (?e \<sqinter> g) \<le> sum (?f \<sqinter> g)"
            using 15 19 20 21 by (simp add: minarc_min)
          have "?e \<noteq> bot"
            using 20 comp_inf.semiring.mult_not_zero semiring.mult_not_zero by blast
          hence 24: "?e \<sqinter> g \<noteq> bot"
            using 22 minarc_meet_bot by auto
          have "sum (?w \<sqinter> g) = sum (w \<sqinter> -?fp \<sqinter> g) + sum (?p\<^sup>T \<sqinter> g) + sum (?e \<sqinter> g)"
            using 7 8 10 by (metis sum_disjoint_3 epm_8 epm_9 epm_10 minimum_spanning_tree_def spanning_tree_def)
          also have "... = sum (((w \<sqinter> -?fp) \<squnion> ?p\<^sup>T) \<sqinter> g) + sum (?e \<sqinter> g)"
            using 11 by (metis epm_8 sum_disjoint)
          also have "... \<le> sum (((w \<sqinter> -?fp) \<squnion> ?p\<^sup>T) \<sqinter> g) + sum (?f \<sqinter> g)"
            using 23 24 by (simp add: sum_plus_right_isotone)
          also have "... = sum (w \<sqinter> -?fp \<sqinter> g) + sum (?p\<^sup>T \<sqinter> g) + sum (?f \<sqinter> g)"
            using 11 by (metis epm_8 sum_disjoint)
          also have "... = sum (w \<sqinter> -?fp \<sqinter> g) + sum (?p \<sqinter> g) + sum (?f \<sqinter> g)"
            using 13 sum_symmetric by auto
          also have "... = sum (((w \<sqinter> -?fp) \<squnion> ?p \<squnion> ?f) \<sqinter> g)"
            using 2 8 by (metis sum_disjoint_3 epm_11 epm_12 epm_13)
          also have "... = sum (w \<sqinter> g)"
            using 2 8 15 18 epm_2 by force
          finally have "sum (?w \<sqinter> g) \<le> sum (w \<sqinter> g)"
            .
          thus "\<forall>u . spanning_tree u g r \<longrightarrow> sum (?w \<sqinter> g) \<le> sum (u \<sqinter> g)"
            using 10 order_lesseq_imp minimum_spanning_tree_def by auto
        qed
      next
        show "?t \<le> ?w"
          using 4 8 10 mst_extends_new_tree by simp
      qed
    qed
  next
    show "?n2 < ?n1"
      using 1 prim_invariant_def prim_vc_2 by auto
  qed
next
  fix t v
  let ?g = "--g"
  assume 25: "prim_invariant t v g r \<and> v * -v\<^sup>T \<sqinter> g = bot"
  hence 26: "regular v"
    by (metis prim_invariant_def prim_spanning_invariant_def spanning_tree_def prim_precondition_def regular_conv_closed regular_closed_star regular_mult_closed conv_involutive)
  from 25 obtain w where 27: "minimum_spanning_tree w g r \<and> t \<le> w"
    by (metis prim_invariant_def)
  have "spanning_tree t g r"
    using 25 prim_invariant_def prim_vc_3 by blast
  hence "component g r = v\<^sup>T"
    by (metis 25 prim_invariant_def span_tree_component prim_spanning_invariant_def spanning_tree_def)
  hence 28: "w \<le> v * v\<^sup>T"
    using 26 27 by (simp add: minimum_spanning_tree_def spanning_tree_def inf_pp_commute)
  have "vector r \<and> injective r \<and> forest w"
    using 25 27 by (simp add: prim_invariant_def prim_spanning_invariant_def prim_precondition_def minimum_spanning_tree_def spanning_tree_def)
  hence "w = t"
    using 25 27 28 prim_invariant_def prim_spanning_invariant_def mst_post by blast
  thus "minimum_spanning_tree t g r"
    using 27 by simp
qed

end

end


theory FormulaIfex
  imports BDT
begin

datatype (atoms: 'a) formula =
    Atom 'a
  | Bot                              ("\<bottom>")
  | Not "'a formula"                 ("\<^bold>\<not>")
  | And "'a formula" "'a formula"    (infix "\<^bold>\<and>" 68)
  | Or "'a formula" "'a formula"     (infix "\<^bold>\<or>" 68)
  | Imp "'a formula" "'a formula"    (infixr "\<^bold>\<rightarrow>" 68)

type_synonym 'a valuation = "'a \<Rightarrow> bool"
primrec formula_semantics :: "'a valuation \<Rightarrow> 'a formula \<Rightarrow> bool" (infix "\<Turnstile>" 51) where
"\<A> \<Turnstile> Atom k = \<A> k" |
"_ \<Turnstile> \<bottom> = False" |
"\<A> \<Turnstile> Not F = (\<not> \<A> \<Turnstile> F)" |
"\<A> \<Turnstile> And F G = (\<A> \<Turnstile> F \<and> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Or F G = (\<A> \<Turnstile> F \<or> \<A> \<Turnstile> G)" |
"\<A> \<Turnstile> Imp F G = (\<A> \<Turnstile> F \<longrightarrow> \<A> \<Turnstile> G)"

fun mk_ifex :: "('a :: linorder) formula \<Rightarrow> 'a ifex" where
"mk_ifex (Atom a) = IF a Trueif Falseif" |
"mk_ifex Bot = Falseif" |
"mk_ifex (Not f) = ifex_ite (mk_ifex f) Falseif Trueif" |
"mk_ifex (And f g) = ifex_ite (mk_ifex f) (mk_ifex g) Falseif" |
"mk_ifex (Or f g) = ifex_ite (mk_ifex f) Trueif (mk_ifex g)" |
"mk_ifex (Imp f g) = ifex_ite (mk_ifex f) (mk_ifex g) Trueif"

lemma ord: "ifex_ordered (mk_ifex f)"
  by(induction rule: mk_ifex.induct) (insert order_ifex_ite_invar; fastforce)+

lemma min: "ifex_minimal (mk_ifex f)"
  by(induction rule: mk_ifex.induct) (insert minimal_ifex_ite_invar; fastforce)+

theorem "assmt \<Turnstile> f \<longleftrightarrow> val_ifex (mk_ifex f) assmt"
  apply(induction f)
  apply(simp_all)[2]
     apply(subst mk_ifex.simps; subst val_ifex_ite_subst; simp_all add: min ord bf_ite_def val_ifex_ite_subst)+
  done

end


theory Group_Inverse_Example
  imports Main
begin

lemma "\<lbrakk> \<forall>x y z. f(x, f(y, z)) = f(f(x,y), z);
         \<forall>x. f(e, x) = x \<and> f(x,e) = x;
         \<forall>x. \<exists>y. f(y,x) = e \<rbrakk> \<Longrightarrow> \<forall>x y. f(x,y) = e \<longrightarrow> f(y,x) = e"
  by metis

(* https://isabelle.in.tum.de/dist/library/HOL/HOL/Groups.html *)
context
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
    and e :: 'a
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
    and left_neutral: "e \<otimes> x = x"
    and left_inv: "\<exists>z. z \<otimes> x = e"
begin

(* verbose *)
lemma
  assumes "x \<otimes> y = e"
  shows "y \<otimes> x = e"
proof -
  have A: "(x \<otimes> y) \<otimes> x = x"
  proof -
    have "(x \<otimes> y) \<otimes> x = x \<otimes> (y \<otimes> x)"
      using assoc by simp
    also have "\<dots> = e \<otimes> x"
      using assms calculation by simp
    also have "\<dots> = x"
      using left_neutral by simp
    finally show ?thesis .
  qed

  from left_inv obtain z where B: "z \<otimes> x = e" by auto

  have "z \<otimes> (x \<otimes> (y \<otimes> x)) = (z \<otimes> x) \<otimes> (y \<otimes> x)"
    using assoc by simp
  also have "\<dots> = e \<otimes> (y \<otimes> x)"
    using B by simp
  also have "\<dots> = y \<otimes> x"
    using left_neutral by simp
  finally show "\<dots> = e"
    using A assoc B by simp
qed

(* automatic *)
lemma
  assumes "x \<otimes> y = e"
  shows "y \<otimes> x = e"
  oops

end

end


(*  Title:      HOL/Library/Log_Nat.thy
    Author:     Johannes Hölzl, Fabian Immler
    Copyright   2012  TU München
*)

section \<open>Logarithm of Natural Numbers\<close>

theory Log_Nat
imports Complex_MainRLT
begin

subsection \<open>Preliminaries\<close>

lemma divide_nat_diff_div_nat_less_one:
  "real x / real b - real (x div b) < 1" for x b :: nat
proof (cases "b = 0")
  case True
  then show ?thesis
    by simp
next
  case False
  then have "real (x div b) + real (x mod b) / real b - real (x div b) < 1"
    by (simp add: field_simps)
  then show ?thesis
    by (simp add: real_of_nat_div_aux [symmetric])
qed

subsection \<open>Floorlog\<close>

definition floorlog :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "floorlog b a = (if a > 0 \<and> b > 1 then nat \<lfloor>log b a\<rfloor> + 1 else 0)"

lemma floorlog_mono: "x \<le> y \<Longrightarrow> floorlog b x \<le> floorlog b y"
  by (auto simp: floorlog_def floor_mono nat_mono)

lemma floorlog_bounds:
  "b ^ (floorlog b x - 1) \<le> x \<and> x < b ^ (floorlog b x)" if "x > 0" "b > 1"
proof
  show "b ^ (floorlog b x - 1) \<le> x"
  proof -
    have "b ^ nat \<lfloor>log b x\<rfloor> = b powr \<lfloor>log b x\<rfloor>"
      using powr_realpow[symmetric, of b "nat \<lfloor>log b x\<rfloor>"] \<open>x > 0\<close> \<open>b > 1\<close>
      by simp
    also have "\<dots> \<le> b powr log b x" using \<open>b > 1\<close> by simp
    also have "\<dots> = real_of_int x" using \<open>0 < x\<close> \<open>b > 1\<close> by simp
    finally have "b ^ nat \<lfloor>log b x\<rfloor> \<le> real_of_int x" by simp
    then show ?thesis
      using \<open>0 < x\<close> \<open>b > 1\<close> of_nat_le_iff
      by (fastforce simp add: floorlog_def)
  qed
  show "x < b ^ (floorlog b x)"
  proof -
    have "x \<le> b powr (log b x)" using \<open>x > 0\<close> \<open>b > 1\<close> by simp
    also have "\<dots> < b powr (\<lfloor>log b x\<rfloor> + 1)"
      using that by (intro powr_less_mono) auto
    also have "\<dots> = b ^ nat (\<lfloor>log b (real_of_int x)\<rfloor> + 1)"
      using that by (simp flip: powr_realpow)
    finally
    have "x < b ^ nat (\<lfloor>log b (int x)\<rfloor> + 1)"
      by (rule of_nat_less_imp_less)
    then show ?thesis
      using \<open>x > 0\<close> \<open>b > 1\<close> by (simp add: floorlog_def nat_add_distrib)
  qed
qed

lemma floorlog_power [simp]:
  "floorlog b (a * b ^ c) = floorlog b a + c" if "a > 0" "b > 1"
proof -
  have "\<lfloor>log b a + real c\<rfloor> = \<lfloor>log b a\<rfloor> + c" by arith
  then show ?thesis using that
    by (auto simp: floorlog_def log_mult powr_realpow[symmetric] nat_add_distrib)
qed

lemma floor_log_add_eqI:
  "\<lfloor>log b (a + r)\<rfloor> = \<lfloor>log b a\<rfloor>" if "b > 1" "a \<ge> 1" "0 \<le> r" "r < 1"
    for a b :: nat and r :: real
proof (rule floor_eq2)
  have "log b a \<le> log b (a + r)" using that by force
  then show "\<lfloor>log b a\<rfloor> \<le> log b (a + r)" by arith
next
  define l::int where "l = int b ^ (nat \<lfloor>log b a\<rfloor> + 1)"
  have l_def_real: "l = b powr (\<lfloor>log b a\<rfloor> + 1)"
    using that by (simp add: l_def powr_add powr_real_of_int)
  have "a < l"
  proof -
    have "a = b powr (log b a)" using that by simp
    also have "\<dots> < b powr floor ((log b a) + 1)"
      using that(1) by auto
    also have "\<dots> = l"
      using that by (simp add: l_def powr_real_of_int powr_add)
    finally show ?thesis by simp
  qed
  then have "a + r < l" using that by simp
  then have "log b (a + r) < log b l" using that by simp
  also have "\<dots> = real_of_int \<lfloor>log b a\<rfloor> + 1"
    using that by (simp add: l_def_real)
  finally show "log b (a + r) < real_of_int \<lfloor>log b a\<rfloor> + 1" .
qed

lemma floor_log_div:
  "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x div b)\<rfloor> + 1" if "b > 1" "x > 0" "x div b > 0"
    for b x :: nat
proof-
  have "\<lfloor>log b x\<rfloor> = \<lfloor>log b (x / b * b)\<rfloor>" using that by simp
  also have "\<dots> = \<lfloor>log b (x / b) + log b b\<rfloor>"
    using that by (subst log_mult) auto
  also have "\<dots> = \<lfloor>log b (x / b)\<rfloor> + 1" using that by simp
  also have "\<lfloor>log b (x / b)\<rfloor> = \<lfloor>log b (x div b + (x / b - x div b))\<rfloor>" by simp
  also have "\<dots> = \<lfloor>log b (x div b)\<rfloor>"
    using that real_of_nat_div4 divide_nat_diff_div_nat_less_one
    by (intro floor_log_add_eqI) auto
  finally show ?thesis .
qed

lemma compute_floorlog [code]:
  "floorlog b x = (if x > 0 \<and> b > 1 then floorlog b (x div b) + 1 else 0)"
  by (auto simp: floorlog_def floor_log_div[of b x] div_eq_0_iff nat_add_distrib
    intro!: floor_eq2)

lemma floor_log_eq_if:
  "\<lfloor>log b x\<rfloor> = \<lfloor>log b y\<rfloor>" if "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
    for b x y :: nat
proof -
  have "y > 0" using that by (auto intro: ccontr)
  thus ?thesis using that by (simp add: floor_log_div)
qed

lemma floorlog_eq_if:
  "floorlog b x = floorlog b y" if "x div b = y div b" "b > 1" "x > 0" "x div b \<ge> 1"
    for b x y :: nat
proof -
  have "y > 0" using that by (auto intro: ccontr)
  then show ?thesis using that
    by (auto simp add: floorlog_def eq_nat_nat_iff intro: floor_log_eq_if)
qed

lemma floorlog_leD:
  "floorlog b x \<le> w \<Longrightarrow> b > 1 \<Longrightarrow> x < b ^ w"
  by (metis floorlog_bounds leD linorder_neqE_nat order.strict_trans power_strict_increasing_iff
      zero_less_one zero_less_power)

lemma floorlog_leI:
  "x < b ^ w \<Longrightarrow> 0 \<le> w \<Longrightarrow> b > 1 \<Longrightarrow> floorlog b x \<le> w"
  by (drule less_imp_of_nat_less[where 'a=real])
    (auto simp: floorlog_def Suc_le_eq nat_less_iff floor_less_iff log_of_power_less)

lemma floorlog_eq_zero_iff:
  "floorlog b x = 0 \<longleftrightarrow> b \<le> 1 \<or> x \<le> 0"
  by (auto simp: floorlog_def)

lemma floorlog_le_iff:
  "floorlog b x \<le> w \<longleftrightarrow> b \<le> 1 \<or> b > 1 \<and> 0 \<le> w \<and> x < b ^ w"
  using floorlog_leD[of b x w] floorlog_leI[of x b w]
  by (auto simp: floorlog_eq_zero_iff[THEN iffD2])

lemma floorlog_ge_SucI:
  "Suc w \<le> floorlog b x" if "b ^ w \<le> x" "b > 1"
  using that le_log_of_power[of b w x] power_not_zero
  by (force simp: floorlog_def Suc_le_eq powr_realpow not_less Suc_nat_eq_nat_zadd1
      zless_nat_eq_int_zless int_add_floor less_floor_iff
      simp del: floor_add2)

lemma floorlog_geI:
  "w \<le> floorlog b x" if "b ^ (w - 1) \<le> x" "b > 1"
  using floorlog_ge_SucI[of b "w - 1" x] that
  by auto

lemma floorlog_geD:
  "b ^ (w - 1) \<le> x" if "w \<le> floorlog b x" "w > 0"
proof -
  have "b > 1" "0 < x"
    using that by (auto simp: floorlog_def split: if_splits)
  have "b ^ (w - 1) \<le> x" if "b ^ w \<le> x"
  proof -
    have "b ^ (w - 1) \<le> b ^ w"
      using \<open>b > 1\<close>
      by (auto intro!: power_increasing)
    also note that
    finally show ?thesis .
  qed
  moreover have "b ^ nat \<lfloor>log (real b) (real x)\<rfloor> \<le> x" (is "?l \<le> _")
  proof -
    have "0 \<le> log (real b) (real x)"
      using \<open>b > 1\<close> \<open>0 < x\<close>
      by (auto simp: )
    then have "?l \<le> b powr log (real b) (real x)"
      using \<open>b > 1\<close>
      by (auto simp flip: powr_realpow intro!: powr_mono of_nat_floor)
    also have "\<dots> = x" using \<open>b > 1\<close> \<open>0 < x\<close>
      by auto
    finally show ?thesis
      unfolding of_nat_le_iff .
  qed
  ultimately show ?thesis
    using that
    by (auto simp: floorlog_def le_nat_iff le_floor_iff le_log_iff powr_realpow
        split: if_splits elim!: le_SucE)
qed

subsection \<open>Bitlen\<close>

definition bitlen :: "int \<Rightarrow> int"
  where "bitlen a = floorlog 2 (nat a)"

lemma bitlen_alt_def:
  "bitlen a = (if a > 0 then \<lfloor>log 2 a\<rfloor> + 1 else 0)"
  by (simp add: bitlen_def floorlog_def)

lemma bitlen_zero [simp]:
  "bitlen 0 = 0"
  by (auto simp: bitlen_def floorlog_def)

lemma bitlen_nonneg:
  "0 \<le> bitlen x"
  by (simp add: bitlen_def)

lemma bitlen_bounds:
  "2 ^ nat (bitlen x - 1) \<le> x \<and> x < 2 ^ nat (bitlen x)" if "x > 0"
proof -
  from that have "bitlen x \<ge> 1" by (auto simp: bitlen_alt_def)
  with that floorlog_bounds[of "nat x" 2] show ?thesis
    by (auto simp add: bitlen_def le_nat_iff nat_less_iff nat_diff_distrib)
qed

lemma bitlen_pow2 [simp]:
  "bitlen (b * 2 ^ c) = bitlen b + c" if "b > 0"
  using that by (simp add: bitlen_def nat_mult_distrib nat_power_eq)

lemma compute_bitlen [code]:
  "bitlen x = (if x > 0 then bitlen (x div 2) + 1 else 0)"
  by (simp add: bitlen_def nat_div_distrib compute_floorlog)

lemma bitlen_eq_zero_iff:
  "bitlen x = 0 \<longleftrightarrow> x \<le> 0"
  by (auto simp add: bitlen_alt_def)
   (metis compute_bitlen add.commute bitlen_alt_def bitlen_nonneg less_add_same_cancel2
      not_less zero_less_one)

lemma bitlen_div:
  "1 \<le> real_of_int m / 2^nat (bitlen m - 1)"
    and "real_of_int m / 2^nat (bitlen m - 1) < 2" if "0 < m"
proof -
  let ?B = "2^nat (bitlen m - 1)"

  have "?B \<le> m" using bitlen_bounds[OF \<open>0 <m\<close>] ..
  then have "1 * ?B \<le> real_of_int m"
    unfolding of_int_le_iff[symmetric] by auto
  then show "1 \<le> real_of_int m / ?B" by auto

  from that have "0 \<le> bitlen m - 1" by (auto simp: bitlen_alt_def)

  have "m < 2^nat(bitlen m)" using bitlen_bounds[OF that] ..
  also from that have "\<dots> = 2^nat(bitlen m - 1 + 1)"
    by (auto simp: bitlen_def)
  also have "\<dots> = ?B * 2"
    unfolding nat_add_distrib[OF \<open>0 \<le> bitlen m - 1\<close> zero_le_one] by auto
  finally have "real_of_int m < 2 * ?B"
    by (metis (full_types) mult.commute power.simps(2) of_int_less_numeral_power_cancel_iff)
  then have "real_of_int m / ?B < 2 * ?B / ?B"
    by (rule divide_strict_right_mono) auto
  then show "real_of_int m / ?B < 2" by auto
qed

lemma bitlen_le_iff_floorlog:
  "bitlen x \<le> w \<longleftrightarrow> w \<ge> 0 \<and> floorlog 2 (nat x) \<le> nat w"
  by (auto simp: bitlen_def)

lemma bitlen_le_iff_power:
  "bitlen x \<le> w \<longleftrightarrow> w \<ge> 0 \<and> x < 2 ^ nat w"
  by (auto simp: bitlen_le_iff_floorlog floorlog_le_iff)

lemma less_power_nat_iff_bitlen:
  "x < 2 ^ w \<longleftrightarrow> bitlen (int x) \<le> w"
  using bitlen_le_iff_power[of x w]
  by auto

lemma bitlen_ge_iff_power:
  "w \<le> bitlen x \<longleftrightarrow> w \<le> 0 \<or> 2 ^ (nat w - 1) \<le> x"
  unfolding bitlen_def
  by (auto simp flip: nat_le_iff intro: floorlog_geI dest: floorlog_geD)

lemma bitlen_twopow_add_eq:
  "bitlen (2 ^ w + b) = w + 1" if "0 \<le> b" "b < 2 ^ w"
  by (auto simp: that nat_add_distrib bitlen_le_iff_power bitlen_ge_iff_power intro!: antisym)

end


(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* General Algorithms for Iterators over Finite Sets *}
theory SetIteratorGA
imports Main "SetIteratorOperations"
begin

subsection {* Quantification *}

definition iterate_ball where
    "iterate_ball (it::('x,bool) set_iterator) P = it id (\<lambda>x \<sigma>. P x) True"

lemma iterate_ball_correct :
assumes it: "set_iterator it S0"
shows "iterate_ball it P = (\<forall>x\<in>S0. P x)"
unfolding iterate_ball_def
apply (rule set_iterator_rule_P [OF it,
            where I = "\<lambda>S \<sigma>. \<sigma> = (\<forall>x\<in>S0-S. P x)"])
apply auto
done

definition iterate_bex where
    "iterate_bex (it::('x,bool) set_iterator) P = it (\<lambda>\<sigma>. \<not>\<sigma>) (\<lambda>x \<sigma>. P x) False"

lemma iterate_bex_correct :
assumes it: "set_iterator it S0"
shows "iterate_bex it P = (\<exists>x\<in>S0. P x)"
unfolding iterate_bex_def
apply (rule set_iterator_rule_P [OF it, where I = "\<lambda>S \<sigma>. \<sigma> = (\<exists>x\<in>S0-S. P x)"])
apply auto
done

subsection {* Iterator to List *}

definition iterate_to_list where
    "iterate_to_list (it::('x,'x list) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. x # \<sigma>) []"

lemma iterate_to_list_foldli [simp] :
  "iterate_to_list (foldli xs) = rev xs"
unfolding iterate_to_list_def
by (induct xs rule: rev_induct, simp_all add: foldli_snoc)

lemma iterate_to_list_genord_correct :
assumes it: "set_iterator_genord it S0 R"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted_by_rel R (rev (iterate_to_list it))"
using it unfolding set_iterator_genord_foldli_conv by auto

lemma iterate_to_list_correct :
assumes it: "set_iterator it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it)"
using iterate_to_list_genord_correct [OF it[unfolded set_iterator_def]]
by simp

lemma (in linorder) iterate_to_list_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (rev (iterate_to_list it))"
using it_OK unfolding set_iterator_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_rev_linord_correct :
fixes S0 :: "'a set"
assumes it_OK: "set_iterator_rev_linord it S0"
shows "set (iterate_to_list it) = S0 \<and> distinct (iterate_to_list it) \<and>
       sorted (iterate_to_list it)"
using it_OK unfolding set_iterator_rev_linord_foldli_conv by auto

lemma (in linorder) iterate_to_list_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (rev (iterate_to_list it)))"
using it_OK unfolding map_iterator_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

lemma (in linorder) iterate_to_list_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "map_of (iterate_to_list it) = m \<and> distinct (map fst (iterate_to_list it)) \<and>
       sorted (map fst (iterate_to_list it))"
using it_OK unfolding map_iterator_rev_linord_foldli_conv
by clarify (simp add: rev_map[symmetric])

subsection {* Size *}

lemma set_iterator_finite :
assumes it: "set_iterator it S0"
shows "finite S0"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]] .

lemma map_iterator_finite :
assumes it: "map_iterator it m"
shows "finite (dom m)"
using set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
by (simp add: finite_map_to_set)

definition iterate_size where
    "iterate_size (it::('x,nat) set_iterator) = it (\<lambda>_. True) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_size it = card S0 \<and> finite S0"
unfolding iterate_size_def
apply (rule_tac set_iterator_rule_insert_P [OF it,
    where I = "\<lambda>S \<sigma>. \<sigma> = card S \<and> finite S"])
apply auto
done

definition iterate_size_abort where
  "iterate_size_abort (it::('x,nat) set_iterator) n = it (\<lambda>\<sigma>. \<sigma> < n) (\<lambda>x \<sigma>. Suc \<sigma>) 0"

lemma iterate_size_abort_correct :
assumes it: "set_iterator it S0"
shows "iterate_size_abort it n = (min n (card S0)) \<and> finite S0"
unfolding iterate_size_abort_def
proof (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> = (min n (card S)) \<and> finite S"])
  case (goal4 \<sigma> S)
  assume "S \<subseteq> S0" "S \<noteq> S0" "\<not> \<sigma> < n" "\<sigma> = min n (card S) \<and> finite S"

  from `\<sigma> = min n (card S) \<and> finite S` `\<not> \<sigma> < n`
  have "\<sigma> = n" "n \<le> card S"
    by (auto simp add: min_less_iff_disj)

  note fin_S0 = set_iterator_genord.finite_S0 [OF it[unfolded set_iterator_def]]
  from card_mono [OF fin_S0 `S \<subseteq> S0`] have "card S \<le> card S0" .

  with `\<sigma> = n` `n \<le> card S` fin_S0
  show "\<sigma> = min n (card S0) \<and> finite S0" by simp
qed simp_all

subsection {* Emptyness Check *}

definition iterate_is_empty_by_size where
    "iterate_is_empty_by_size it = (iterate_size_abort it 1 = 0)"

lemma iterate_is_empty_by_size_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty_by_size it = (S0 = {})"
using iterate_size_abort_correct[OF it, of 1]
unfolding iterate_is_empty_by_size_def
by (cases "card S0") auto

definition iterate_is_empty where
    "iterate_is_empty (it::('x,bool) set_iterator) = (it (\<lambda>b. b) (\<lambda>_ _. False) True)"

lemma iterate_is_empty_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_empty it = (S0 = {})"
unfolding iterate_is_empty_def
apply (rule set_iterator_rule_insert_P [OF it,
   where I = "\<lambda>S \<sigma>. \<sigma> \<longleftrightarrow> S = {}"])
apply auto
done

subsection {* Check for singleton Sets *}

definition iterate_is_sng where
    "iterate_is_sng it = (iterate_size_abort it 2 = 1)"

lemma iterate_is_sng_correct :
assumes it: "set_iterator it S0"
shows "iterate_is_sng it = (card S0 = 1)"
using iterate_size_abort_correct[OF it, of 2]
unfolding iterate_is_sng_def
apply (cases "card S0", simp, rename_tac n')
apply (case_tac n')
apply auto
done

subsection {* Selection *}

definition iterate_sel where
    "iterate_sel (it::('x,'y option) set_iterator) f = it (\<lambda>\<sigma>. \<sigma> = None) (\<lambda>x \<sigma>. f x) None"

lemma iterate_sel_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
      "iterate_sel it f = Some y \<Longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))"
proof -
  show "iterate_sel it f = None \<longleftrightarrow> (\<forall>x\<in>S0. (f x = None))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. (f x = None))"])
    apply auto
  done
next
  have "iterate_sel it f = Some y \<longrightarrow> (\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y'. f x' = Some y' \<longrightarrow> R x x'))"
    unfolding iterate_sel_def
    apply (rule_tac set_iterator_genord.iteratei_rule_insert_P [OF it_OK,
       where I = "\<lambda>S \<sigma>. (\<forall>y. \<sigma> = Some y \<longrightarrow> (\<exists>x \<in> S. f x = Some y \<and> (\<forall>x' \<in> S-{x}.\<forall>y'. f x' = Some y' \<longrightarrow> R x x'))) \<and>
                        ((\<sigma> = None) \<longleftrightarrow> (\<forall>x\<in>S. f x = None))"])
    apply simp
    apply (auto simp add: Bex_def subset_iff Ball_def)
    apply metis
  done
  moreover assume "iterate_sel it f = Some y"
  finally show "(\<exists>x \<in> S0. f x = Some y \<and> (\<forall>x' \<in> S0-{x}. \<forall>y. f x' = Some y' \<longrightarrow> R x x'))" by blast
qed

definition iterate_sel_no_map where
    "iterate_sel_no_map it P = iterate_sel it (\<lambda>x. if P x then Some x else None)"
lemmas iterate_sel_no_map_alt_def = iterate_sel_no_map_def[unfolded iterate_sel_def, code]

lemma iterate_sel_no_map_genord_correct :
assumes it_OK: "set_iterator_genord it S0 R"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x' \<in> S0-{x}. P x' \<longrightarrow> R x x'))"
unfolding iterate_sel_no_map_def
using iterate_sel_genord_correct[OF it_OK, of "\<lambda>x. if P x then Some x else None"]
apply (simp_all add: Bex_def)
apply (metis option.inject option.simps(2))
done

lemma iterate_sel_no_map_correct :
assumes it_OK: "set_iterator it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> x \<in> S0 \<and> P x"
    by simp_all
qed

lemma (in linorder) iterate_sel_no_map_linord_correct :
assumes it_OK: "set_iterator_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x \<le> x'))"
    by auto
qed

lemma (in linorder) iterate_sel_no_map_rev_linord_correct :
assumes it_OK: "set_iterator_rev_linord it S0"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
      "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>x\<in>S0. \<not>(P x))"
       "iterate_sel_no_map it P = Some x \<Longrightarrow> (x \<in> S0 \<and> P x \<and> (\<forall>x'\<in>S0. P x' \<longrightarrow> x' \<le> x))"
    by auto
qed

lemma iterate_sel_no_map_map_correct :
assumes it_OK: "map_iterator it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v))"
    by (auto simp add: map_to_set_def)
qed

lemma (in linorder) iterate_sel_no_map_map_linord_correct :
assumes it_OK: "map_iterator_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k \<le> k'))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

lemma (in linorder) iterate_sel_no_map_map_rev_linord_correct :
assumes it_OK: "map_iterator_rev_linord it m"
shows "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
      "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
proof -
  note iterate_sel_no_map_genord_correct [OF it_OK[unfolded set_iterator_map_rev_linord_def], of P]
  thus "iterate_sel_no_map it P = None \<longleftrightarrow> (\<forall>k v. m k = Some v \<longrightarrow> \<not>(P (k, v)))"
       "iterate_sel_no_map it P = Some (k, v) \<Longrightarrow> (m k = Some v \<and> P (k, v) \<and> (\<forall>k' v' . m k' = Some v' \<and>
           P (k', v') \<longrightarrow> k' \<le> k))"
    apply (auto simp add: map_to_set_def Ball_def)
  done
qed

subsection {* Creating ordered iterators *}

text {* One can transform an iterator into an ordered one by converting it to list,
        sorting this list and then converting back to an iterator. In general, this brute-force
        method is inefficient, though. *}

definition iterator_to_ordered_iterator where
  "iterator_to_ordered_iterator sort_fun it =
   foldli (sort_fun (iterate_to_list it))"

lemma iterator_to_ordered_iterator_correct :
assumes sort_fun_OK: "\<And>l. sorted_by_rel R (sort_fun l) \<and> multiset_of (sort_fun l) = multiset_of l"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator sort_fun it) S0 R"
proof -
  def l \<equiv> "iterate_to_list it"
  have l_props: "set l = S0" "distinct l"
    using iterate_to_list_correct [OF it_OK, folded l_def] by simp_all

  with sort_fun_OK[of l] have sort_l_props:
    "sorted_by_rel R (sort_fun l)"
    "set (sort_fun l) = S0" "distinct (sort_fun l)"
    apply (simp_all)
    apply (metis set_of_multiset_of)
    apply (metis distinct_count_atmost_1 set_of_multiset_of)
  done

  show ?thesis
    apply (rule set_iterator_genord_I[of "sort_fun l"])
    apply (simp_all add: sort_l_props iterator_to_ordered_iterator_def l_def[symmetric])
  done
qed

definition iterator_to_ordered_iterator_quicksort where
  "iterator_to_ordered_iterator_quicksort R it =
   iterator_to_ordered_iterator (quicksort_by_rel R []) it"

lemmas iterator_to_ordered_iterator_quicksort_code[code] =
  iterator_to_ordered_iterator_quicksort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_quicksort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_quicksort R it) S0 R"
unfolding iterator_to_ordered_iterator_quicksort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_by_rel_quicksort_by_rel[OF lin trans_R])
done

definition iterator_to_ordered_iterator_mergesort where
  "iterator_to_ordered_iterator_mergesort R it =
   iterator_to_ordered_iterator (mergesort_by_rel R) it"

lemmas iterator_to_ordered_iterator_mergesort_code[code] =
  iterator_to_ordered_iterator_mergesort_def[unfolded iterator_to_ordered_iterator_def]

lemma iterator_to_ordered_iterator_mergesort_correct :
assumes lin : "\<And>x y. (R x y) \<or> (R y x)"
    and trans_R: "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
    and it_OK: "set_iterator it S0"
shows "set_iterator_genord (iterator_to_ordered_iterator_mergesort R it) S0 R"
unfolding iterator_to_ordered_iterator_mergesort_def
apply (rule iterator_to_ordered_iterator_correct [OF _ it_OK])
apply (simp_all add: sorted_by_rel_mergesort_by_rel[OF lin trans_R])
done

end


(*  Title:      HOL/ex/Cubic_Quartic.thy
    Author:     Amine Chaieb
*)

section \<open>The Cubic and Quartic Root Formulas\<close>

theory Cubic_Quartic
imports Complex_Main
begin

section \<open>The Cubic Formula\<close>

definition "ccbrt z = (SOME (w::complex). w^3 = z)"

lemma ccbrt: "(ccbrt z) ^ 3 = z"
proof -
  from rcis_Ex obtain r a where ra: "z = rcis r a"
    by blast
  let ?r' = "if r < 0 then - root 3 (-r) else root 3 r"
  let ?a' = "a/3"
  have "rcis ?r' ?a' ^ 3 = rcis r a"
    by (cases "r < 0") (simp_all add: DeMoivre2)
  then have *: "\<exists>w. w^3 = z"
    unfolding ra by blast
  from someI_ex [OF *] show ?thesis
    unfolding ccbrt_def by blast
qed

text \<open>The reduction to a simpler form:\<close>

lemma cubic_reduction:
  fixes a :: complex
  assumes
    "a \<noteq> 0 \<and> x = y - b / (3 * a) \<and>  p = (3* a * c - b^2) / (9 * a^2) \<and>
      q = (9 * a * b * c - 2 * b^3 - 27 * a^2 * d) / (54 * a^3)"
  shows "a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow> y^3 + 3 * p * y - 2 * q = 0"
proof -
  from assms have "3 * a \<noteq> 0" "9 * a^2 \<noteq> 0" "54 * a^3 \<noteq> 0" by auto
  then have *:
      "x = y - b / (3 * a) \<longleftrightarrow> (3*a) * x = (3*a) * y - b"
      "p = (3* a * c - b^2) / (9 * a^2) \<longleftrightarrow> (9 * a^2) * p = (3* a * c - b^2)"
      "q = (9 * a * b * c - 2 * b^3 - 27 * a^2 * d) / (54 * a^3) \<longleftrightarrow>
        (54 * a^3) * q = (9 * a * b * c - 2 * b^3 - 27 * a^2 * d)"
    by (simp_all add: field_simps)
  from assms [unfolded *] show ?thesis
    by algebra
qed

text \<open>The solutions of the special form:\<close>

lemma cubic_basic:
  fixes s :: complex
  assumes
    "s^2 = q^2 + p^3 \<and>
      s1^3 = (if p = 0 then 2 * q else q + s) \<and>
      s2 = -s1 * (1 + i * t) / 2 \<and>
      s3 = -s1 * (1 - i * t) / 2 \<and>
      i^2 + 1 = 0 \<and>
      t^2 = 3"
  shows
    "if p = 0
     then y^3 + 3 * p * y - 2 * q = 0 \<longleftrightarrow> y = s1 \<or> y = s2 \<or> y = s3
     else s1 \<noteq> 0 \<and>
      (y^3 + 3 * p * y - 2 * q = 0 \<longleftrightarrow> (y = s1 - p / s1 \<or> y = s2 - p / s2 \<or> y = s3 - p / s3))"
proof (cases "p = 0")
  case True
  with assms show ?thesis
    by (simp add: field_simps) algebra
next
  case False
  with assms have *: "s1 \<noteq> 0" by (simp add: field_simps) algebra
  with assms False have "s2 \<noteq> 0" "s3 \<noteq> 0"
    by (simp_all add: field_simps) algebra+
  with * have **:
      "y = s1 - p / s1 \<longleftrightarrow> s1 * y = s1^2 - p"
      "y = s2 - p / s2 \<longleftrightarrow> s2 * y = s2^2 - p"
      "y = s3 - p / s3 \<longleftrightarrow> s3 * y = s3^2 - p"
    by (simp_all add: field_simps power2_eq_square)
  from assms False show ?thesis
    unfolding ** by (simp add: field_simps) algebra
qed

text \<open>Explicit formula for the roots:\<close>

lemma cubic:
  assumes a0: "a \<noteq> 0"
  shows
    "let
      p = (3 * a * c - b^2) / (9 * a^2);
      q = (9 * a * b * c - 2 * b^3 - 27 * a^2 * d) / (54 * a^3);
      s = csqrt(q^2 + p^3);
      s1 = (if p = 0 then ccbrt(2 * q) else ccbrt(q + s));
      s2 = -s1 * (1 + \<i> * csqrt 3) / 2;
      s3 = -s1 * (1 - \<i> * csqrt 3) / 2
     in
      if p = 0 then
        a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow>
          x = s1 - b / (3 * a) \<or>
          x = s2 - b / (3 * a) \<or>
          x = s3 - b / (3 * a)
      else
        s1 \<noteq> 0 \<and>
          (a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow>
            x = s1 - p / s1 - b / (3 * a) \<or>
            x = s2 - p / s2 - b / (3 * a) \<or>
            x = s3 - p / s3 - b / (3 * a))"
proof -
  let ?p = "(3 * a * c - b^2) / (9 * a^2)"
  let ?q = "(9 * a * b * c - 2 * b^3 - 27 * a^2 * d) / (54 * a^3)"
  let ?s = "csqrt (?q^2 + ?p^3)"
  let ?s1 = "if ?p = 0 then ccbrt(2 * ?q) else ccbrt(?q + ?s)"
  let ?s2 = "- ?s1 * (1 + \<i> * csqrt 3) / 2"
  let ?s3 = "- ?s1 * (1 - \<i> * csqrt 3) / 2"
  let ?y = "x + b / (3 * a)"
  from a0 have zero: "9 * a^2 \<noteq> 0" "a^3 * 54 \<noteq> 0" "(a * 3) \<noteq> 0"
    by auto
  have eq: "a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow> ?y^3 + 3 * ?p * ?y - 2 * ?q = 0"
    by (rule cubic_reduction) (auto simp add: field_simps zero a0)
  have "csqrt 3^2 = 3" by (rule power2_csqrt)
  then have th0:
    "?s^2 = ?q^2 + ?p ^ 3 \<and> ?s1^ 3 = (if ?p = 0 then 2 * ?q else ?q + ?s) \<and>
      ?s2 = - ?s1 * (1 + \<i> * csqrt 3) / 2 \<and>
      ?s3 = - ?s1 * (1 - \<i> * csqrt 3) / 2 \<and>
      \<i>^2 + 1 = 0 \<and> csqrt 3^2 = 3"
    using zero by (simp add: field_simps ccbrt)
  from cubic_basic[OF th0, of ?y]
  show ?thesis
    apply (simp only: Let_def eq)
    using zero apply (simp add: field_simps ccbrt)
    using zero
    apply (cases "a * (c * 3) = b^2")
    apply (simp_all add: field_simps)
    done
qed

section \<open>The Quartic Formula\<close>

lemma quartic:
  "(y::real)^3 - b * y^2 + (a * c - 4 * d) * y - a^2 * d + 4 * b * d - c^2 = 0 \<and>
    R^2 = a^2 / 4 - b + y \<and>
    s^2 = y^2 - 4 * d \<and>
    (D^2 = (if R = 0 then 3 * a^2 / 4 - 2 * b + 2 * s
                     else 3 * a^2 / 4 - R^2 - 2 * b + (4 * a * b - 8 * c - a^3) / (4 * R))) \<and>
    (E^2 = (if R = 0 then 3 * a^2 / 4 - 2 * b - 2 * s
                     else 3 * a^2 / 4 - R^2 - 2 * b - (4 * a * b - 8 * c - a^3) / (4 * R)))
  \<Longrightarrow> x^4 + a * x^3 + b * x^2 + c * x + d = 0 \<longleftrightarrow>
      x = -a / 4 + R / 2 + D / 2 \<or>
      x = -a / 4 + R / 2 - D / 2 \<or>
      x = -a / 4 - R / 2 + E / 2 \<or>
      x = -a / 4 - R / 2 - E / 2"
  apply (cases "R = 0")
   apply (simp_all add: field_simps divide_minus_left[symmetric] del: divide_minus_left)
   apply algebra
  apply algebra
  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_48
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y xs) = S (length xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y = True"
| "t2 (S z) (Z) = False"
| "t2 (S z) (S x2) = t2 z x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if t2 x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "((length (isort x)) = (length x))"
  oops

end


(*  Title:       Metric and semimetric spaces
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

header "Metric and semimetric spaces"

theory Metric
imports "~~/src/HOL/Multivariate_Analysis/Euclidean_Space"
begin

locale semimetric =
  fixes dist :: "'p \<Rightarrow> 'p \<Rightarrow> real"
  assumes nonneg [simp]: "dist x y \<ge> 0"
  and eq_0 [simp]: "dist x y = 0 \<longleftrightarrow> x = y"
  and symm: "dist x y = dist y x"
begin
  lemma refl [simp]: "dist x x = 0"
    by simp
end

locale metric =
  fixes dist :: "'p \<Rightarrow> 'p \<Rightarrow> real"
  assumes [simp]: "dist x y = 0 \<longleftrightarrow> x = y"
  and triangle: "dist x z \<le> dist y x + dist y z"

sublocale metric < semimetric
proof
  { fix w
    have "dist w w = 0" by simp }
  note [simp] = this
  fix x y
  show "0 \<le> dist x y"
  proof -
    from triangle [of y y x] show "0 \<le> dist x y" by simp
  qed
  show "dist x y = 0 \<longleftrightarrow> x = y" by simp
  show "dist x y = dist y x"
  proof -
    { fix w z
      have "dist w z \<le> dist z w"
      proof -
        from triangle [of w z z] show "dist w z \<le> dist z w" by simp
      qed }
    hence "dist x y \<le> dist y x" and "dist y x \<le> dist x y" by simp+
    thus "dist x y = dist y x" by simp
  qed
qed

definition norm_dist :: "('a::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> real" where
[simp]: "norm_dist x y \<equiv> norm (x - y)"

interpretation norm_metric: metric norm_dist
proof
  fix x y
  show "norm_dist x y = 0 \<longleftrightarrow> x = y" by simp
  fix z
  from norm_triangle_ineq [of "x - y" "y - z"] have
    "norm (x - z) \<le> norm (x - y) + norm (y - z)" by simp
  with norm_minus_commute [of x y] show
    "norm_dist x z \<le> norm_dist y x + norm_dist y z" by simp
qed

end


(*  Title:       Verification components with relational MKA
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Relational model \<close> (* by Victor Gomes, Georg Struth *)

text \<open> In this subsection, we follow Gomes and Struth~\<^cite>\<open>"afp:vericomp"\<close> and show that relations
form Kleene algebras.  \<close>

theory HS_VC_KA_rel
  imports Kleene_Algebra.Kleene_Algebra

begin

context dioid_one_zero
begin

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
  by(induct n, auto, metis mult.assoc mult_isol order_trans)

lemma power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> (x ^ n) \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc
  {fix n
    assume "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ n \<le> y"
      and "z + y \<cdot> x \<le> y"
    hence "z \<cdot> x ^ n \<le> y"
      by auto
    also have "z \<cdot> x ^ Suc n = z \<cdot> x \<cdot> x ^ n"
      by (metis mult.assoc power_Suc)
    moreover have "... = (z \<cdot> x ^ n) \<cdot> x"
      by (metis mult.assoc power_commutes)
    moreover have "... \<le> y \<cdot> x"
      by (metis calculation(1) mult_isor)
    moreover have "... \<le> y"
      using \<open>z + y \<cdot> x \<le> y\<close> by auto
    ultimately have "z \<cdot> x ^ Suc n \<le> y" by auto}
  thus ?case
    by (metis Suc)
qed

end

interpretation rel_dioid: dioid_one_zero "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)"
  by (unfold_locales, auto)

lemma power_is_relpow: "rel_dioid.power X n = X ^^ n"
proof (induct n)
  case 0 show ?case
    by (metis rel_dioid.power_0 relpow.simps(1))
  case Suc thus ?case
    by (metis rel_dioid.power_Suc2 relpow.simps(2))
qed

lemma rel_star_def: "X^* = (\<Union>n. rel_dioid.power X n)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X O Y^* = (\<Union>n. X O rel_dioid.power Y n)"
  by (metis rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* O Y = (\<Union>n. (rel_dioid.power X n) O Y)"
  by (metis rel_star_def relcomp_UNION_distrib2)

interpretation rel_ka: kleene_algebra "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl
proof
  fix x y z :: "'a rel"
  show "Id \<union> x O x\<^sup>* \<subseteq> x\<^sup>*"
    by (metis order_refl r_comp_rtrancl_eq rtrancl_unfold)
next
  fix x y z :: "'a rel"
  assume "z \<union> x O y \<subseteq> y"
  thus "x\<^sup>* O z \<subseteq> y"
    by (simp only: rel_star_contr, metis (lifting) SUP_le_iff rel_dioid.power_inductl)
next
  fix x y z :: "'a rel"
  assume "z \<union> y O x \<subseteq> y"
  thus "z O x\<^sup>* \<subseteq> y"
    by (simp only: rel_star_contl, metis (lifting) SUP_le_iff rel_dioid.power_inductr)
qed

end