(* Title: Verification Component Based on KAD for Forward Reasoning: Examples
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection\<open>Verification Examples\<close>

theory VC_KAD_dual_Examples
imports VC_KAD_dual

begin

text\<open>The proofs are essentially the same as with forward boxes.\<close>

lemma euclid:
  "FPRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  by (rule rel_modal_kleene_algebra.bdia_whilei, auto simp: gcd_non_0_nat)

lemma euclid_diff:
   "FPRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_modal_kleene_algebra.bdia_whilei, simp_all)
  apply auto[1]
  by (metis gcd.commute gcd_diff1_nat le_cases nat_less_le)

lemma varible_swap:
  "FPRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by simp

lemma maximum:
  "FPRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by auto

lemma integer_division:
  "FPRE (\<lambda>s::nat store. x \<ge> 0)
    (''q'' ::= (\<lambda>s. 0));
    (''r'' ::= (\<lambda>s. x));
    (WHILE (\<lambda>s. y \<le> s ''r'') INV (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0)
     DO
      (''q'' ::= (\<lambda>s. s ''q'' + 1));
      (''r'' ::= (\<lambda>s. s ''r'' - y))
      OD)
   POST (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' \<ge> 0 \<and> s ''r'' < y)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp: p2r_def)

lemma factorial:
  "FPRE (\<lambda>s::nat store. True)
   (''x'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''x'' \<noteq> x0) INV (\<lambda>s. s ''y'' = fact (s ''x''))
   DO
     (''x'' ::= (\<lambda>s. s ''x'' + 1));
     (''y'' ::= (\<lambda>s. s ''y'' \<cdot> s ''x''))
   OD)
   POST (\<lambda>s. s ''y'' = fact x0)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp: p2r_def)

lemma my_power:
  "FPRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all, auto simp add: p2r_def)

lemma imp_reverse:
  "FPRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply (rule rel_modal_kleene_algebra.bdia_whilei_break, simp_all)
  apply auto[1]
  by (safe, metis append.simps append_assoc hd_Cons_tl rev.simps(2))

end


theory QuantK_Sqrt
imports QuantK_VCG "HOL-Library.Discrete"
begin

subsection \<open>Example: discrete square root in the quantitative Hoare logic\<close>

text \<open>As an example, consider the following program that computes the discrete square root:\<close>

definition c :: com where "c=
         ''l''::= N 0 ;;
         ''m'' ::= N 0 ;;
         ''r''::= Plus (N 1) (V ''x'');;
         (WHILE (Less (Plus (N 1) (V ''l'')) (V ''r''))
              DO (''m'' ::= (Div (Plus (V ''l'') (V ''r'')) (N 2)) ;;
                 (IF Not (Less (Times (V ''m'') (V ''m'')) (V ''x''))
                    THEN ''l'' ::= V ''m''
                    ELSE ''r'' ::= V ''m'');;
                 ''m'' ::= N 0))"

text \<open>In this theory we will show that its running time is in the order of magnitude of the
      logarithm of the variable ''x''\<close>

text \<open>a little lemma we need later for bounding the running time:\<close>

lemma absch: "\<And>s k. 1 + s ''x'' = 2 ^ k \<Longrightarrow> 5 * k \<le> 96 + 100 * Discrete.log (nat (s ''x''))"
proof -
  fix s :: state and  k :: nat
  assume F: " 1 + s ''x'' = 2 ^ k "
  then have i: "nat (1 + s ''x'') =  2 ^ k" and nn: "s ''x''\<ge> 0"  apply (auto simp: nat_power_eq)
    by (smt one_le_power)
  have F: "1 + nat (s ''x'') = 2 ^k" unfolding i[symmetric] using nn by auto
  show "5 * k \<le> 96 + 100 * Discrete.log (nat (s ''x''))"
  proof (cases "s ''x'' \<ge> 1")
    case True
    have "5 * k = 5 * (Discrete.log (2^k))"     by auto
    also have "\<dots> = 5 * Discrete.log (1 + nat (s ''x''))" by(simp only: F[symmetric])
    also have "\<dots> \<le> 5 * Discrete.log (nat (s ''x'' + s ''x''))" using True
      apply auto apply(rule monoD[OF log_mono]) by auto
    also have "\<dots> = 5 *  Discrete.log (2 * nat (s ''x''))" by (auto simp: nat_mult_distrib)
    also have "\<dots> = 5 + 5 * (Discrete.log (nat (s ''x'')))" using True by auto
    also have "\<dots> \<le> 96 + 100 * Discrete.log (nat (s ''x''))" by simp
    finally show ?thesis .
  next
    case False
    with nn have gt1: "s ''x'' = 0" by auto
    from F[unfolded gt1] have "2 ^ k = (1::int)" using log_Suc_zero by auto
    then have "k=0"
      by (metis One_nat_def add.right_neutral gt1 i n_not_Suc_n nat_numeral nat_power_eq_Suc_0_iff numeral_2_eq_2 numeral_One)
    then show ?thesis by(simp add: gt1)
  qed
qed

text \<open>For simplicity we assume, that during the process all segments between ''l'' and ''r'' have
      as length a power of two. This simplifies the analysis.
      To obtain this we choose the prepotential P accordingly.

      Now lets show the correctness of our time complexity: the binary search is in O(log ''x'') \<close>

lemma
  assumes
    P: "P  = (\<lambda>s. \<up> (  (\<exists>k. 1 + s ''x''  = 2 ^ k)) + (Discrete.log (nat ( s ''x'')) + 1))" and
      Q[simp]: "Q = (\<lambda>_. 0)"
  shows " \<turnstile>\<^sub>2\<^sub>' {P} c {Q}"
proof -
  \<comment> \<open>first we create an annotated command\<close>
  let ?lb = "''m'' ::=
              (Div (Plus (V ''l'') (V ''r'')) (N 2)) ;;
              (IF Not (Less (Times (V ''m'') (V ''m'')) (V ''x''))
                THEN ''l'' ::= V ''m''
                ELSE ''r'' ::= V ''m'');;
              (''m'' ::= N 0)::acom"
  \<comment> \<open>with an invariant potential\<close>
  define I   where "I \<equiv> (\<lambda>s::state. (( emb (  s ''l''\<ge>0   \<and> ( \<exists>k. s ''r'' - s ''l'' = 2 ^ k) ) + 5 * Discrete.log (nat (s ''r'') - nat (s ''l'')))::enat) )"
  let ?C = " ((''l''::= N 0) :: acom) ;; (''m'' ::= N 0) ;; ''r''::= Plus (N 1) (V ''x'');; ({I} WHILE (Less (Plus (N 1) (V ''l'')) (V ''r'')) DO ?lb)"

  \<comment> \<open>we show that the annotated command corresponds to the command we are interested in\<close>
  have s: "strip ?C = c" unfolding c_def by auto

  \<comment> \<open>now we show that the annotated command is correct; here we use the VCG for the QuantK logic\<close>
  have v: "\<turnstile>\<^sub>2\<^sub>' {P} strip ?C {Q}"
  proof (rule vc_sound'', safe)

    \<comment> \<open>A) first lets show the verification conditions:\<close>
    show "vc ?C Q" apply auto
      unfolding I_def
      subgoal for s
        apply(cases "(\<exists>k. s ''r''  - s ''l'' = 2 ^ k)") apply auto
        apply(cases "(1 + s ''l'' < s ''r'')") apply auto
        apply(cases "0 \<le> s ''l''") apply auto
      proof (goal_cases)
        case (1 k)
        then have "k>0" using gr0I by force
        then obtain k' where k': "k=k'+1" by (metis Suc_eq_plus1 Suc_pred)
        from 1 k' have R: " s ''r'' - (s ''l'' + s ''r'') div 2 = 2 ^ k'" by auto
        have gN: "s ''l''\<le>s ''r''"  "s ''l''\<ge>0" "s ''r'' \<ge> 0" using 1 by auto
        have n: "nat ( s ''r'' - (s ''l'' + s ''r'') div 2 ) =  nat (s ''r'') - nat ((s ''l'' + s ''r'') div 2)"
          using gN  apply(simp add: nat_diff_distrib nat_div_distrib) done

        have R': "nat (s ''r'') -  nat ((s ''l'' + s ''r'') div 2) = 2 ^ k'"
          apply(simp only: n[symmetric] R nat_power_eq) by auto
        have S': "nat (s ''r'') - nat (s ''l'') = 2 ^ k"
          using gN apply(simp only: nat_diff_distrib[symmetric] 1(2) nat_power_eq) by auto
        have N: "0 \<le> (s ''l'' + s ''r'') div 2" using gN by auto

        from N  show ?case apply (simp ) apply (simp only : R R' S' k') by (auto simp: eSuc_enat plus_1_eSuc(2))
      qed
      subgoal for s
        apply(cases "\<exists>k. s ''r''  - s ''l'' = 2 ^ k") apply auto
        apply (cases "(1 + s ''l'' < s ''r'')") apply auto
        apply(cases "0 \<le> s ''l''") apply auto
      proof (goal_cases)
        case (1 k)
        from 1(2,3) have "k>0" using gr0I by force
        then obtain k' where k': "k=k'+1" by (metis Suc_eq_plus1 Suc_pred)
        from 1 k' have R: " (s ''l'' + s ''r'') div 2 - s ''l'' = 2 ^ k'" by auto
        have gN: "s ''l''\<le>s ''r''"  "s ''l''\<ge>0" "s ''r'' \<ge> 0" using 1 by auto
        have n: "nat ((s ''l'' + s ''r'') div 2 - s ''l'') =  nat ( (s ''l'' + s ''r'') div 2) - nat (s ''l'')"
          using gN  apply(simp add: nat_diff_distrib nat_div_distrib) done

        have R': "nat ( (s ''l'' + s ''r'') div 2) - nat (s ''l'') = 2 ^ k'"
          apply(simp only: n[symmetric] R nat_power_eq) by auto
        have S': "nat (s ''r'') - nat (s ''l'') = 2 ^ k"
          using gN apply(simp only: nat_diff_distrib[symmetric] 1(2) nat_power_eq) by auto

        show ?case   apply (simp only : R R' S' k') by (auto simp: eSuc_enat plus_1_eSuc(2))
      qed done
  next
    \<comment> \<open>B) lets show that the precondition implies the weakest precondition, and that the
            time bound of C can be bounded by log ''x''\<close>
    fix s
    show "pre ?C Q s \<le> enat 100 * P s" unfolding  I_def apply(simp only: P)  apply auto apply(cases "(\<exists>k. 1 + s ''x''   = 2 ^ k)")
       apply (auto simp: eSuc_enat plus_1_eSuc(2) nat_power_eq)
        using absch by force
  qed auto

  from s v show ?thesis by simp
qed

end


theory sample5
  imports Main begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  for r where
  refl: "star r x x" |
  step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

thm star.induct

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
  (* apply(simp add:refl) *)
  (* for subgoal 1. The first one is P x x,
   the result of case refl*)
   apply(assumption)
  apply(metis step)
  done


(* 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_sort_ISortPermutes
imports "../../Test_Base"
begin

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

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

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

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (isort xs) xs"
  oops

end


theory ex2_03 imports Main begin

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count y Nil = 0" |
"count y (x#xs) = (if x = y then 1+(count y xs) else count y xs)"

(* I cannot understand why the value is not 1*)
value "count 1 (1#2#3#[])"

theorem "count x xs \<le> length xs"
apply(induction xs)
apply auto
done

end


(* Author: Ujkan Sulejmani *)

section \<open>Center Selection\<close>

theory Center_Selection
  imports Complex_Main "HOL-Hoare.Hoare_Logic"
begin

text \<open>The Center Selection (or metric k-center) problem. Given a set of \textit{sites} \<open>S\<close>
in a metric space, find a subset \<open>C \<subseteq> S\<close> that minimizes the maximal distance from any \<open>s \<in> S\<close>
to some \<open>c \<in> C\<close>. This theory presents a verified 2-approximation algorithm.
It is based on Section 11.2 in the book by Kleinberg and Tardos \<^cite>\<open>"KleinbergT06"\<close>.
In contrast to the proof in the book, our proof is a standard invariant proof.\<close>

locale Center_Selection =
  fixes S :: "('a :: metric_space) set"
    and k :: nat
  assumes finite_sites: "finite S"
  and     non_empty_sites: "S \<noteq> {}"
and       non_zero_k: "k > 0"
begin

definition distance :: "('a::metric_space) set \<Rightarrow> ('a::metric_space) \<Rightarrow> real" where
"distance C s = Min (dist s ` C)"

definition radius :: "('a :: metric_space) set \<Rightarrow> real" where
"radius C = Max (distance C ` S)"

lemma distance_mono:
assumes "C\<^sub>1 \<subseteq> C\<^sub>2" and "C\<^sub>1 \<noteq> {}" and "finite C\<^sub>2"
shows "distance C\<^sub>1 s \<ge> distance C\<^sub>2 s"
by (simp add: Min.subset_imp assms distance_def image_mono)

lemma finite_distances: "finite (distance C ` S)"
  using finite_sites by simp

lemma non_empty_distances: "distance C ` S \<noteq> {}"
  using non_empty_sites by simp

lemma radius_contained: "radius C \<in> distance C ` S"
  using finite_distances non_empty_distances Max_in radius_def by simp

lemma radius_def2: "\<exists>s \<in> S. distance C s = radius C"
  using radius_contained image_iff by metis

lemma dist_lemmas_aux:
  assumes  "finite C"
      and  "C \<noteq> {}"
  shows  "finite (dist s ` C)"
    and "finite (dist s ` C) \<Longrightarrow> distance C s \<in> dist s ` C"
    and "distance C s \<in> dist s ` C \<Longrightarrow> \<exists>c \<in> C. dist s c = distance C s"
and "\<exists>c \<in> C. dist s c = distance C s \<Longrightarrow> distance C s \<ge> 0"
proof
  show "finite C" using assms(1) by simp
next
  assume "finite (dist s ` C)"
  then show "distance C s \<in> dist s ` C" using distance_def eq_Min_iff assms(2) by blast
next
  assume "distance C s \<in> dist s ` C"
  then show "\<exists>c \<in> C. dist s c = distance C s" by auto
next
  assume "\<exists>c \<in> C. dist s c = distance C s"
  then show "distance C s \<ge> 0" by (metis zero_le_dist)
qed

lemma dist_lemmas:
  assumes "finite C"
      and "C \<noteq> {}"
  shows "finite (dist s ` C)"
    and "distance C s \<in> dist s ` C"
    and "\<exists>c \<in> C. dist s c = distance C s"
    and "distance C s \<ge> 0"
  using dist_lemmas_aux assms by auto

lemma radius_max_prop: "(\<forall>s \<in> S. distance C s \<le> r) \<Longrightarrow> (radius C \<le> r)"
  by (metis image_iff radius_contained)

lemma dist_ins:
assumes "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> x < dist c\<^sub>1 c\<^sub>2"
and "distance C s > x"
and "finite C"
and "C \<noteq> {}"
shows "\<forall>c\<^sub>1 \<in> (C \<union> {s}). \<forall>c\<^sub>2 \<in> (C \<union> {s}). c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> x < dist c\<^sub>1 c\<^sub>2"
proof (rule+)
  fix c\<^sub>1 c\<^sub>2
  assume local_assms: "c\<^sub>1\<in>C \<union> {s}" "c\<^sub>2\<in>C \<union> {s}" "c\<^sub>1 \<noteq> c\<^sub>2"
  then have "c\<^sub>1 \<in> C  \<and> c\<^sub>2 \<in> C  \<or> c\<^sub>1 \<in>C  \<and> c\<^sub>2\<in> {s} \<or> c\<^sub>2\<in>C  \<and> c\<^sub>1 \<in> {s} \<or> c\<^sub>1 \<in> {s} \<and> c\<^sub>2\<in> {s}" by auto
  then show "x < dist c\<^sub>1 c\<^sub>2"
  proof (elim disjE)
    assume "c\<^sub>1 \<in>C  \<and> c\<^sub>2\<in>C"
    then show ?thesis using assms(1) local_assms(3) by simp
  next
    assume case_assm: "c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> {s}"
    have "x < distance C c\<^sub>2" using assms(2) case_assm by simp
    also have " ... \<le> dist c\<^sub>2 c\<^sub>1"
      using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp
    also have " ... = dist c\<^sub>1 c\<^sub>2" using dist_commute by metis
    finally show ?thesis .
  next
    assume case_assm: "c\<^sub>2 \<in> C \<and> c\<^sub>1 \<in> {s}"
    have "x < distance C c\<^sub>1" using assms(2) case_assm by simp
    also have " ... \<le> dist c\<^sub>1 c\<^sub>2"
      using Min.coboundedI distance_def assms(3,4) dist_lemmas(1, 2) case_assm by simp
    finally show ?thesis .
  next
    assume "c\<^sub>1 \<in> {s} \<and> c\<^sub>2 \<in> {s}"
    then have False using local_assms by simp
    then show ?thesis by simp
  qed
qed

subsection \<open>A Preliminary Algorithm and Proof\<close>

text \<open>This subsection verifies an auxiliary algorithm by Kleinberg and Tardos.
Our proof of the main algorithm does not does not rely on this auxiliary algorithm at all
but we do reuse part off its invariant proof later on.\<close>

definition inv :: "('a :: metric_space) set \<Rightarrow> ('a :: metric_space set) \<Rightarrow> real \<Rightarrow> bool" where
"inv S' C r =
  ((\<forall>s \<in> (S - S'). distance C s \<le> 2*r) \<and> S' \<subseteq> S \<and> C \<subseteq> S \<and>
   (\<forall>c \<in> C. \<forall>s \<in> S'. S' \<noteq> {} \<longrightarrow> dist c s > 2 * r) \<and> (S' = S \<or> C \<noteq> {}) \<and>
   (\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * r))"

lemma inv_init: "inv S {} r"
  unfolding inv_def non_empty_sites by simp
lemma inv_step:
  assumes "S' \<noteq> {}"
and IH: "inv S' C r"
defines[simp]: "s \<equiv> (SOME s. s \<in> S')"
shows "inv (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}) (C \<union> {s}) r"
proof -
  have s_def: "s \<in> S'" using assms(1) some_in_eq by auto

  have "finite (C \<union> {s})" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def)

  moreover

  have "(\<forall>s' \<in> (S - (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r})). distance (C \<union> {s}) s' \<le> 2*r)"
  proof
    fix s''
    assume "s'' \<in> S - (S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r})"
    then have "s'' \<in> S - S' \<or> s'' \<in> {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}" by simp
    then show "distance (C \<union> {s}) s'' \<le> 2 * r"
    proof (elim disjE)
      assume local_assm: "s'' \<in> S - S'"
      have "S' = S \<or> C \<noteq> {}" using IH by (simp add: inv_def)
      then show ?thesis
      proof (elim disjE)
        assume "S' = S"
        then have "s'' \<in> {}" using local_assm by simp
        then show ?thesis by simp
      next
        assume C_not_empty: "C \<noteq> {}"
        have "finite C" using IH finite_subset[OF _ finite_sites] by (simp add: inv_def)
        then have "distance (C \<union> {s}) s'' \<le> distance C s''"
          using distance_mono C_not_empty by (meson Un_upper1 calculation)
        also have " ...  \<le> 2 * r" using IH local_assm inv_def by simp
        finally show ?thesis .
      qed
    next
      assume local_assm: "s'' \<in> {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}"
      then have "distance (C \<union> {s}) s'' \<le> dist s'' s"
        using Min.coboundedI distance_def dist_lemmas calculation by auto
      also have " ... \<le> 2 * r" using local_assm by (smt dist_self dist_triangle2 mem_Collect_eq)
      finally show ?thesis .
    qed
  qed

  moreover

  have "S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r} \<subseteq> S" using IH by (auto simp: inv_def)

  moreover
  {
    have "s \<in> S" using IH inv_def s_def by auto
    then have "C \<union> {s} \<subseteq> S" using IH by (simp add: inv_def)
  }
  moreover

  have "(\<forall>c\<in>C \<union> {s}. \<forall>c\<^sub>2\<in>C \<union> {s}. c \<noteq> c\<^sub>2 \<longrightarrow> 2 * r < dist c c\<^sub>2)"
  proof (rule+)
    fix c\<^sub>1 c\<^sub>2
    assume local_assms: "c\<^sub>1 \<in> C \<union> {s}" "c\<^sub>2 \<in> C \<union> {s}" "c\<^sub>1 \<noteq> c\<^sub>2"
    then have "(c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C) \<or> (c\<^sub>1 = s \<and> c\<^sub>2 \<in> C) \<or> (c\<^sub>1 \<in> C \<and> c\<^sub>2 = s) \<or> (c\<^sub>1 = s \<and> c\<^sub>2 = s)"
      using assms by auto
    then show "2 * r < dist c\<^sub>1 c\<^sub>2"
    proof (elim disjE)
      assume "c\<^sub>1 \<in> C \<and> c\<^sub>2 \<in> C"
      then show "2 * r < dist c\<^sub>1 c\<^sub>2" using IH inv_def local_assms by simp
    next
      assume case_assm: "c\<^sub>1 = s \<and> c\<^sub>2 \<in> C"
      have "(\<forall>c \<in> C. \<forall>s\<in>S'. S' \<noteq> {} \<longrightarrow> 2 * r < dist c s)" using IH inv_def by simp
      then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
    next
      assume case_assm: "c\<^sub>1 \<in> C \<and> c\<^sub>2 = s"
      have "(\<forall>c \<in> C. \<forall>s\<in>S'. S' \<noteq> {} \<longrightarrow> 2 * r < dist c s)" using IH inv_def by simp
      then show ?thesis by (smt case_assm s_def assms(1) dist_self dist_triangle3 singletonD)
    next
      assume "c\<^sub>1 = s \<and> c\<^sub>2 = s"
      then have False using local_assms(3) by simp
      then show ?thesis by simp
    qed
  qed

  moreover

  have "(\<forall>c\<in>C \<union> {s}. \<forall>s'' \<in> S' - {s' \<in> S'. dist s s' \<le> 2 * r}.
           S' - {s' \<in> S'. dist s s' \<le> 2 * r} \<noteq> {} \<longrightarrow> 2 * r < dist c s'')"
    using IH inv_def by fastforce

  moreover

  have "(S' - {s' \<in> S'. dist s s' \<le> 2 * r} = S \<or> C \<union> {s} \<noteq> {})" by simp

  ultimately show ?thesis unfolding inv_def by blast
qed

lemma inv_last_1:
  assumes "\<forall>s \<in> (S - S'). distance C s \<le> 2*r"
    and "S' = {}"
  shows "radius C \<le> 2*r"
  by (metis Diff_empty assms image_iff radius_contained)

lemma inv_last_2:
  assumes "finite C"
  and "card C > n"
  and "C \<subseteq> S"
  and "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2*r"
  shows "\<forall>C'. card C' \<le> n \<and> card C' > 0 \<longrightarrow> radius C' > r" (is ?P)
proof (rule ccontr)
  assume "\<not> ?P"
  then obtain C' where card_C': "card C' \<le> n \<and> card C' > 0" and radius_C': "radius C' \<le> r" by auto
  have "\<forall>c \<in> C. (\<exists>c'. c' \<in> C' \<and> dist c c' \<le> r)"
  proof
    fix c
    assume "c \<in> C"
    then have "c \<in> S" using assms(3) by blast
    then have "distance C' c \<le> radius C'" using finite_distances by (simp add: radius_def)
    then have "distance C' c \<le> r" using radius_C' by simp
    then show "\<exists>c'. c' \<in> C' \<and> dist c c' \<le> r" using dist_lemmas
      by (metis card_C' card_gt_0_iff)
  qed
  then obtain f where f: "\<forall>c\<in>C. f c \<in> C' \<and> dist c (f c) \<le> r" by metis
  have "\<not>inj_on f C"
  proof
    assume "inj_on f C"
    then have "card C' \<ge> card C" using \<open>inj_on f C\<close> card_inj_on_le card_ge_0_finite card_C' f by blast
    then show False using card_C' \<open>n < card C\<close> by linarith
  qed
  then obtain c1 c2 where defs: "c1 \<in> C \<and> c2 \<in> C \<and> c1 \<noteq> c2 \<and> f c1 = f c2" using inj_on_def by blast
  then have *: "dist c1 (f c1) \<le> r \<and> dist c2 (f c1) \<le> r" using f by auto

  have "2 * r < dist c1 c2" using assms defs by simp
  also have " ... \<le> dist c1 (f c1) + dist (f c1) c2" by(rule dist_triangle)
  also have " ... = dist c1 (f c1) + dist c2 (f c1)" using dist_commute by simp
  also have " ... \<le> 2 * r" using * by simp
  finally show False by simp
qed

lemma inv_last:
  assumes "inv {} C r"
  shows "(card C \<le> k \<longrightarrow> radius C \<le> 2*r) \<and> (card C > k \<longrightarrow> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C' > r))"
  using assms inv_def inv_last_1 inv_last_2 finite_subset[OF _ finite_sites] by auto

theorem Center_Selection_r:
  "VARS (S' :: ('a :: metric_space) set) (C :: ('a :: metric_space) set) (r :: real) (s :: 'a)
  {True}
  S' := S;
  C := {};
  WHILE S' \<noteq> {} INV {inv S' C r} DO
    s := (SOME s. s \<in> S');
    C := C \<union> {s};
    S' := S' - {s' . s' \<in> S' \<and> dist s s' \<le> 2*r}
    OD
  {(card C \<le> k \<longrightarrow> radius C \<le> 2*r) \<and> (card C > k \<longrightarrow> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C' > r))}"
proof (vcg, goal_cases)
  case (1 S' C r)
  then show ?case using inv_init by simp
next
  case (2 S' C r)
  then show ?case using inv_step by simp
next
  case (3 S' C r)
  then show ?case using inv_last by blast
qed

subsection \<open>The Main Algorithm\<close>

definition invar :: "('a :: metric_space) set \<Rightarrow> bool" where
"invar C = (C \<noteq> {} \<and> card C \<le> k \<and> C \<subseteq> S \<and>
  (\<forall>C'. (\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * radius C')
        \<or> (\<forall>s \<in> S. distance C s \<le> 2 * radius C')))"

abbreviation some where "some A \<equiv> (SOME s. s \<in> A)"

lemma invar_init: "invar {some S}"
proof -
  let ?s = "some S"
  have s_in_S: "?s \<in> S" using some_in_eq non_empty_sites by blast

  have "{?s} \<noteq> {}" by simp

  moreover

  have "{SOME s. s \<in> S} \<subseteq> S" using s_in_S by simp

  moreover

  have "card {SOME s. s \<in> S} \<le> k" using non_zero_k by simp

  ultimately show ?thesis by (auto simp: invar_def)
qed

abbreviation furthest_from where
"furthest_from C \<equiv> (SOME s. s \<in> S \<and> distance C s = Max (distance C ` S))"

  have "C \<union> {furthest_from C} \<noteq> {}" by simp

  moreover

  have "(C \<union> {furthest_from C}) \<subseteq> S" using assms(1) furthest_from_C_props unfolding invar_def by simp

  moreover

  have "\<forall>C'. (\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')
          \<or> (\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. \<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2)"
  proof
    fix C'
    have "distance C (furthest_from C) > 2 * radius C' \<or> distance C (furthest_from C) \<le> 2 * radius C'" by auto
    then show "(\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')
               \<or> (\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. \<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2)"
    proof (elim disjE)
      assume asm: "distance C (furthest_from C) > 2 * radius C'"
      then have "\<not>(\<forall>s \<in> S. distance C s \<le> 2 * radius C')" using furthest_from_C_props by force
      then have IH: "\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2"
        using assms(1) unfolding invar_def by blast
      have "(\<forall>c\<^sub>1 \<in> C \<union> {furthest_from C}. (\<forall>c\<^sub>2 \<in> C \<union> {furthest_from C}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * radius C' < dist c\<^sub>1 c\<^sub>2))"
        using dist_ins[of "C" "2 * radius C'" "furthest_from C"] IH C_props asm by simp
      then show ?thesis by simp
    next
      assume main_assm: "2 * radius C' \<ge> distance C (furthest_from C)"
      have "(\<forall>s \<in> S. distance (C \<union> {furthest_from C}) s \<le> 2 * radius C')"
      proof
        fix s
        assume local_assm: "s \<in> S"
        then show "distance (C \<union> {furthest_from C}) s \<le> 2 * radius C'"
        proof -
          have "distance (C \<union> {furthest_from C}) s \<le> distance C s"
            using distance_mono[of C "C \<union> {furthest_from C}"] C_props by auto
          also have " ... \<le> distance C (furthest_from C)"
            using Max.coboundedI local_assm finite_distances radius_def furthest_from_C_props by auto
          also have " ... \<le> 2 * radius C'" using main_assm by simp
          finally show ?thesis .
        qed
      qed
      then show ?thesis by blast
    qed
  qed

  ultimately show ?thesis unfolding invar_def by blast
qed

lemma invar_last:
assumes "invar C" and "\<not>card C < k"
shows "card C = k" and "card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C'"
proof -
  show "card C = k" using assms(1, 2) unfolding invar_def by simp
next
  have C_props: "finite C \<and> C \<noteq> {}" using finite_sites assms(1) unfolding invar_def by (meson finite_subset)
  show "card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C'"
  proof (rule impI)
    assume C'_assms: "0 < card (C' :: 'a set) \<and> card C' \<le> k"
    let ?r = "radius C'"
    have "(\<forall>c\<^sub>1 \<in> C. \<forall>c\<^sub>2 \<in> C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * ?r < dist c\<^sub>1 c\<^sub>2) \<or> (\<forall>s \<in> S. distance C s \<le> 2 * ?r)"
      using assms(1) unfolding invar_def by simp
    then show "radius C \<le> 2 * ?r"
    proof
      assume case_assm: "\<forall>c\<^sub>1\<in>C. \<forall>c\<^sub>2\<in>C. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> 2 * ?r < dist c\<^sub>1 c\<^sub>2"
      obtain s where s_def: "radius C = distance C s \<and> s \<in> S" using radius_def2 by metis
      show ?thesis
      proof (rule ccontr)
        assume contr_assm: "\<not> radius C \<le> 2 * ?r"
        then have s_prop: "distance C s > 2 * ?r" using s_def by simp
        then have \<open>\<forall>c\<^sub>1 \<in> C \<union> {s}. \<forall>c\<^sub>2 \<in> C \<union> {s}. c\<^sub>1 \<noteq> c\<^sub>2 \<longrightarrow> dist c\<^sub>1 c\<^sub>2 > 2 * ?r\<close>
          using C_props dist_ins[of "C" "2*?r" "s"] case_assm by blast
        moreover
        {
          have "s \<notin> C"
          proof
            assume "s \<in> C"
            then have "distance C s \<le> dist s s" using Min.coboundedI[of "distance C ` S" "dist s s"]
              by (simp add: distance_def C_props)
            also have " ... = 0" by simp
            finally have "distance C s = 0" using dist_lemmas(4) by (smt C_props)
            then have radius_le_zero: "2 * ?r < 0" using contr_assm s_def by simp
            obtain x where x_def: "?r = distance C' x" using radius_def2 by metis
            obtain l where l_def: "distance C' x = dist x l" using dist_lemmas(3) by (metis C'_assms card_gt_0_iff)
            then have "dist x l = ?r" by (simp add: x_def)
            also have "...  < 0" using C'_assms radius_le_zero by simp
            finally show False by simp
          qed
          then have "card (C \<union> {s}) > k" using assms(1,2) C_props unfolding invar_def by simp
        }
        moreover
          have "C \<union> {s} \<subseteq> S" using assms(1) s_def unfolding invar_def by simp
        moreover
          have "finite (C \<union> {s})" using calculation(3) finite_subset finite_sites by auto
        ultimately have "\<forall>C. card C \<le> k \<and> card C > 0 \<longrightarrow> radius C > ?r" using inv_last_2 by metis
        then have "?r > ?r" using C'_assms by blast
        then show False by simp
      qed
    next
      assume "\<forall>s\<in>S. distance C s \<le> 2 * radius C'"
      then show ?thesis by (metis image_iff radius_contained)
    qed
  qed
qed

theorem Center_Selection:
"VARS (C :: ('a :: metric_space) set) (s :: ('a :: metric_space))
  {k \<le> card S}
  C := {some S};
  WHILE card C < k INV {invar C} DO
    C := C \<union> {furthest_from C}
  OD
  {card C = k \<and> (\<forall>C'. card C' > 0 \<and> card C' \<le> k \<longrightarrow> radius C \<le> 2 * radius C')}"
proof (vcg, goal_cases)
  case (1 C s)
  show ?case using invar_init by simp
next
  case (2 C s)
  then show ?case using invar_step by blast
next
  case (3 C s)
  then show ?case using invar_last by blast
qed

end
end


(*  Title:      HOL/Induct/Sigma_Algebra.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section {* Sigma algebras *}

theory Sigma_Algebra
imports Main
begin

text {*
  This is just a tiny example demonstrating the use of inductive
  definitions in classical mathematics.  We define the least @{text
  \<sigma>}-algebra over a given set of sets.
*}

inductive_set \<sigma>_algebra :: "'a set set => 'a set set" for A :: "'a set set"
where
  basic: "a \<in> A ==> a \<in> \<sigma>_algebra A"
| UNIV: "UNIV \<in> \<sigma>_algebra A"
| complement: "a \<in> \<sigma>_algebra A ==> -a \<in> \<sigma>_algebra A"
| Union: "(!!i::nat. a i \<in> \<sigma>_algebra A) ==> (\<Union>i. a i) \<in> \<sigma>_algebra A"

text {*
  The following basic facts are consequences of the closure properties
  of any @{text \<sigma>}-algebra, merely using the introduction rules, but
  no induction nor cases.
*}

theorem sigma_algebra_empty: "{} \<in> \<sigma>_algebra A"
proof -
  have "UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.UNIV)
  then have "-UNIV \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-UNIV = {}" by simp
  finally show ?thesis .
qed

theorem sigma_algebra_Inter:
  "(!!i::nat. a i \<in> \<sigma>_algebra A) ==> (\<Inter>i. a i) \<in> \<sigma>_algebra A"
proof -
  assume "!!i::nat. a i \<in> \<sigma>_algebra A"
  then have "!!i::nat. -(a i) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  then have "(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.Union)
  then have "-(\<Union>i. -(a i)) \<in> \<sigma>_algebra A" by (rule \<sigma>_algebra.complement)
  also have "-(\<Union>i. -(a i)) = (\<Inter>i. a i)" by simp
  finally show ?thesis .
qed

end


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

section \<open>Minimal elements of sets w.r.t. a well-founded and transitive relation\<close>

theory Minimal_Elements
imports
  Infinite_Sequences
  Open_Induction.Restricted_Predicates
begin

locale minimal_element =
  fixes P A
  assumes po: "po_on P A"
    and wf: "wfp_on P A"
begin

definition "min_elt B = (SOME x. x \<in> B \<and> (\<forall>y \<in> A. P y x \<longrightarrow> y \<notin> B))"

lemma minimal:
  assumes "x \<in> A" and "Q x"
  shows "\<exists>y \<in> A. P\<^sup>=\<^sup>= y x \<and> Q y \<and> (\<forall>z \<in> A. P z y \<longrightarrow> \<not> Q z)"
using wf and assms
proof (induction rule: wfp_on_induct)
  case (less x)
  then show ?case
  proof (cases "\<forall>y \<in> A. P y x \<longrightarrow> \<not> Q y")
    case True
    with less show ?thesis by blast
  next
    case False
    then obtain y where "y \<in> A" and "P y x" and "Q y" by blast
    with less show ?thesis
      using po [THEN po_on_imp_transp_on, unfolded transp_on_def, rule_format, of _ y x] by blast
  qed
qed

lemma min_elt_ex:
  assumes "B \<subseteq> A" and "B \<noteq> {}"
  shows "\<exists>x. x \<in> B \<and> (\<forall>y \<in> A. P y x \<longrightarrow> y \<notin> B)"
using assms using minimal [of _ "\<lambda>x. x \<in> B"] by auto

lemma min_elt_mem:
  assumes "B \<subseteq> A" and "B \<noteq> {}"
  shows "min_elt B \<in> B"
using someI_ex [OF min_elt_ex [OF assms]] by (auto simp: min_elt_def)

lemma min_elt_minimal:
  assumes *: "B \<subseteq> A" "B \<noteq> {}"
  assumes "y \<in> A" and "P y (min_elt B)"
  shows "y \<notin> B"
using someI_ex [OF min_elt_ex [OF *]] and assms by (auto simp: min_elt_def)

text \<open>A lexicographically minimal sequence w.r.t.\ a given set of sequences \<open>C\<close>\<close>
fun lexmin
where
  lexmin: "lexmin C i = min_elt (ith (eq_upto C (lexmin C) i) i)"
declare lexmin [simp del]

lemma eq_upto_lexmin_non_empty:
  assumes "C \<subseteq> SEQ A" and "C \<noteq> {}"
  shows "eq_upto C (lexmin C) i \<noteq> {}"
proof (induct i)
  case 0
  show ?case using assms by auto
next
  let ?A = "\<lambda>i. ith (eq_upto C (lexmin C) i) i"
  case (Suc i)
  then have "?A i \<noteq> {}" by force
  moreover have "eq_upto C (lexmin C) i \<subseteq> eq_upto C (lexmin C) 0" by auto
  ultimately have "?A i \<subseteq> A" and "?A i \<noteq> {}" using assms by (auto simp: ith_def)
  from min_elt_mem [OF this, folded lexmin]
    obtain f where "f \<in> eq_upto C (lexmin C) (Suc i)" by (auto dest: eq_upto_Suc)
  then show ?case by blast
qed

lemma lexmin_SEQ_mem:
  assumes "C \<subseteq> SEQ A" and "C \<noteq> {}"
  shows "lexmin C \<in> SEQ A"
proof -
  { fix i
    let ?X = "ith (eq_upto C (lexmin C) i) i"
    have "?X \<subseteq> A" using assms by (auto simp: ith_def)
    moreover have "?X \<noteq> {}" using eq_upto_lexmin_non_empty [OF assms] by auto
    ultimately have "lexmin C i \<in> A" using min_elt_mem [of ?X] by (subst lexmin) blast }
  then show ?thesis by auto
qed

lemma non_empty_ith:
  assumes "C \<subseteq> SEQ A" and "C \<noteq> {}"
  shows "ith (eq_upto C (lexmin C) i) i \<subseteq> A"
  and "ith (eq_upto C (lexmin C) i) i \<noteq> {}"
using eq_upto_lexmin_non_empty [OF assms, of i] and assms by (auto simp: ith_def)

lemma lexmin_minimal:
  "C \<subseteq> SEQ A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> y \<in> A \<Longrightarrow> P y (lexmin C i) \<Longrightarrow> y \<notin> ith (eq_upto C (lexmin C) i) i"
using min_elt_minimal [OF non_empty_ith, folded lexmin] .

lemma lexmin_mem:
  "C \<subseteq> SEQ A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> lexmin C i \<in> ith (eq_upto C (lexmin C) i) i"
using min_elt_mem [OF non_empty_ith, folded lexmin] .

lemma LEX_chain_on_eq_upto_imp_ith_chain_on:
  assumes "chain_on (LEX P) (eq_upto C f i) (SEQ A)"
  shows "chain_on P (ith (eq_upto C f i) i) A"
using assms
proof -
  { fix x y assume "x \<in> ith (eq_upto C f i) i" and "y \<in> ith (eq_upto C f i) i"
      and "\<not> P x y" and "y \<noteq> x"
    then obtain g h where *: "g \<in> eq_upto C f i" "h \<in> eq_upto C f i"
      and [simp]: "x = g i" "y = h i" and eq: "\<forall>j<i. g j = f j \<and> h j = f j"
      by (auto simp: ith_def eq_upto_def)
    with assms and \<open>y \<noteq> x\<close> consider "LEX P g h" | "LEX P h g" by (force simp: chain_on_def)
    then have "P y x"
    proof (cases)
      assume "LEX P g h"
      with eq and \<open>y \<noteq> x\<close> have "P x y" using assms and *
        by (auto simp: LEX_def)
           (metis SEQ_iff chain_on_imp_subset linorder_neqE_nat minimal subsetCE)
      with \<open>\<not> P x y\<close> show "P y x" ..
    next
      assume "LEX P h g"
      with eq and \<open>y \<noteq> x\<close> show "P y x" using assms and *
        by (auto simp: LEX_def)
           (metis SEQ_iff chain_on_imp_subset linorder_neqE_nat minimal subsetCE)
    qed }
  then show ?thesis using assms by (auto simp: chain_on_def) blast
qed

end

end


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

section \<open>Models of Kleene Algebras\<close>

theory Kleene_Algebra_Models
imports Kleene_Algebra Dioid_Models
begin

text \<open>We now show that most of the models considered for dioids are
also Kleene algebras. Some of the dioid models cannot be expanded, for
instance max-plus and min-plus semirings, but we do not formalise this
fact. We also currently do not show that formal powerseries and
matrices form Kleene algebras.

The interpretation proofs for some of the following models are quite
similar. One could, perhaps, abstract out common reasoning in the
future.\<close>

subsection \<open>Preliminary Lemmas\<close>

text \<open>We first prove two induction-style statements for dioids that
are useful for establishing the full induction laws. In the future
these will live in a theory file on finite sums for Kleene
algebras.\<close>

context dioid_one_zero
begin

lemma power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> (x ^ n) \<cdot> z \<le> y"
proof (induct n)
  case 0 show ?case
    using "0.prems" by auto
  case Suc thus ?case
    by (auto, metis mult.assoc mult_isol order_trans)
qed

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 (* dioid_one_zero *)

subsection \<open>The Powerset Kleene Algebra over a Monoid\<close>

text \<open>We now show that the powerset dioid forms a Kleene
algebra. The Kleene star is defined as in language theory.\<close>

lemma Un_0_Suc: "(\<Union>n. f n) = f 0 \<union> (\<Union>n. f (Suc n))"
by auto (metis not0_implies_Suc)

instantiation set :: (monoid_mult) kleene_algebra
begin

  definition star_def: "X\<^sup>\<star> = (\<Union>n. X ^ n)"

  lemma star_elim: "x \<in> X\<^sup>\<star> \<longleftrightarrow> (\<exists>k. x \<in> X ^ k)"
  by (simp add: star_def)

  lemma star_contl: "X \<cdot> Y\<^sup>\<star> = (\<Union>n. X \<cdot> Y ^ n)"
  by (auto simp add: star_elim c_prod_def)

  lemma star_contr: "X\<^sup>\<star> \<cdot> Y = (\<Union>n. X ^ n \<cdot> Y)"
  by (auto simp add: star_elim c_prod_def)

  instance
  proof
    fix X Y Z :: "'a set"
    show "1 + X \<cdot> X\<^sup>\<star> \<subseteq> X\<^sup>\<star>"
    proof -
      have "1 + X \<cdot> X\<^sup>\<star> = (X ^ 0) \<union> (\<Union>n. X ^ (Suc n))"
        by (auto simp add: star_def c_prod_def plus_set_def one_set_def)
      also have "... = (\<Union>n. X ^ n)"
        by (metis Un_0_Suc)
      also have "... = X\<^sup>\<star>"
        by (simp only: star_def)
      finally show ?thesis
        by (metis subset_refl)
    qed
  next
    fix X Y Z :: "'a set"
    assume hyp: "Z + X \<cdot> Y \<subseteq> Y"
    show  "X\<^sup>\<star> \<cdot> Z \<subseteq> Y"
      by (simp add: star_contr SUP_le_iff) (meson hyp dioid_one_zero_class.power_inductl)
  next
    fix X Y Z :: "'a set"
    assume hyp: "Z + Y \<cdot> X \<subseteq> Y"
    show  "Z \<cdot> X\<^sup>\<star> \<subseteq> Y"
      by (simp add: star_contl SUP_le_iff) (meson dioid_one_zero_class.power_inductr hyp)
  qed

end (* instantiation *)

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

text \<open>We now specialise this fact to languages.\<close>

interpretation lan_kleene_algebra: kleene_algebra "(+)" "(\<cdot>)" "1::'a lan" "0" "(\<subseteq>)" "(\<subset>)" star ..

subsection \<open>Regular Languages\<close>

text \<open>{\ldots} and further to regular languages. For the sake of
simplicity we just copy in the axiomatisation of regular expressions
by Krauss and Nipkow~\cite{krauss12regular}.\<close>

datatype 'a rexp =
  Zero
| One
| Atom 'a
| Plus "'a rexp" "'a rexp"
| Times "'a rexp" "'a rexp"
| Star "'a rexp"

text \<open>The interpretation map that induces regular languages as the
images of regular expressions in the set of languages has also been
adapted from there.\<close>

fun lang :: "'a rexp \<Rightarrow> 'a lan" where
  "lang Zero = 0"  \<comment> \<open>{}\<close>
| "lang One = 1"  \<comment> \<open>{[]}\<close>
| "lang (Atom a) = {[a]}"
| "lang (Plus x y) = lang x + lang y"
| "lang (Times x y) = lang x \<cdot> lang y"
| "lang (Star x) = (lang x)\<^sup>\<star>"

typedef 'a reg_lan = "range lang :: 'a lan set"
  by auto

setup_lifting type_definition_reg_lan

instantiation reg_lan :: (type) kleene_algebra
begin

  lift_definition star_reg_lan :: "'a reg_lan \<Rightarrow> 'a reg_lan"
    is star
    by (metis (hide_lams, no_types) image_iff lang.simps(6) rangeI)

  lift_definition zero_reg_lan :: "'a reg_lan"
    is 0
    by (metis lang.simps(1) rangeI)

  lift_definition one_reg_lan :: "'a reg_lan"
    is 1
    by (metis lang.simps(2) rangeI)

  lift_definition less_eq_reg_lan :: "'a reg_lan \<Rightarrow> 'a reg_lan \<Rightarrow> bool"
    is less_eq .

  lift_definition less_reg_lan :: "'a reg_lan \<Rightarrow> 'a reg_lan \<Rightarrow> bool"
    is less .

  lift_definition plus_reg_lan :: "'a reg_lan \<Rightarrow> 'a reg_lan \<Rightarrow> 'a reg_lan"
    is plus
    by (metis (hide_lams, no_types) image_iff lang.simps(4) rangeI)

  lift_definition times_reg_lan :: "'a reg_lan \<Rightarrow> 'a reg_lan \<Rightarrow> 'a reg_lan"
    is times
    by (metis (hide_lams, no_types) image_iff lang.simps(5) rangeI)

  instance
  proof
    fix x y z :: "'a reg_lan"
    show "x + y + z = x + (y + z)"
      by transfer (metis join_semilattice_class.add_assoc')
    show "x + y = y + x"
      by transfer (metis join_semilattice_class.add_comm)
    show "x \<cdot> y \<cdot> z = x \<cdot> (y \<cdot> z)"
      by transfer (metis semigroup_mult_class.mult.assoc)
    show "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
      by transfer (metis semiring_class.distrib_right)
    show "1 \<cdot> x = x"
      by transfer (metis monoid_mult_class.mult_1_left)
    show "x \<cdot> 1 = x"
      by transfer (metis monoid_mult_class.mult_1_right)
    show "0 + x = x"
      by transfer (metis join_semilattice_zero_class.add_zero_l)
    show "0 \<cdot> x = 0"
      by transfer (metis ab_near_semiring_one_zerol_class.annil)
    show "x \<cdot> 0 = 0"
      by transfer (metis ab_near_semiring_one_zero_class.annir)
    show "x \<le> y \<longleftrightarrow> x + y = y"
      by transfer (metis plus_ord_class.less_eq_def)
    show "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
      by transfer (metis plus_ord_class.less_def)
    show "x + x = x"
      by transfer (metis join_semilattice_class.add_idem)
    show "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
      by transfer (metis semiring_class.distrib_left)
    show "z \<cdot> x \<le> z \<cdot> (x + y)"
      by transfer (metis pre_dioid_class.subdistl)
    show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by transfer (metis star_unfoldl)
    show "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
      by transfer (metis star_inductl)
    show "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
      by transfer (metis star_inductr)
  qed

end  (* instantiation *)

interpretation reg_lan_kleene_algebra: kleene_algebra "(+)" "(\<cdot>)" "1::'a reg_lan" 0 "(\<le>)" "(<)" star ..

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

text \<open>We now show that binary relations form Kleene algebras. While
we could have used the reflexive transitive closure operation as the
Kleene star, we prefer the equivalent definition of the star as the
sum of powers. This essentially allows us to copy previous proofs.\<close>

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_kleene_algebra: 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

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

text \<open>Again, the proof that sets of traces form Kleene algebras
follows the same schema.\<close>

definition t_star :: "('p, 'a) trace set \<Rightarrow> ('p, 'a) trace set" where
  "t_star X \<equiv> \<Union>n. trace_dioid.power X n"

lemma t_star_elim: "x \<in> t_star X \<longleftrightarrow> (\<exists>n. x \<in> trace_dioid.power X n)"
  by (simp add: t_star_def)

lemma t_star_contl: "t_prod X (t_star Y) = (\<Union>n. t_prod X (trace_dioid.power Y n))"
  by (auto simp add: t_star_elim t_prod_def)

lemma t_star_contr: "t_prod (t_star X) Y = (\<Union>n. t_prod (trace_dioid.power X n) Y)"
  by (auto simp add: t_star_elim t_prod_def)

interpretation trace_kleene_algebra: kleene_algebra "(\<union>)" t_prod t_one t_zero "(\<subseteq>)" "(\<subset>)" t_star
proof
  fix X Y Z :: "('a, 'b) trace set"
  show "t_one \<union> t_prod X (t_star X) \<subseteq> t_star X"
    proof -
      have "t_one \<union> t_prod X (t_star X) = (trace_dioid.power X 0) \<union> (\<Union>n. trace_dioid.power X (Suc n))"
        by (auto simp add: t_star_def t_prod_def)
      also have "... = (\<Union>n. trace_dioid.power X n)"
        by (metis Un_0_Suc)
      also have "... = t_star X"
        by (metis t_star_def)
      finally show ?thesis
        by (metis subset_refl)
    qed
  show "Z \<union> t_prod X Y \<subseteq> Y \<Longrightarrow> t_prod (t_star X) Z \<subseteq> Y"
    by (simp only: ball_UNIV t_star_contr SUP_le_iff) (metis trace_dioid.power_inductl)
  show "Z \<union> t_prod Y X \<subseteq> Y \<Longrightarrow> t_prod Z (t_star X) \<subseteq> Y"
    by (simp only: ball_UNIV t_star_contl SUP_le_iff) (metis trace_dioid.power_inductr)
qed

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

text \<open>We start with paths that include the empty path.\<close>

definition p_star :: "'a path set \<Rightarrow> 'a path set" where
  "p_star X \<equiv> \<Union>n. path_dioid.power X n"

lemma p_star_elim: "x \<in> p_star X \<longleftrightarrow> (\<exists>n. x \<in> path_dioid.power X n)"
by (simp add: p_star_def)

lemma p_star_contl: "p_prod X (p_star Y) = (\<Union>n. p_prod X (path_dioid.power Y n))"
apply (auto simp add: p_prod_def p_star_elim)
   apply (metis p_fusion.simps(1))
  apply metis
 apply (metis p_fusion.simps(1) p_star_elim)
apply (metis p_star_elim)
done

lemma p_star_contr: "p_prod (p_star X) Y = (\<Union>n. p_prod (path_dioid.power X n) Y)"
apply (auto simp add: p_prod_def p_star_elim)
   apply (metis p_fusion.simps(1))
  apply metis
 apply (metis p_fusion.simps(1) p_star_elim)
apply (metis p_star_elim)
done

interpretation path_kleene_algebra: kleene_algebra "(\<union>)" p_prod p_one "{}" "(\<subseteq>)" "(\<subset>)" p_star
proof
  fix X Y Z :: "'a path set"
  show "p_one \<union> p_prod X (p_star X) \<subseteq> p_star X"
    proof -
      have "p_one \<union> p_prod X (p_star X) = (path_dioid.power X 0) \<union> (\<Union>n. path_dioid.power X (Suc n))"
        by (auto simp add: p_star_def p_prod_def)
      also have "... = (\<Union>n. path_dioid.power X n)"
        by (metis Un_0_Suc)
      also have "... = p_star X"
        by (metis p_star_def)
      finally show ?thesis
        by (metis subset_refl)
    qed
  show "Z \<union> p_prod X Y \<subseteq> Y \<Longrightarrow> p_prod (p_star X) Z \<subseteq> Y"
    by (simp only: ball_UNIV p_star_contr SUP_le_iff) (metis path_dioid.power_inductl)
  show "Z \<union> p_prod Y X \<subseteq> Y \<Longrightarrow> p_prod Z (p_star X) \<subseteq> Y"
    by (simp only: ball_UNIV p_star_contl SUP_le_iff) (metis path_dioid.power_inductr)
qed

text \<open>We now consider a notion of paths that does not include the
empty path.\<close>

definition pp_star :: "'a ppath set \<Rightarrow> 'a ppath set" where
  "pp_star X \<equiv> \<Union>n. ppath_dioid.power X n"

lemma pp_star_elim: "x \<in> pp_star X \<longleftrightarrow> (\<exists>n. x \<in> ppath_dioid.power X n)"
by (simp add: pp_star_def)

lemma pp_star_contl: "pp_prod X (pp_star Y) = (\<Union>n. pp_prod X (ppath_dioid.power Y n))"
by (auto simp add: pp_prod_def pp_star_elim)

lemma pp_star_contr: "pp_prod (pp_star X) Y = (\<Union>n. pp_prod (ppath_dioid.power X n) Y)"
by (auto simp add: pp_prod_def pp_star_elim)

interpretation ppath_kleene_algebra: kleene_algebra "(\<union>)" pp_prod pp_one "{}" "(\<subseteq>)" "(\<subset>)" pp_star
proof
  fix X Y Z :: "'a ppath set"
  show "pp_one \<union> pp_prod X (pp_star X) \<subseteq> pp_star X"
    proof -
      have "pp_one \<union> pp_prod X (pp_star X) = (ppath_dioid.power X 0) \<union> (\<Union>n. ppath_dioid.power X (Suc n))"
        by (auto simp add: pp_star_def pp_prod_def)
      also have "... = (\<Union>n. ppath_dioid.power X n)"
        by (metis Un_0_Suc)
      also have "... = pp_star X"
        by (metis pp_star_def)
      finally show ?thesis
        by (metis subset_refl)
    qed
  show "Z \<union> pp_prod X Y \<subseteq> Y \<Longrightarrow> pp_prod (pp_star X) Z \<subseteq> Y"
    by (simp only: ball_UNIV pp_star_contr SUP_le_iff) (metis ppath_dioid.power_inductl)
  show "Z \<union> pp_prod Y X \<subseteq> Y \<Longrightarrow> pp_prod Z (pp_star X) \<subseteq> Y"
    by (simp only: ball_UNIV pp_star_contl SUP_le_iff) (metis ppath_dioid.power_inductr)
qed

subsection \<open>The Distributive Lattice Kleene Algebra\<close>

text \<open>In the case of bounded distributive lattices, the star maps
all elements to to the maximal element.\<close>

definition (in bounded_distributive_lattice) bdl_star :: "'a \<Rightarrow> 'a" where
  "bdl_star x = top"

sublocale bounded_distributive_lattice \<subseteq> kleene_algebra sup inf top bot less_eq less bdl_star
proof
  fix x y z :: 'a
  show "sup top (inf x (bdl_star x)) \<le> bdl_star x"
    by (simp add: bdl_star_def)
  show "sup z (inf x y) \<le> y \<Longrightarrow> inf (bdl_star x) z \<le> y"
    by (simp add: bdl_star_def)
  show "sup z (inf y x) \<le> y \<Longrightarrow> inf z (bdl_star x) \<le> y"
    by (simp add: bdl_star_def)
qed

subsection \<open>The Min-Plus Kleene Algebra\<close>

text \<open>One cannot define a Kleene star for max-plus and min-plus
algebras that range over the real numbers. Here we define the star for
a min-plus algebra restricted to natural numbers and~$+\infty$. The
resulting Kleene algebra is commutative. Similar variants can be
obtained for max-plus algebras and other algebras ranging over the
positive or negative integers.\<close>

instantiation pnat :: commutative_kleene_algebra
begin

  definition star_pnat where
    "x\<^sup>\<star> \<equiv> (1::pnat)"

  instance
  proof
    fix x y z :: pnat
    show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by (metis star_pnat_def zero_pnat_top)
    show "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
      by (simp add: star_pnat_def)
    show "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
      by (simp add: star_pnat_def)
    show "x \<cdot> y = y \<cdot> x"
      unfolding times_pnat_def by (cases x, cases y, simp_all)
  qed

end (* instantiation *)

end