theory TreeDemo
imports "$HIPSTER_HOME/IsaHipster"

begin

(* setup Tactic_Data.set_induct_simp *)

datatype 'a Tree =
  Leaf 'a
  | Node "'a Tree""'a Tree"

fun mirror :: "'a Tree => 'a Tree"
where
  "mirror (Leaf x) = Leaf x"
| "mirror (Node l r) = Node (mirror r) (mirror l)"

fun tmap :: "('a => 'b) => 'a Tree => 'b Tree"
where
  "tmap f (Leaf x) = Leaf (f x)"
| "tmap f (Node l r) = Node (tmap f l) (tmap f r)"

(* First call to Hipster: Explore tmap and mirror *)
hipster tmap mirror

fun flat_tree :: "'a Tree => 'a list"
where
  "flat_tree (Leaf x) = [x]"
| "flat_tree (Node l r) = (flat_tree l) @ (flat_tree r)"

(* Second call to Hipster: Explore relation to lists: flat_tree tmap mirror rev map *)

fun rightmost :: "'a Tree \<Rightarrow> 'a"
where
  "rightmost (Leaf x) = x"
| "rightmost (Node l r) = rightmost r"

fun leftmost :: "'a Tree \<Rightarrow> 'a"
where
  "leftmost (Leaf x) = x"
| "leftmost (Node l r) = leftmost l"

(* Explore leftmost rightmost mirror tmap *)

(*
(* Third call to Hipster: hd mirror flat_tree  rightmost leftmost*)
hipster hd mirror flat_tree rightmost leftmost

(* Bug, produces the wrong proof as sledgehammer gives back a simp-proof it
   seems to loose the last line! *)
lemma lemma_ad [thy_expl]: "hd (flat_tree z @ y) = hd (flat_tree z)"
apply (induction z)
apply simp
apply simp
by (simp add: hd_append) (* Misses this!*)

lemma lemma_ae [thy_expl]: "hd (flat_tree y) = leftmost y"
apply (induction y)
apply simp
apply simp
by (metis TreeDemo.lemma_ad)

lemma lemma_af [thy_expl]: "leftmost (mirror y) = rightmost y"
apply (induction y)
apply simp
by simp
*)

(* lemma lemma_ad [thy_expl]: "leftmost (mirror x) = rightmost x"
apply (induction x)
apply simp
by simp

lemma lemma_ae [thy_expl]: "rightmost (mirror x) = leftmost x"
apply (induction x)
apply simp
by simp

lemma lemma_af [thy_expl]: "hd (xs @ xs) = hd xs"
apply (induction xs)
apply simp
by simp

lemma unknown [thy_expl]: "hd (flat_tree x) = leftmost x"
oops

*)

(* FIXME: Bug in translation? *)
(*
fun size :: "'a Tree \<Rightarrow> nat"
where
  "size (Leaf x) = 0"
  | "size (Node l r) = (size l + size r + 1)"
fun size1 :: "'a Tree \<Rightarrow> nat"
where
  "size1 (Leaf x) = 1"
  | "size1 (Node l r) = (size1 l + size1 r)"
*)
(*  hipster  size *) (* TO DO! Make sure + and 0,1 gets transalated back to the right constants*)
(* Issue! These constants are polymorphic! fix fix fix... *)
(*ML{* @{term "nonEmpty ys \<and> true ==> flat_tree x = []"} *} *)

(*

hipster last rev mirror flat_tree rigthmost leftmost
lemma lemma_af [thy_expl]: "last (xs2 @ xs2) = last xs2"
by (tactic {* Hipster_Tacs.induct_simp_metis @{context} @{thms List.last.simps List.rev.simps TreeDemo.mirror.simps TreeDemo.flat_tree.simps TreeDemo.rigthmost.simps TreeDemo.leftmost.simps thy_expl} *})

lemma unknown [thy_expl]: "last (flat_tree x) = rigthmost x"
oops

(* setup{*
Tactic_Data.set_induct_simp;
*}
*)

*)
end


theory NthRoot_Limits
  imports Complex_Main "~~/src/HOL/Number_Theory/Binomial"
begin

text {*

This does not fit into @{text Complex_Main}, as it depends on @{text Binomial}

*}

lemma LIMSEQ_root: "(\<lambda>n. root n n) ----> 1"
proof -
  def x \<equiv> "\<lambda>n. root n n - 1"
  have "x ----> sqrt 0"
  proof (rule tendsto_sandwich[OF _ _ tendsto_const])
    show "(\<lambda>x. sqrt (2 / x)) ----> sqrt 0"
      by (intro tendsto_intros tendsto_divide_0[OF tendsto_const] filterlim_mono[OF filterlim_real_sequentially])
         (simp_all add: at_infinity_eq_at_top_bot)
    { fix n :: nat assume "2 < n"
      have "1 + (real (n - 1) * n) / 2 * x n^2 = 1 + of_nat (n choose 2) * x n^2"
        using `2 < n` unfolding gbinomial_def binomial_gbinomial
        by (simp add: atLeast0AtMost atMost_Suc field_simps real_of_nat_diff numeral_2_eq_2 real_eq_of_nat[symmetric])
      also have "\<dots> \<le> (\<Sum>k\<in>{0, 2}. of_nat (n choose k) * x n^k)"
        by (simp add: x_def)
      also have "\<dots> \<le> (\<Sum>k=0..n. of_nat (n choose k) * x n^k)"
        using `2 < n` by (intro setsum_mono2) (auto intro!: mult_nonneg_nonneg zero_le_power simp: x_def le_diff_eq)
      also have "\<dots> = (x n + 1) ^ n"
        by (simp add: binomial_ring)
      also have "\<dots> = n"
        using `2 < n` by (simp add: x_def)
      finally have "real (n - 1) * (real n / 2 * (x n)\<^sup>2) \<le> real (n - 1) * 1"
        by simp
      then have "(x n)\<^sup>2 \<le> 2 / real n"
        using `2 < n` unfolding mult_le_cancel_left by (simp add: field_simps)
      from real_sqrt_le_mono[OF this] have "x n \<le> sqrt (2 / real n)"
        by simp }
    then show "eventually (\<lambda>n. x n \<le> sqrt (2 / real n)) sequentially"
      by (auto intro!: exI[of _ 3] simp: eventually_sequentially)
    show "eventually (\<lambda>n. sqrt 0 \<le> x n) sequentially"
      by (auto intro!: exI[of _ 1] simp: eventually_sequentially le_diff_eq x_def)
  qed
  from tendsto_add[OF this tendsto_const[of 1]] show ?thesis
    by (simp add: x_def)
qed

lemma LIMSEQ_root_const:
  assumes "0 < c"
  shows "(\<lambda>n. root n c) ----> 1"
proof -
  { fix c :: real assume "1 \<le> c"
    def x \<equiv> "\<lambda>n. root n c - 1"
    have "x ----> 0"
    proof (rule tendsto_sandwich[OF _ _ tendsto_const])
      show "(\<lambda>n. c / n) ----> 0"
        by (intro tendsto_divide_0[OF tendsto_const] filterlim_mono[OF filterlim_real_sequentially])
           (simp_all add: at_infinity_eq_at_top_bot)
      { fix n :: nat assume "1 < n"
        have "1 + x n * n = 1 + of_nat (n choose 1) * x n^1"
          using `1 < n` unfolding gbinomial_def binomial_gbinomial by (simp add: real_eq_of_nat[symmetric])
        also have "\<dots> \<le> (\<Sum>k\<in>{0, 1}. of_nat (n choose k) * x n^k)"
          by (simp add: x_def)
        also have "\<dots> \<le> (\<Sum>k=0..n. of_nat (n choose k) * x n^k)"
          using `1 < n` `1 \<le> c` by (intro setsum_mono2) (auto intro!: mult_nonneg_nonneg zero_le_power simp: x_def le_diff_eq)
        also have "\<dots> = (x n + 1) ^ n"
          by (simp add: binomial_ring)
        also have "\<dots> = c"
          using `1 < n` `1 \<le> c` by (simp add: x_def)
        finally have "x n \<le> c / n"
          using `1 \<le> c` `1 < n` by (simp add: field_simps) }
      then show "eventually (\<lambda>n. x n \<le> c / n) sequentially"
        by (auto intro!: exI[of _ 3] simp: eventually_sequentially)
      show "eventually (\<lambda>n. 0 \<le> x n) sequentially"
        using `1 \<le> c` by (auto intro!: exI[of _ 1] simp: eventually_sequentially le_diff_eq x_def)
    qed
    from tendsto_add[OF this tendsto_const[of 1]] have "(\<lambda>n. root n c) ----> 1"
      by (simp add: x_def) }
  note ge_1 = this

  show ?thesis
  proof cases
    assume "1 \<le> c" with ge_1 show ?thesis by blast
  next
    assume "\<not> 1 \<le> c"
    with `0 < c` have "1 \<le> 1 / c"
      by simp
    then have "(\<lambda>n. 1 / root n (1 / c)) ----> 1 / 1"
      by (intro tendsto_divide tendsto_const ge_1 `1 \<le> 1 / c` one_neq_zero)
    then show ?thesis
      by (rule filterlim_cong[THEN iffD1, rotated 3])
         (auto intro!: exI[of _ 1] simp: eventually_sequentially real_root_divide)
  qed
qed

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_37
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

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

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

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

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

(*fun did not finish the proof*)
function twoThirds :: "Nat => Nat" where
  "twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

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

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
  and nstoogesort2 :: "Nat list => Nat list"
  and nstooge2sort1 :: "Nat list => Nat list" where
  "nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort2 xs) = (isort xs))"
  oops

end


(* Title: Refinement KAT
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsection \<open>Refinement Component\<close>

theory RKAT
  imports "AVC_KAT/VC_KAT"

begin

subsubsection\<open>RKAT: Definition and Basic Properties\<close>

text \<open>A refinement KAT is a KAT expanded by Morgan's specification statement.\<close>

class rkat = kat +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes spec_def:  "x \<le> R p q \<longleftrightarrow> H p x q"

begin

lemma R1: "H p (R p q) q"
  using spec_def by blast

lemma R2: "H p x q \<Longrightarrow> x \<le> R p q"
  by (simp add: spec_def)

subsubsection\<open>Propositional Refinement Calculus\<close>

lemma R_skip: "1 \<le> R p p"
proof -
  have "H p 1 p"
    by (simp add: H_skip)
  thus ?thesis
    by (rule R2)
qed

lemma R_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> R p' q' \<le> R p q"
proof -
  assume h1: "t p \<le> t p'" and h2: "t q' \<le> t q"
  have "H p' (R p' q') q'"
    by (simp add: R1)
  hence "H p (R p' q') q"
    using h1 h2 H_cons_1 H_cons_2 by blast
  thus ?thesis
    by (rule R2)
qed

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
proof -
  have "H p (R p r) r" and "H r (R r q) q"
    by (simp add: R1)+
  hence "H p ((R p r) \<cdot> (R r q)) q"
    by (rule H_seq_swap)
  thus ?thesis
    by (rule R2)
qed

lemma R_cond: "if v then (R (t v \<cdot> t p) q) else (R (n v \<cdot> t p) q) fi \<le> R p q"
proof -
  have "H (t v \<cdot> t p) (R (t v \<cdot> t p) q) q" and "H (n v \<cdot> t p) (R (n v \<cdot> t p) q) q"
    by (simp add: R1)+
  hence "H p (if v then (R (t v \<cdot> t p) q) else (R (n v \<cdot> t p) q) fi) q"
    by (simp add: H_cond n_mult_comm)
 thus ?thesis
    by (rule R2)
qed

lemma R_loop: "while q do (R (t p \<cdot> t q) p) od \<le> R p (t p \<cdot> n q)"
proof -
  have "H (t p \<cdot> t q) (R (t p \<cdot> t q) p)  p"
    by (simp_all add: R1)
  hence "H p (while q do (R (t p \<cdot> t q) p) od) (t p \<cdot> n q)"
    by (simp add: H_loop)
  thus ?thesis
    by (rule R2)
  qed

lemma R_zero_one: "x \<le> R 0 1"
proof -
  have "H 0 x 1"
    by (simp add: H_def)
  thus ?thesis
    by (rule R2)
qed

lemma R_one_zero: "R 1 0 = 0"
proof -
  have "H 1 (R 1 0) 0"
    by (simp add: R1)
  thus ?thesis
    by (simp add: H_def join.le_bot)
qed

end

end


(* Title: Program Correctness Component Based on Modal Kleene Algebra
   Author:  Georg Struth
*)

section \<open>Verification Component Based on Modal Kleene Algebra\<close>

theory MKA
  imports KA Store

begin

subsection \<open>Definitions\<close>

class antidomain_kleene_algebra = kleene_algebra +
  fixes ad :: "'a \<Rightarrow> 'a"
  assumes ad_annil [simp]: "ad x \<cdot> x = 0"
  and ad_local_sub [simp]: "ad (x \<cdot> y) \<le> ad (x \<cdot> ad (ad y))"
  and ad_compl1 [simp]: "ad (ad x) + ad x = 1"

begin

definition dom_op :: "'a \<Rightarrow> 'a" ("do") where
  "do x = ad (ad x)"

definition fdia :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "fdia x y = do (x \<cdot> y)"

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

end

class antirange_kleene_algebra = kleene_algebra +
  fixes ar :: "'a \<Rightarrow> 'a"
  assumes ar_annil [simp]: "x \<cdot> ar x  = 0"
  and ar_local_sub [simp]: "ar (x \<cdot> y) \<le> ar (ar (ar x) \<cdot> y)"
  and ar_compl1 [simp]: "ar (ar x) + ar x = 1"

begin

definition range_op :: "'a \<Rightarrow> 'a" ("ra") where
  "ra x = ar (ar x)"

definition bdia :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "bdia x y = ra (y \<cdot> x)"

definition bbox :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  where
  "bbox x y = ar (ar y \<cdot> x)"

end

class modal_kleene_algebra = antidomain_kleene_algebra + antirange_kleene_algebra

subsection \<open>Formalisation of Opposition Duality\<close>

sublocale antirange_kleene_algebra \<subseteq> op_arka: antidomain_kleene_algebra "(+)" "0" "1" "\<lambda>x y. y \<cdot> x" "(\<le>)" "(<)" _ ar
  rewrites "op_arka.dom_op x = ra x"
  and "op_arka.fdia x y = bdia x y"
  and "op_arka.fbox x y = bbox x y"
proof -
  show "class.antidomain_kleene_algebra (+) 0 1 (\<lambda>x y. y \<cdot> x) (\<le>) (<) star ar"
    by unfold_locales (simp_all add: mult_assoc distr distl star_inductl star_inductr)
  then interpret op_arka: antidomain_kleene_algebra "(+)" "0" "1" "(\<lambda>x y. y \<cdot> x)" "(\<le>)" "(<)" star ar.
  show "op_arka.dom_op x = ra x"
    by (simp add: range_op_def op_arka.dom_op_def)
  show "op_arka.fdia x y = bdia x y"
    by (simp add: bdia_def range_op_def op_arka.dom_op_def op_arka.fdia_def)
  show "op_arka.fbox x y = bbox x y"
    by (simp add: bbox_def op_arka.fbox_def)
qed

sublocale antidomain_kleene_algebra \<subseteq> arka_op: antirange_kleene_algebra "(+)" "0" "1" "(\<lambda>x y. y \<cdot> x)" "(\<le>)" "(<)" star ad
  rewrites "arka_op.range_op x = do x"
  and "arka_op.bdia x y = fdia x y"
  and "arka_op.bbox x y = fbox x y"
proof -
  show "class.antirange_kleene_algebra (+) 0 1 (\<lambda>x y. y \<cdot> x) (\<le>) (<) star ad"
    by unfold_locales (simp_all add: mult_assoc distl distr star_inductl star_inductr)
  then interpret arka_op: antirange_kleene_algebra "(+)" "0" "1" "(\<lambda>x y. y \<cdot> x)" "(\<le>)" "(<)" star ad.
  show "arka_op.range_op x = do x"
    by (simp add: arka_op.range_op_def dom_op_def)
  show "arka_op.bdia x y = fdia x y"
    by (simp add: arka_op.bdia_def arka_op.range_op_def dom_op_def fdia_def)
  show "arka_op.bbox x y = fbox x y"
    by (simp add: arka_op.bbox_def fbox_def)
qed

subsection \<open>Basic Properties\<close>

context antidomain_kleene_algebra
begin

lemma a_subid_aux: "ad x \<cdot> y \<le> y"
  by (metis ad_compl1 add.commute add_ubl mult.left_neutral mult_isor)

lemma d1_a [simp]: "do x \<cdot> x = x"
  unfolding dom_op_def by (metis add_0_right ad_annil ad_compl1 distr mult_1_left)

lemma ad_one [simp]: "ad 1 = 0"
  by (metis ad_annil mult_1_right)

lemma "do 0 = 0"
  by (metis ad_one d1_a local.arka_op.range_op_def local.mult_1_right)

lemma ad_zero [simp]: "ad 0 = 1"
  by (metis ad_one ad_compl1 add_0_right)

lemma ad_compl2 [simp]: "ad x \<cdot> do x = 0"
  by (metis order.antisym arka_op.ar_annil arka_op.ar_local_sub dom_op_def mult_1_left mult_isor zero_least)

lemma ad_d: "(ad x \<cdot> y = 0) = (do x \<cdot> y = y)"
  by (metis ad_compl2 add_commute dom_op_def ad_compl1 add_0_left annil distr mult_1_left mult_assoc)

lemma d_a_closed [simp]: "ad (do x) = ad x"
  by (metis ad_one ad_zero ad_zero d1_a dom_op_def ad_annil ad_compl1 annir distl mult_1_right)

lemma a_idem [simp]: "ad x \<cdot> ad x = ad x"
  by (metis d1_a d_a_closed dom_op_def)

lemma meet_ord: "(ad x \<le> ad y) = (ad x \<cdot> ad y = ad x)"
  by (metis a_subid_aux d1_a d_a_closed dom_op_def order.antisym mult_1_right mult_isol)

lemma d_wloc: "(x \<cdot> y = 0) = (x \<cdot> do y = 0)"
  by (metis a_subid_aux d1_a dom_op_def ad_annil ad_local_sub order.antisym mult_1_right mult_assoc)

lemma gla: "(ad x \<cdot> y = 0) = (ad x \<le> ad y)"
  apply standard
   apply (smt a_subid_aux add_commute d_wloc dom_op_def ad_compl1 add_0_right distl mult_1_right)
  by (metis ad_annil annir mult_assoc meet_ord)

lemma a_local [simp]: "ad (x \<cdot> do y) = ad (x \<cdot> y)"
  by (smt d_wloc gla ad_annil order.antisym mult_assoc)

lemma a_supdist: "ad (x + y) \<le> ad x"
  by (metis gla ad_annil add_0_right add_ubl distl order_def)

lemma a_antitone: "x \<le> y \<Longrightarrow> ad y \<le> ad x"
  by (metis a_supdist order_def)

lemma d_iso: "x \<le> y \<Longrightarrow> do x \<le> do y"
  by (simp add: a_antitone dom_op_def)

lemma d_a_ord: "(do x \<le> do y) = (ad y \<le> ad x)"
  using a_antitone dom_op_def by fastforce

lemma llp: "(do y \<cdot> x = x) = (do x \<le> do y)"
  by (metis a_antitone ad_d d_a_closed dom_op_def gla)

lemma a_comm: "ad x \<cdot> ad y = ad y \<cdot> ad x"
  by (rule order.antisym) (metis a_local a_subid_aux d1_a d_a_closed d_iso dom_op_def eq_refl mult_1_right mult_iso)+

lemma a_closed [simp]: "do (ad x \<cdot> ad y) = ad x \<cdot> ad y"
  by (smt a_comm a_idem a_subid_aux ad_zero d1_a d_a_closed d_iso dom_op_def mult_1_right mult_assoc meet_ord)

lemma a_de_morgan: "ad (ad x \<cdot> ad y) = do x + do y"
  by (simp add: dom_op_def)

lemma d1_sum_var: "x + y \<le> (do x + do y) \<cdot> (x + y)"
  by (simp add: add_commute add_iso add_ubl distl distr)

lemma a_dual_add: "ad (x + y) = ad x \<cdot> ad y"
  apply (rule order.antisym)
  apply (metis a_supdist add_commute  mult_isor meet_ord)
  by (metis a_closed a_de_morgan a_exp a_subid_aux d1_sum_var order.antisym  order_def)

lemma d_add: "do (x + y) = do x + do y"
  by (simp add: a_dual_add dom_op_def)

lemma a_absorb1 [simp]: "ad x \<cdot> (ad x + ad y) = ad x"
  using a_dual_add a_supdist add_commute distl order_def by auto

lemma a_absorb2 [simp]: "ad x + ad x \<cdot> ad y = ad x"
  using a_dual_add a_supdist add_commute order_def by auto

lemma a_dist: "ad x + ad y \<cdot> ad z = (ad x + ad y) \<cdot> (ad x + ad z)"
  by (smt a_absorb1 a_subid_aux abel_semigroup.commute abel_semigroup.left_commute add.abel_semigroup_axioms distl distr order_def)

lemma a_lbl: "ad x \<cdot> ad y \<le> ad x"
  using a_dual_add a_supdist by simp

lemma a_lower: "ad x \<le> ad y \<Longrightarrow> ad x \<le> ad z \<Longrightarrow> ad x \<le> ad y \<cdot> ad z"
  by (simp add: a_dist order_def)

lemma a_glb: "(ad x \<le> ad y \<and> ad x \<le> ad z) = (ad x \<le> ad y \<cdot> ad z)"
  using a_lbl a_lower a_subid_aux dual_order.trans by blast

lemma at_shunt: "(ad x \<cdot> ad y \<le> ad z) = (ad x \<le> do y + ad z)"
  by (metis a_dual_add a_exp gla mult_assoc)

lemma a_comp_dist [simp]: "(ad p + ad q) \<cdot> (do p + ad t) = ad p \<cdot> ad t + do p \<cdot> ad q"
proof-
  have "(ad p + ad q) \<cdot> (do p + ad t) = ad p \<cdot> ad t + do p \<cdot> ad q + (ad p + do p) \<cdot> ad q \<cdot> ad t"
    using a_comm ad_compl2 add_commute add_assoc arka_op.ar_compl1 distl distr dom_op_def by simp
  also have "\<dots> = ad p \<cdot> ad t + do p \<cdot> ad q + ad p \<cdot> ad q \<cdot> ad t + do p \<cdot> ad q \<cdot> ad t"
    by (simp add: add_assoc distr)
  also have "\<dots> = (1 + ad q) \<cdot> ad p \<cdot> ad t + (1 + ad t) \<cdot> do p \<cdot> ad q"
    by (smt a_comm add_commute add.left_commute arka_op.distl arka_op.range_op_def mult.semigroup_axioms mult_1_left semigroup.assoc)
  finally show ?thesis
    by (metis a_absorb2 ad_zero mult_1_left)
qed

lemma pcorrect_if1: "ad p \<cdot> x \<le> x \<cdot> ad q \<Longrightarrow> ad p \<cdot> x \<cdot> do q = 0"
  sorry

lemma pcorrect_if2: "ad p \<cdot> x \<cdot> do q = 0 \<Longrightarrow> ad p \<cdot> x \<cdot> ad q = ad p \<cdot> x"
  sorry

lemma pcorrect_if3: "ad p \<cdot> x = ad p \<cdot> x \<cdot> ad q \<Longrightarrow> ad p \<cdot> x \<le> x \<cdot> ad q"
  sorry

lemma pcorrect_iff1: "(ad p \<cdot> x \<le> x \<cdot> ad q) = (ad p \<cdot> x \<cdot> do q = 0)"
  sorry

lemma pcorrect_iff2: "(ad p \<cdot> x \<cdot> do q = 0) = (ad p \<cdot> x \<cdot> ad q = ad p \<cdot> x)"
  sorry

lemma pcorrect_iff2_op: "(do p \<cdot> x \<cdot> ad q = 0) = (x \<cdot> ad q = ad p \<cdot> x \<cdot> ad q)"
  sorry

lemma pcorrect_iff3_op: "(x \<cdot> ad q = ad p \<cdot> x \<cdot> ad q) = (x \<cdot> ad q \<le> ad p \<cdot> x)"
  sorry

lemma pcorrect_iff1_op: "(x \<cdot> ad q \<le> ad p \<cdot> x) = (do p \<cdot> x \<cdot> ad q = 0)"
  sorry

lemma pcorrect_var: "(ad p \<cdot> x \<le> x \<cdot> ad q) = (x \<cdot> do q \<le> do p \<cdot> x)"
  sorry

lemma pcorrect_var2: "(do p \<cdot> x \<le> x \<cdot> do q) = (x \<cdot> ad q \<le> ad p \<cdot> x)"
  sorry

lemma ad_star [simp]: "ad (x\<^sup>\<star>) = 0"
  sorry

end

context antidomain_kleene_algebra
begin

subsection \<open>Forward Diamond and Box Operators\<close>

lemma fbox_fdia: "fbox x p = ad (fdia x (ad p))"
  sorry

lemma fdia_fbox: "fdia x p = ad (fbox x (ad p))"
  sorry

lemma fdia_demod: "(fdia x y \<le> do z) = (x \<cdot> do y \<le> do z \<cdot> x)"
  sorry

lemma fbox_demod: "(do y \<le> fbox x z) = (do y \<cdot> x  \<le> x \<cdot> do z)"
  sorry

lemma fdia_dom [simp]: "fdia x 1 = do x"
  sorry

lemma fbox_dom [simp]: "fbox x 0 = ad x"
  sorry

lemma fdia_one [simp]: "fdia 1 x = do x"
  sorry

lemma fbox_zero [simp]: "fbox 0 x = 1"
  sorry

lemma fdia_zero_var [simp]: "fdia 0 x = 0"
  sorry

lemma fbox_zero_var [simp]: "fbox 1 x = do x"
  sorry

lemma fbox_one_1 [simp]: "fbox x 1 = 1"
  sorry

lemma fdia_add1: "fdia x (y + z) = fdia x y + fdia x z"
  sorry

lemma fbox_add1: "fbox x (do y \<cdot> do z) = fbox x y \<cdot> fbox x z"
  sorry

lemma fdia_add2: "fdia (x + y) z = fdia x z + fdia y z"
  sorry

lemma fbox_add2: "fbox (x + y) z = fbox x z \<cdot> fbox y z"
  sorry

lemma fdia_comp: "fdia (x \<cdot> y) z = fdia x (fdia y z)"
  sorry

lemma fbox_comp: "fbox (x \<cdot> y) z = fbox x (fbox y z)"
  sorry

lemma fdia_iso1: "do x \<le> do y \<Longrightarrow> fdia z x \<le> fdia z y"
  sorry

lemma fbox_iso: "do x \<le> do y \<Longrightarrow> fbox z x \<le> fbox z y"
  sorry

lemma fdia_iso2: "x \<le> y \<Longrightarrow> fdia x z \<le> fdia y z"
  sorry

lemma fbox_anti: "x \<le> y \<Longrightarrow> fbox y z \<le> fbox x z"
  sorry

lemma fdia_export: "ad y \<cdot> fdia x z = fdia (ad y \<cdot> x) z"
  sorry

lemma fbox_export: "ad y + fbox x y = fbox (do y \<cdot> x) y"
  sorry

lemma fdia_diff: "fdia x (do y \<cdot> ad z) \<le> fdia x y + ad (fdia x z)"
  sorry

lemma fbox_diff: "fbox x (do y + ad z) \<le> fbox x y + ad (fbox x z)"
  sorry

lemma fdia_star_unfoldl [simp]: "fdia 1 y + fdia x (fdia (x\<^sup>\<star>) y) = fdia (x\<^sup>\<star>) y"
  sorry

lemma fbox_star_unfoldl [simp]: "fbox 1 y \<cdot> fbox x (fbox (x\<^sup>\<star>) y) = fbox (x\<^sup>\<star>) y"
  sorry

lemma fdia_star_unfoldr [simp]: "fdia 1 y + fdia (x\<^sup>\<star>) (fdia x y) = fdia (x\<^sup>\<star>) y"
  sorry

lemma fbox_star_unfoldr [simp]: "fbox 1 y \<cdot> fbox (x\<^sup>\<star>) (fbox x y) = fbox (x\<^sup>\<star>) y"
  sorry

lemma fdia_star_inductl_var: "fdia x y \<le> do y \<Longrightarrow> fdia (x\<^sup>\<star>) y \<le> do y"
  sorry

lemma fbox_star_inductl_var: "do y \<le> fbox x y \<Longrightarrow> do y \<le> fbox (x\<^sup>\<star>) y"
  sorry

lemma fdia_star_inductl: "do z + fdia x y \<le> do y \<Longrightarrow> fdia (x\<^sup>\<star>) z \<le> do y"
  sorry

lemma fbox_star_inductl: "do y \<le> do z \<cdot> fbox x y \<Longrightarrow> do y \<le> fbox (x\<^sup>\<star>) z"
  sorry

end

subsection \<open>Compatibility, Galois Connections and Conjugations\<close>

context modal_kleene_algebra
begin

lemma dr_comp_aux1 [simp]: "ar x \<cdot> do (ra x) = 0"
  sorry

lemma dr_comp_aux2 [simp]: "ra x \<cdot> do (ra x) \<cdot> ar x = 0"
  sorry

lemma dr_comp [simp]: "do (ra x) = ra x"
  sorry

lemma rd_comp [simp]: "ra (do x) = do x"
  sorry

lemma do_ra: "(do x = x) = (ra x = x)"
  sorry

lemma do_ra_alg: "{x. do x = x} = {x. ra x = x}"
  sorry

lemma dr_zero: "(x \<cdot> y = 0) = (ra x \<cdot> do y = 0)"
  sorry

lemma fdia_bbox_galois:
  assumes "do p = p" and "do q = q"
  shows "(fdia x p \<le> q) = (p \<le> bbox x q)"
  sorry

lemma dia_conjugation:
  assumes "do p = p" and "do q = q"
  shows "(p \<cdot> fdia x q = 0) = (bdia x p \<cdot> q = 0)"
  sorry

lemma box_conjugation:
  assumes "do p = p" and "do q = q"
  shows "(p + fbox x q = 1) = (bbox x p + q = 1)"
  sorry

end

subsection \<open>Algebraic Laws for VCG\<close>

context antidomain_kleene_algebra
begin

definition cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = do p \<cdot> x + ad p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (do p \<cdot> x)\<^sup>\<star> \<cdot> ad p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma while_if: "while p do x od = if p then x \<cdot> (while p do x od) else 1 fi"
  sorry

lemma fbox_cond: "fbox (if p then x else y fi) q = (ad p + fbox x q) \<cdot> (do p + fbox y q)"
  sorry

lemma fbox_condl: "do p \<cdot> fbox (if p then x else y fi) q = do p \<cdot> fbox x q"
  sorry

lemma fbox_condr: "ad p \<cdot> fbox (if p then x else y fi) q = ad p \<cdot> fbox y q"
  sorry

lemma fbox_cond_var: "fbox (if p then x else y fi) q = (do p \<cdot> fbox x q) + (ad p \<cdot> fbox y q)"
  sorry

lemma fbox_while:
  assumes "do p \<cdot> do t \<le> fbox x p"
  shows "do p \<le> fbox (while t do x od) (do p \<cdot> ad t)"
  sorry

lemma fbox_whilet: "do p \<cdot> fbox (while p do x od) q = do p \<cdot> fbox x (fbox (while p do x od) q)"
  sorry

lemma fbox_whilef: "ad p \<cdot> fbox (while p do x od) q = ad p \<cdot> do q"
  sorry

lemma fbox_while_inv:
  assumes "do p \<le> do i"
  and "do i \<cdot> ad t \<le> do q"
  and "do i \<cdot> do t \<le> fbox x i"
shows "do p \<le> fbox (while t inv i do x od) q"
  sorry

end

subsection \<open>Relation and State Transformer KAD\<close>

definition rel_ad :: "'a rel \<Rightarrow> 'a rel" ("ad\<^sub>r") where
  "rel_ad R = {(x,x) | x. \<not>(\<exists>y. (x,y) \<in> R)}"

interpretation rel_aka: antidomain_kleene_algebra "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl "ad\<^sub>r"
  by unfold_locales (auto simp: rel_ad_def)

definition sta_ad :: "'a sta \<Rightarrow> 'a sta" ("ad\<^sub>s")where
  "sta_ad f x = (if f x = {} then {x} else {})"

interpretation sta_aka: antidomain_kleene_algebra "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar "ad\<^sub>s"
  sorry

lemma rel_d_fix_subid: "(rel_aka.dom_op R = R) = (R \<subseteq> Id)"
  sorry

lemma sta_d_fix_subid: "(sta_aka.dom_op f = f) = (f \<sqsubseteq> \<eta>)"
  sorry

subsection \<open>Optimised Laws for VCG\<close>

abbreviation rcond :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rif _ then _ else _ fi" [64,64,64] 63) where
  "rif P then R else S fi \<equiv> rel_aka.cond \<lceil>P\<rceil>\<^sub>r R S"

abbreviation rwhile :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ do _ od" [64,64] 63) where
  "rwhile P do R od \<equiv> rel_aka.while \<lceil>P\<rceil>\<^sub>r R"

abbreviation rwhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("rwhile _ inv _ do _ od" [64,64,64] 63) where
  "rwhile P inv I do R od \<equiv> rel_aka.while_inv \<lceil>P\<rceil>\<^sub>r \<lceil>I\<rceil>\<^sub>r R"

abbreviation scond :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("sif _ then _ else _ fi" [64,64,64] 63) where
  "sif P then f else g fi \<equiv> sta_aka.cond \<lceil>P\<rceil>\<^sub>s f g"

abbreviation swhile :: "'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ do _ od" [64,64] 63) where
  "swhile P do f od \<equiv> sta_aka.while \<lceil>P\<rceil>\<^sub>s f"

abbreviation swhile_inv :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a sta \<Rightarrow> 'a sta" ("swhile _ inv _ do _ od" [64,64,64] 63) where
  "swhile P inv I do f od \<equiv> sta_aka.while_inv \<lceil>P\<rceil>\<^sub>s \<lceil>I\<rceil>\<^sub>s f"

lemma rel_fbox_subid: "rel_aka.fbox R P \<subseteq> Id"
  sorry

lemma sta_fbox_subid: "sta_aka.fbox f P \<sqsubseteq> \<eta>"
  sorry

lemma rel_dom_pred [simp]: "rel_aka.dom_op \<lceil>P\<rceil>\<^sub>r = \<lceil>P\<rceil>\<^sub>r"
  sorry

lemma rel_ad_pred [simp]: "ad\<^sub>r \<lceil>P\<rceil>\<^sub>r = \<lceil>\<lambda>s. \<not> P s\<rceil>\<^sub>r"
  sorry

lemma sta_dom_pred [simp]: "sta_aka.dom_op \<lceil>P\<rceil>\<^sub>s = \<lceil>P\<rceil>\<^sub>s"
  sorry

lemma sta_ad_pred [simp]: "ad\<^sub>s \<lceil>P\<rceil>\<^sub>s = \<lceil>\<lambda>s. \<not> P s\<rceil>\<^sub>s"
  sorry

abbreviation "rfbox R Q \<equiv> \<lfloor>rel_aka.fbox R \<lceil>Q\<rceil>\<^sub>r\<rfloor>\<^sub>r"

abbreviation "sfbox R Q \<equiv> \<lfloor>sta_aka.fbox R \<lceil>Q\<rceil>\<^sub>s\<rfloor>\<^sub>s"

lemma rfbox_p2r2p: "rel_aka.fbox R \<lceil>P\<rceil>\<^sub>r = \<lceil>rfbox R P\<rceil>\<^sub>r"
  sorry

lemma sfbox_p2s2p: "sta_aka.fbox R \<lceil>P\<rceil>\<^sub>s = \<lceil>sfbox R P\<rceil>\<^sub>s"
  sorry

lemma rfbox_unfold: "rfbox R P s = (\<forall>s'. (s,s') \<in> R \<longrightarrow> P s')"
  sorry

lemma sfbox_unfold: "sfbox f P s = (\<forall>s'. s' \<in> f s \<longrightarrow> P s')"
  sorry

lemma rfbox_seq [simp]: "rfbox (R ; S) P s = rfbox R (rfbox S P) s"
  sorry

lemma rfbox_seq_var:
  assumes "\<forall>s. w s \<longrightarrow> rfbox y z s"
   and "\<forall>s. v s \<longrightarrow> rfbox x w s"
  shows "\<forall>s. v s \<longrightarrow> rfbox (x ; y) z s"
  sorry

lemma sfbox_seq [simp]: "sfbox (f \<circ>\<^sub>K g) P s = sfbox f (sfbox g P) s"
  sorry

lemma sfbox_seq_var:
  assumes "\<forall>s. w s \<longrightarrow> sfbox y z s"
  and "\<forall>s. v s \<longrightarrow> sfbox x w s"
  shows "\<forall>s. v s \<longrightarrow> sfbox (x \<circ>\<^sub>K y) z s"
  sorry

lemma rfbox_cond [simp]: "rfbox (rif P then R else S fi) Q s = ((P s \<longrightarrow> rfbox R Q s) \<and> (\<not> P s \<longrightarrow> rfbox S Q s))"
  sorry

lemma rfbox_cond_var: "rfbox (rif P then R else S fi) Q s = ((P s \<and> rfbox R Q s) \<or>  (\<not> P s \<and> rfbox S Q s))"
  sorry

lemma sfbox_cond [simp]: "sfbox (sif P then f else g fi) Q s = ((P s \<longrightarrow> sfbox f Q s) \<and> (\<not> P s \<longrightarrow> sfbox g Q s))"
  sorry

lemma sfbox_cond_var: "sfbox (sif P then f else g fi) Q s = ((P s \<and> sfbox f Q s) \<or>  (\<not> P s \<and> sfbox g Q s))"
  sorry

lemma rfbox_while_inv:
  assumes "\<forall>s. P s \<longrightarrow> I s"
  and "\<forall>s. I s \<longrightarrow> \<not> T s \<longrightarrow> Q s"
  and "\<forall>s. I s \<longrightarrow> T s \<longrightarrow> rfbox R I s"
  shows "\<forall>s. P s \<longrightarrow> rfbox (rwhile T inv I do R od) Q s"
  sorry

lemma sfbox_while_inv:
  assumes "\<forall>s. P s \<longrightarrow> I s"
  and "\<forall>s. I s \<longrightarrow> \<not> T s \<longrightarrow> Q s"
  and "\<forall>s. I s \<longrightarrow> T s \<longrightarrow> sfbox f I s"
  shows "\<forall>s. P s \<longrightarrow> sfbox (swhile T inv I do f od) Q s"
  sorry

lemma rfbox_while_inv_break:
  assumes "\<forall>s. P s \<longrightarrow> rfbox S I s"
  and "\<forall>s. I s \<longrightarrow> \<not> T s \<longrightarrow> Q s"
  and "\<forall>s. I s \<longrightarrow>  T s \<longrightarrow> rfbox R I s"
  shows "\<forall>s. P s \<longrightarrow> rfbox (S ; (rwhile T inv I do R od)) Q s"
  sorry

lemma sfbox_while_inv_break:
  assumes "\<forall>s. P s \<longrightarrow> sfbox g I s"
  and "\<forall>s. I s \<longrightarrow> \<not> T s \<longrightarrow> Q s"
  and "\<forall>s. I s \<longrightarrow>  T s \<longrightarrow> sfbox f I s"
  shows "\<forall>s. P s \<longrightarrow> sfbox (g \<circ>\<^sub>K (swhile T inv I do f od)) Q s"
  sorry

subsection \<open>Store and Assignment Semantics\<close>

text \<open>We reuse the store from KAT\<close>

lemma mka_rel_assign [simp]: "rel_aka.fbox (v :=\<^sub>r e) \<lceil>Q\<rceil>\<^sub>r = \<lceil>Q \<circ> (set v e)\<rceil>\<^sub>r"
  sorry

lemma mka_sta_assign [simp]: "sta_aka.fbox (v :=\<^sub>s e) \<lceil>Q\<rceil>\<^sub>s = \<lceil>Q \<circ> (set v e)\<rceil>\<^sub>s"
  sorry

lemma rfbox_assign [simp]: "rfbox (v :=\<^sub>r e) Q  = Q \<circ> (set v e)"
  sorry

lemma sfbox_assign [simp]: "sfbox (v :=\<^sub>s e) Q  = Q \<circ> (set v e)"
  sorry

subsection \<open>Examples\<close>

lemma svar_swap:
  "s ''x'' = m \<and> s ''y'' = n \<Longrightarrow>
    sfbox ((''z'' :=\<^sub>s (\<lambda>s. s ''x''))\<circ>\<^sub>K
    (''x'' :=\<^sub>s (\<lambda>s. s ''y''))\<circ>\<^sub>K
    (''y'' :=\<^sub>s (\<lambda>s. s ''z'')))
   (\<lambda>s. s ''x'' = n \<and> s ''y'' = m) s"
  sorry

lemma rvar_swap:
  "s ''x'' = m \<and> s ''y'' = n \<Longrightarrow>
    rfbox ((''z'' :=\<^sub>r (\<lambda>s. s ''x''));
    (''x'' :=\<^sub>r (\<lambda>s. s ''y''));
    (''y'' :=\<^sub>r (\<lambda>s. s ''z'')))
   (\<lambda>s. s ''x'' = n \<and> s ''y'' = m) s"
  sorry

lemma rmaximum:
  "\<forall>s::int store.
   rfbox (rif (\<lambda>s. s ''x'' \<ge> s ''y'')
    then (''z'' :=\<^sub>r (\<lambda>s. s ''x''))
    else (''z'' :=\<^sub>r (\<lambda>s. s ''y''))
    fi)
   (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')) s"
  sorry

lemma smaximum:
  "\<forall>s::int store.
   sfbox (sif (\<lambda>s. s ''x'' \<ge> s ''y'')
    then (''z'' :=\<^sub>s (\<lambda>s. s ''x''))
    else (''z'' :=\<^sub>s (\<lambda>s. s ''y''))
    fi)
   (\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')) s"
  sorry

lemma rinteger_division:
"\<forall>s::nat store. 0 < y \<longrightarrow>
    rfbox ((''q'' :=\<^sub>r (\<lambda>s. 0));
    (''r'' :=\<^sub>r (\<lambda>s. x));
    (rwhile (\<lambda>s. y \<le> s ''r'') inv (\<lambda>s. x = s ''q'' * y + s ''r'')
     do
      (''q'' :=\<^sub>r (\<lambda>s. s ''q'' + 1)) ;
      (''r'' :=\<^sub>r (\<lambda>s. s ''r'' - y))
     od))
  (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' < y) s"
  sorry

lemma sinteger_division:
"\<forall>s::nat store. 0 < y \<longrightarrow>
    sfbox ((''q'' :=\<^sub>s (\<lambda>s. 0)) \<circ>\<^sub>K
    (''r'' :=\<^sub>s (\<lambda>s. x))  \<circ>\<^sub>K
    (swhile (\<lambda>s. y \<le> s ''r'') inv (\<lambda>s. x = s ''q'' * y + s ''r'')
     do
      (''q'' :=\<^sub>s (\<lambda>s. s ''q'' + 1)) \<circ>\<^sub>K
      (''r'' :=\<^sub>s (\<lambda>s. s ''r'' - y))
     od))
  (\<lambda>s. x = s ''q'' * y + s ''r'' \<and> s ''r'' < y) s"
  sorry

end


(* 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_ISortCount
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 count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (isort xs)) = (count x xs))"
  oops

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Galois Connections\<close>
theory Galois_Connections
  imports
    Galois_Property
begin

context galois
begin

definition "galois_connection \<equiv>
  ((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l \<and> ((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r \<and> ((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"

notation galois.galois_connection (infix "\<stileturn>" 50)

lemma galois_connectionI [intro]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l" and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding galois_connection_def using assms by blast

lemma galois_connectionE [elim]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  obtains "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l" "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r" "((\<le>\<^bsub>L\<^esub>) \<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms unfolding galois_connection_def by blast

context
begin

interpretation g : galois S T f g for S T f g.

lemma rel_inv_galois_connection_eq_galois_connection_rel_inv [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<stileturn> (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<ge>\<^bsub>L\<^esub>) \<stileturn> (\<ge>\<^bsub>R\<^esub>))"
  by (intro ext) blast

corollary galois_connection_rel_inv_iff_galois_connection [iff]:
  "((\<ge>\<^bsub>L\<^esub>) \<stileturn> (\<ge>\<^bsub>R\<^esub>)) l r \<longleftrightarrow> ((\<le>\<^bsub>R\<^esub>) \<stileturn> (\<le>\<^bsub>L\<^esub>)) r l"
  by (simp flip: rel_inv_galois_connection_eq_galois_connection_rel_inv)

lemma rel_unit_if_left_rel_if_galois_connection:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "x \<le>\<^bsub>L\<^esub> x'"
  shows "x \<le>\<^bsub>L\<^esub> \<eta> x'"
  using assms
  by (blast intro: rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel)

end

lemma counit_rel_if_right_rel_if_galois_connection:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "y \<le>\<^bsub>R\<^esub> y'"
  shows "\<epsilon> y \<le>\<^bsub>R\<^esub> y'"
  using assms
  by (blast intro: counit_rel_if_right_rel_if_half_galois_prop_left_if_mono_wrt_rel)

lemma rel_unit_if_reflexive_on_if_galois_connection:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  and "P x"
  shows "x \<le>\<^bsub>L\<^esub> \<eta> x"
  using assms
  by (blast intro: rel_unit_if_reflexive_on_if_half_galois_prop_right_if_mono_wrt_rel)

lemma counit_rel_if_reflexive_on_if_galois_connection:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  and "P y"
  shows "\<epsilon> y \<le>\<^bsub>R\<^esub> y"
  using assms
  by (blast intro: counit_rel_if_reflexive_on_if_half_galois_prop_left_if_mono_wrt_rel)

lemma inflationary_on_unit_if_reflexive_on_if_galois_connection:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms
  by (blast intro: inflationary_on_unit_if_reflexive_on_if_half_galois_prop_rightI)

lemma deflationary_on_counit_if_reflexive_on_if_galois_connection:
  fixes P :: "'b \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  shows "deflationary_on P (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  using assms
  by (blast intro: deflationary_on_counit_if_reflexive_on_if_half_galois_prop_leftI)

end

end


theory Directed_Walk
  imports
    Directed_Multigraph
    Graph_Theory.Rtrancl_On
begin

type_synonym ('a, 'b) walk = "('a, 'b) edge list"

inductive walk :: "('a, 'b) multigraph \<Rightarrow> ('a, 'b) walk \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  walk_Nil: "v \<in> V G \<Longrightarrow> walk G [] v v" |
  walk_Cons: "\<lbrakk> e \<in> G; walk G es (head e) v \<rbrakk> \<Longrightarrow> walk G (e # es) (tail e) v"

inductive_simps walk_Nil_iff: "walk G [] u v"
inductive_simps walk_Cons_iff: "walk G (e # es) u v"

lemma walk_iff:
  assumes "p \<noteq> []"
  shows "walk G p u v \<longleftrightarrow> hd p \<in> G \<and> walk G (tl p) (head (hd p)) v \<and> tail (hd p) = u"
  using assms
  by (cases p) (auto simp add: walk_Cons_iff)

lemma walk_singletonI:
  assumes "e \<in> G"
  shows "walk G [e] (tail e) (head e)"
  using assms
  by (auto simp add: walk_Cons_iff walk_Nil_iff dest: head_mem_V)

lemma walk_singleton_iff:
  shows "walk G [e] u v \<longleftrightarrow> e \<in> G \<and> endpoints e = (u, v)"
  by (auto simp add: walk_Cons_iff tail_def head_def walk_Nil_iff dest: head_mem_V)

(*
inductive walk :: "('a, 'b) multigraph \<Rightarrow> ('a, 'b) walk \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  walk_Nil: "v \<in> V G \<Longrightarrow> walk G [] v v" |
  walk_Cons: "e \<in> G \<Longrightarrow> walk G [e] (tail e) (head e)" |
  walk_Cons_Cons: "\<lbrakk> e \<in> G; e' \<in> G; tail e' = head e; walk G (e' # es) (tail e') v \<rbrakk> \<Longrightarrow>
                   walk G (e # e' # es) (tail e) v"

inductive_simps walk_Nil_iff [simp]: "walk G [] u v"
inductive_simps walk_Cons_iff [simp]: "walk G [e] u v"
inductive_simps walk_Cons_Cons_iff [simp]: "walk G (e # e' # es) u v"
*)

lemma hd_vertex_mem_V:
  assumes "walk G p u v"
  shows "u \<in> V G"
  using assms
  by (cases p) (auto simp add: walk_Nil_iff walk_Cons_iff dest: tail_mem_V)

lemma last_vertex_mem_V:
  assumes "walk G p u v"
  shows "v \<in> V G"
  using assms
  by (induct p arbitrary: u) (auto simp add: walk_Nil_iff walk_Cons_iff dest: tail_mem_V)

fun walk_vertices :: "('a, 'b) walk \<Rightarrow> 'b \<Rightarrow> 'b list" where
  "walk_vertices [] v = [v]" |
  "walk_vertices (e # es) _ = tail e # walk_vertices es (head e)"

lemma walk_vertices_non_empty:
  shows "walk_vertices p v \<noteq> []"
  by (cases p) simp_all

lemma walk_vertices_cong:
  shows "walk_vertices p v = (if p = [] then [v] else map tail p @ [head (last p)])"
  by (induct p arbitrary: v) simp_all

lemma walk_vertices_cong_2:
  assumes "walk G p u v"
  shows "walk_vertices p u = (if p = [] then [u] else tail (hd p) # map head p)"
  using assms
  by (induct p arbitrary: u) (auto simp add: walk_iff)

lemma dinstinct_walk_vertices_imp_distinct:
  assumes "distinct (walk_vertices p u)"
  shows "distinct p"
  using assms
  by (cases p) (auto simp add: walk_vertices_cong distinct_map)

definition hd_vertex :: "('a, 'b) walk \<Rightarrow> 'b \<Rightarrow> 'b" where
  "hd_vertex p v \<equiv> hd (walk_vertices p v)"

definition last_vertex :: "('a, 'b) walk \<Rightarrow> 'b \<Rightarrow> 'b" where
  "last_vertex p v \<equiv> last (walk_vertices p v)"

lemma hd_vertex_eq:
  assumes "walk G p u v"
  shows "hd_vertex p u = u"
  using assms
  by (cases p) (simp_all add: walk_Cons_iff hd_vertex_def)

lemma last_vertex_eq:
  assumes "walk G p u v"
  shows "last_vertex p u = v"
  using assms
proof (induct p arbitrary: u)
  case Nil
  thus ?case
    by (simp add: walk_Nil_iff last_vertex_def)
next
  case (Cons e es)
  thus ?case
    using walk_vertices_non_empty
    by (fastforce simp add: walk_Cons_iff last_vertex_def)
qed

lemma walk_append_iff:
  shows "walk G (p @ p') u v \<longleftrightarrow> walk G p u (last_vertex p u) \<and> walk G p' (last_vertex p u) v"
proof (induct p arbitrary: u)
  case Nil
  thus ?case
    by (auto simp add: walk_Nil_iff last_vertex_def dest: hd_vertex_mem_V)
next
  case (Cons e es)
  thus ?case
    using walk_vertices_non_empty
    by (fastforce simp add: walk_Cons_iff last_vertex_def)
qed

lemma walk_snoc_iff:
  shows "walk G (p @ [e]) u v \<longleftrightarrow> walk G p u (tail e) \<and> e \<in> G \<and> head e = v"
  by (fastforce simp add: walk_append_iff walk_singleton_iff tail_def head_def last_vertex_eq)

lemma walk_snocD:
  assumes "walk G (p @ [e]) u v"
  shows
    "walk G p u (tail e)"
    "e \<in> G"
    "head e = v"
  using assms
  by (simp_all add: walk_snoc_iff)

(* TODO: Beautify. *)
lemma walk_vertices_snoc:
  assumes "walk G (es @ [e]) u v"
  shows "walk_vertices (es @ [e]) x = walk_vertices es (tail e) @ [head e]"
  using assms
  by (metis (no_types, lifting) append_self_conv2 last_vertex_def last_vertex_eq list.simps(9) map_append snoc_eq_iff_butlast walk_snoc_iff walk_vertices_cong)

definition reachable :: "('a, 'b) multigraph \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "reachable G u v \<equiv> (u, v) \<in> rtrancl_on (V G) (endpoints ` G)"

lemma reachableE:
  assumes "reachable G u v"
  obtains p where
    "walk G p u v"
  using assms
  unfolding reachable_def
proof (induct rule: rtrancl_on.induct)
  case (rtrancl_on_refl v)
  thus ?case
    by (fast intro: walk_Nil)
next
  case (rtrancl_on_into_rtrancl_on u v w)
  thus ?case
    using walk_append_iff walk_singleton_iff last_vertex_eq
    by fastforce
qed

lemma reachableI:
  assumes "walk G p u v"
  shows "reachable G u v"
  using assms
  unfolding reachable_def
proof (induct arbitrary: v rule: rev_induct)
  case Nil
  thus ?case
    by (simp add: walk_Nil_iff)
next
  case (snoc e es)
  show ?case
  proof (rule rtrancl_on_into_rtrancl_on[where ?b = "tail e"], goal_cases)
    case 1
    show ?case
      using snoc.prems
      by (auto simp add: walk_snoc_iff intro: snoc.hyps)
  next
    case 2
    thus ?case
      using snoc.prems
      by (auto simp add: walk_snoc_iff dest: mem_ED)
  next
    case 3
    then show ?case
      using snoc.prems
      by (fast dest: last_vertex_mem_V)
  qed
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Several Locales for Homomorphisms Between Types.\<close>

theory Ring_Hom
imports
  HOL.Complex
  Main
  "HOL-Library.Multiset"
  "HOL-Computational_Algebra.Factorial_Ring"
begin

hide_const (open) mult

text \<open>
Many standard operations can be interpreted as homomorphisms in some sense.
Since declaring some lemmas as [simp] will interfere with existing simplification rules,
we introduce named theorems that would be added to the simp set when necessary.

The following collects distribution lemmas for homomorphisms.
Its symmetric version can often be useful.\<close>
named_theorems hom_distribs

subsection \<open>Basic Homomorphism Locales\<close>

locale zero_hom =
  fixes hom :: "'a :: zero \<Rightarrow> 'b :: zero"
  assumes hom_zero[simp]: "hom 0 = 0"

locale one_hom =
  fixes hom :: "'a :: one \<Rightarrow> 'b :: one"
  assumes hom_one[simp]: "hom 1 = 1"

locale times_hom =
  fixes hom :: "'a :: times \<Rightarrow> 'b :: times"
  assumes hom_mult[hom_distribs]: "hom (x * y) = hom x * hom y"

locale plus_hom =
  fixes hom :: "'a :: plus \<Rightarrow> 'b :: plus"
  assumes hom_add[hom_distribs]: "hom (x + y) = hom x + hom y"

locale semigroup_mult_hom =
  times_hom hom for hom :: "'a :: semigroup_mult \<Rightarrow> 'b :: semigroup_mult"

locale semigroup_add_hom =
  plus_hom hom for hom :: "'a :: semigroup_add \<Rightarrow> 'b :: semigroup_add"

locale monoid_mult_hom = one_hom hom + semigroup_mult_hom hom
  for hom :: "'a :: monoid_mult \<Rightarrow> 'b :: monoid_mult"
begin
  text \<open>Homomorphism distributes over product:\<close>
  lemma hom_prod_list: "hom (prod_list xs) = prod_list (map hom xs)"
    by (induct xs, auto simp: hom_distribs)
  text \<open>but since it introduces unapplied @{term hom}, the reverse direction would be simp.\<close>
  lemmas prod_list_map_hom[simp] = hom_prod_list[symmetric]
  lemma hom_power[hom_distribs]: "hom (x ^ n) = hom x ^ n"
    by (induct n, auto simp: hom_distribs)
end

locale monoid_add_hom = zero_hom hom + semigroup_add_hom hom
  for hom :: "'a :: monoid_add \<Rightarrow> 'b :: monoid_add"
begin
  lemma hom_sum_list: "hom (sum_list xs) = sum_list (map hom xs)"
    by (induct xs, auto simp: hom_distribs)
  lemmas sum_list_map_hom[simp] = hom_sum_list[symmetric]
  lemma hom_add_eq_zero: assumes "x + y = 0" shows "hom x + hom y = 0"
  proof -
    have "0 = x + y" using assms..
    hence "hom 0 = hom (x + y)" by simp
    thus ?thesis by (auto simp: hom_distribs)
  qed
end

locale group_add_hom = monoid_add_hom hom
  for hom :: "'a :: group_add \<Rightarrow> 'b :: group_add"
begin
  lemma hom_uminus[hom_distribs]: "hom (-x) = - hom x"
    by (simp add: eq_neg_iff_add_eq_0 hom_add_eq_zero)
  lemma hom_minus [hom_distribs]: "hom (x - y) = hom x - hom y"
    unfolding diff_conv_add_uminus hom_distribs..
end

subsection \<open>Commutativity\<close>

locale ab_semigroup_mult_hom = semigroup_mult_hom hom
  for hom :: "'a :: ab_semigroup_mult \<Rightarrow> 'b :: ab_semigroup_mult"

locale ab_semigroup_add_hom = semigroup_add_hom hom
  for hom :: "'a :: ab_semigroup_add \<Rightarrow> 'b :: ab_semigroup_add"

locale comm_monoid_mult_hom = monoid_mult_hom hom
  for hom :: "'a :: comm_monoid_mult \<Rightarrow> 'b :: comm_monoid_mult"
begin
  sublocale ab_semigroup_mult_hom..
  lemma hom_prod[hom_distribs]: "hom (prod f X) = (\<Prod>x \<in> X. hom (f x))"
    by (cases "finite X", induct rule:finite_induct; simp add: hom_distribs)
  lemma hom_prod_mset: "hom (prod_mset X) = prod_mset (image_mset hom X)"
    by (induct X, auto simp: hom_distribs)
  lemmas prod_mset_image[simp] = hom_prod_mset[symmetric]
  lemma hom_dvd[intro,simp]: assumes "p dvd q" shows "hom p dvd hom q"
  proof -
    from assms obtain r where "q = p * r" unfolding dvd_def by auto
    from arg_cong[OF this, of hom] show ?thesis unfolding dvd_def by (auto simp: hom_distribs)
  qed

locale comm_monoid_add_hom = monoid_add_hom hom
  for hom :: "'a :: comm_monoid_add \<Rightarrow> 'b :: comm_monoid_add"
begin
  sublocale ab_semigroup_add_hom..
  lemma hom_sum[hom_distribs]: "hom (sum f X) = (\<Sum>x \<in> X. hom (f x))"
    by (cases "finite X", induct rule:finite_induct; simp add: hom_distribs)
  lemma hom_sum_mset[hom_distribs,simp]: "hom (sum_mset X) = sum_mset (image_mset hom X)"
    by (induct X, auto simp: hom_distribs)
end

locale ab_group_add_hom = group_add_hom hom
  for hom :: "'a :: ab_group_add \<Rightarrow> 'b :: ab_group_add"
begin
  sublocale comm_monoid_add_hom..
end

locale semiring_hom = comm_monoid_add_hom hom + monoid_mult_hom hom
  for hom :: "'a :: semiring_1 \<Rightarrow> 'b :: semiring_1"
begin
  lemma hom_mult_eq_zero: assumes "x * y = 0" shows "hom x * hom y = 0"
  proof -
    have "0 = x * y" using assms..
    hence "hom 0 = hom (x * y)" by simp
    thus ?thesis by (auto simp:hom_distribs)
  qed
end

locale ring_hom = semiring_hom hom
  for hom :: "'a :: ring_1 \<Rightarrow> 'b :: ring_1"
begin
  sublocale ab_group_add_hom hom..
end

locale comm_semiring_hom = semiring_hom hom
  for hom :: "'a :: comm_semiring_1 \<Rightarrow> 'b :: comm_semiring_1"
begin
  sublocale comm_monoid_mult_hom..
end

locale comm_ring_hom = ring_hom hom
  for hom :: "'a :: comm_ring_1 \<Rightarrow> 'b :: comm_ring_1"
begin
  sublocale comm_semiring_hom..
end

locale idom_hom = comm_ring_hom hom
  for hom :: "'a :: idom \<Rightarrow> 'b :: idom"

subsection \<open>Division\<close>

locale idom_divide_hom = idom_hom hom
  for hom :: "'a :: idom_divide \<Rightarrow> 'b :: idom_divide" +
  assumes hom_div[hom_distribs]: "hom (x div y) = hom x div hom y"
begin

end

locale field_hom = idom_hom hom
  for hom :: "'a :: field \<Rightarrow> 'b :: field"
begin

  lemma hom_inverse[hom_distribs]: "hom (inverse x) = inverse (hom x)"
    by (metis hom_mult hom_one hom_zero inverse_unique inverse_zero right_inverse)

  sublocale idom_divide_hom hom
  proof
    fix x y
    have "hom (x / y) = hom (x * inverse y)" by (simp add: field_simps)
    thus "hom (x / y) = hom x / hom y" unfolding hom_distribs by (simp add: field_simps)
  qed

end

locale field_char_0_hom = field_hom hom
  for hom :: "'a :: field_char_0 \<Rightarrow> 'b :: field_char_0"

subsection \<open>(Partial) Injectivitiy\<close>

locale zero_hom_0 = zero_hom +
  assumes hom_0: "\<And>x. hom x = 0 \<Longrightarrow> x = 0"
begin
  lemma hom_0_iff[iff]: "hom x = 0 \<longleftrightarrow> x = 0" using hom_0 by auto
end

locale one_hom_1 = one_hom +
  assumes hom_1: "\<And>x. hom x = 1 \<Longrightarrow> x = 1"
begin
  lemma hom_1_iff[iff]: "hom x = 1 \<longleftrightarrow> x = 1" using hom_1 by auto
end

text \<open>Next locales are at this point not interesting.
  They will retain some results when we think of polynomials.
\<close>
locale monoid_mult_hom_1 = monoid_mult_hom + one_hom_1

locale monoid_add_hom_0 = monoid_add_hom + zero_hom_0

locale comm_monoid_mult_hom_1 = monoid_mult_hom_1 hom
  for hom :: "'a :: comm_monoid_mult \<Rightarrow> 'b :: comm_monoid_mult"

locale comm_monoid_add_hom_0 = monoid_add_hom_0 hom
  for hom :: "'a :: comm_monoid_add \<Rightarrow> 'b :: comm_monoid_add"

locale injective =
  fixes f :: "'a \<Rightarrow> 'b" assumes injectivity: "\<And>x y. f x = f y \<Longrightarrow> x = y"
begin
  lemma eq_iff[simp]: "f x = f y \<longleftrightarrow> x = y" using injectivity by auto
  lemma inj_f: "inj f" by (auto intro: injI)
  lemma inv_f_f[simp]: "inv f (f x) = x" by (fact inv_f_f[OF inj_f])
end

locale inj_zero_hom = zero_hom + injective hom
begin
  sublocale zero_hom_0 by (unfold_locales, auto intro: injectivity)
end

locale inj_one_hom = one_hom + injective hom
begin
  sublocale one_hom_1 by (unfold_locales, auto intro: injectivity)
end

locale inj_semigroup_mult_hom = semigroup_mult_hom + injective hom

locale inj_semigroup_add_hom = semigroup_add_hom + injective hom

locale inj_monoid_mult_hom = monoid_mult_hom + inj_semigroup_mult_hom
begin
  sublocale inj_one_hom..
  sublocale monoid_mult_hom_1..
end

locale inj_monoid_add_hom = monoid_add_hom + inj_semigroup_add_hom
begin
  sublocale inj_zero_hom..
  sublocale monoid_add_hom_0..
end

locale inj_comm_monoid_mult_hom = comm_monoid_mult_hom + inj_monoid_mult_hom
begin
  sublocale comm_monoid_mult_hom_1..
end

locale inj_comm_monoid_add_hom = comm_monoid_add_hom + inj_monoid_add_hom
begin
  sublocale comm_monoid_add_hom_0..
end

locale inj_semiring_hom = semiring_hom + injective hom
begin
  sublocale inj_comm_monoid_add_hom + inj_monoid_mult_hom..
end

locale inj_comm_semiring_hom = comm_semiring_hom + inj_semiring_hom
begin
  sublocale inj_comm_monoid_mult_hom..
end

text \<open>For groups, injectivity is easily ensured.\<close>
locale inj_group_add_hom = group_add_hom + zero_hom_0
begin
  sublocale injective hom
  proof
    fix x y assume "hom x = hom y"
    then have "hom (x-y) = 0" by (auto simp: hom_distribs)
    then show "x = y" by simp
  qed
  sublocale inj_monoid_add_hom..
end

locale inj_ab_group_add_hom = ab_group_add_hom + inj_group_add_hom
begin
  sublocale inj_comm_monoid_add_hom..
end

locale inj_ring_hom = ring_hom + zero_hom_0
begin
  sublocale inj_ab_group_add_hom..
  sublocale inj_semiring_hom..
end

locale inj_comm_ring_hom = comm_ring_hom + zero_hom_0
begin
  sublocale inj_ring_hom..
  sublocale inj_comm_semiring_hom..
end

locale inj_idom_hom = idom_hom + zero_hom_0
begin
  sublocale inj_comm_ring_hom..
end

text \<open>Field homomorphism is always injective.\<close>
context field_hom begin
  sublocale zero_hom_0
  proof (unfold_locales, rule ccontr)
    fix x
    assume "hom x = 0" and x0: "x \<noteq> 0"
    then have "inverse (hom x) = 0" by simp
    then have "hom (inverse x) = 0" by (simp add: hom_distribs)
    then have "hom (inverse x * x) = 0" by (simp add: hom_distribs)
    with x0 have "hom 1 = hom 0" by simp
    then have "(1 :: 'b) = 0" by simp
    then show False by auto
  qed
  sublocale inj_idom_hom..
end

subsection \<open>Surjectivity and Isomorphisms\<close>

locale surjective =
  fixes f :: "'a \<Rightarrow> 'b"
  assumes surj: "surj f"
begin
  lemma f_inv_f[simp]: "f (inv f x) = x"
     by (rule cong, auto simp: surj[unfolded surj_iff o_def id_def])
end

locale bijective = injective + surjective

lemma bijective_eq_bij: "bijective f = bij f"
proof(intro iffI)
  assume "bijective f"
  then interpret bijective f.
  show "bij f" using injectivity surj by (auto intro!: bijI injI)
next
  assume "bij f"
  from this[unfolded bij_def]
  show "bijective f" by (unfold_locales, auto dest: injD)
qed

context bijective
begin
  lemmas bij = bijective_axioms[unfolded bijective_eq_bij]
  interpretation inv: bijective "inv f"
    using bijective_axioms bij_imp_bij_inv by (unfold bijective_eq_bij)
  sublocale inv: surjective "inv f"..
  sublocale inv: injective "inv f"..
  lemma inv_inv_f_eq[simp]: "inv (inv f) = f" using inv_inv_eq[OF bij].
  lemma f_eq_iff[simp]: "f x = y \<longleftrightarrow> x = inv f y" by auto
  lemma inv_f_eq_iff[simp]: "inv f x = y \<longleftrightarrow> x = f y" by auto
end

locale monoid_mult_isom = inj_monoid_mult_hom + bijective hom
begin
  sublocale inv: bijective "inv hom"..
  sublocale inv: inj_monoid_mult_hom "inv hom"
  proof (unfold_locales)
    fix hx hy :: 'b
    from bij obtain x y where hx: "hx = hom x" and hy: "hy = hom y" by (meson bij_pointE)
    show "inv hom (hx*hy) = inv hom hx * inv hom hy" by (unfold hx hy, fold hom_mult, simp)
    have "inv hom (hom 1) = 1" by (unfold inv_f_f, simp)
    then show "inv hom 1 = 1" by simp
  qed
end

locale monoid_add_isom = inj_monoid_add_hom + bijective hom
begin
  sublocale inv: bijective "inv hom"..
  sublocale inv: inj_monoid_add_hom "inv hom"
  proof (unfold_locales)
    fix hx hy :: 'b
    from bij obtain x y where hx: "hx = hom x" and hy: "hy = hom y" by (meson bij_pointE)
    show "inv hom (hx+hy) = inv hom hx + inv hom hy" by (unfold hx hy, fold hom_add, simp)
    have "inv hom (hom 0) = 0" by (unfold inv_f_f, simp)
    then show "inv hom 0 = 0" by simp
  qed
end

locale comm_monoid_mult_isom = monoid_mult_isom hom
  for hom :: "'a :: comm_monoid_mult \<Rightarrow> 'b :: comm_monoid_mult"
begin
  sublocale inv: monoid_mult_isom "inv hom"..
  sublocale inj_comm_monoid_mult_hom..

  lemma hom_dvd_hom[simp]: "hom x dvd hom y \<longleftrightarrow> x dvd y"
  proof
    assume "hom x dvd hom y"
    then obtain hz where "hom y = hom x * hz" by (elim dvdE)
    moreover obtain z where "hz = hom z" using bij by (elim bij_pointE)
    ultimately have "hom y = hom (x * z)" by (auto simp: hom_distribs)
    from this[unfolded eq_iff] have "y = x * z".
    then show "x dvd y" by (intro dvdI)
  qed (rule hom_dvd)

  lemma hom_dvd_simp[simp]:
    shows "hom x dvd y' \<longleftrightarrow> x dvd inv hom y'"
    using hom_dvd_hom[of x "inv hom y'"] by simp

end

locale comm_monoid_add_isom = monoid_add_isom hom
  for hom :: "'a :: comm_monoid_add \<Rightarrow> 'b :: comm_monoid_add"
begin
  sublocale inv: monoid_add_isom "inv hom" by (unfold_locales; simp add: hom_distribs)
  sublocale inj_comm_monoid_add_hom..
end

locale semiring_isom = inj_semiring_hom hom + bijective hom for hom
begin
  sublocale inv: inj_semiring_hom "inv hom" by (unfold_locales; simp add: hom_distribs)
  sublocale inv: bijective "inv hom"..
  sublocale monoid_mult_isom..
  sublocale comm_monoid_add_isom..
end

locale comm_semiring_isom = semiring_isom hom
  for hom :: "'a :: comm_semiring_1 \<Rightarrow> 'b :: comm_semiring_1"
begin
  sublocale inv: semiring_isom "inv hom" by (unfold_locales; simp add: hom_distribs)
  sublocale comm_monoid_mult_isom..
  sublocale inj_comm_semiring_hom..
end

locale ring_isom = inj_ring_hom + surjective hom
begin
  sublocale semiring_isom..
  sublocale inv: inj_ring_hom "inv hom" by (unfold_locales; simp add: hom_distribs)
end

locale comm_ring_isom = ring_isom hom
  for hom :: "'a :: comm_ring_1 \<Rightarrow> 'b :: comm_ring_1"
begin
  sublocale comm_semiring_isom..
  sublocale inj_comm_ring_hom..
  sublocale inv: ring_isom "inv hom" by (unfold_locales; simp add: hom_distribs)
end

locale idom_isom = comm_ring_isom + inj_idom_hom
begin
  sublocale inv: comm_ring_isom "inv hom" by (unfold_locales; simp add: hom_distribs)
  sublocale inv: inj_idom_hom "inv hom"..
end

locale field_isom = field_hom + surjective hom
begin
  sublocale idom_isom..
  sublocale inv: field_hom "inv hom" by (unfold_locales; simp add: hom_distribs)
end

locale inj_idom_divide_hom = idom_divide_hom hom + inj_idom_hom hom
  for hom :: "'a :: idom_divide \<Rightarrow> 'b :: idom_divide"
begin
lemma hom_dvd_iff[simp]: "(hom p dvd hom q) = (p dvd q)"
proof (cases "p = 0")
  case False
  show ?thesis
  proof
    assume "hom p dvd hom q" from this[unfolded dvd_def] obtain k where
      id: "hom q = hom p * k" by auto
    hence "(hom q div hom p) = (hom p * k) div hom p" by simp
    also have "\<dots> = k" by (rule nonzero_mult_div_cancel_left, insert False, simp)
    also have "hom q div hom p = hom (q div p)" by (simp add: hom_div)
    finally have "k = hom (q div p)" by auto
    from id[unfolded this] have "hom q = hom (p * (q div p))" by (simp add: hom_mult)
    hence "q = p * (q div p)" by simp
    thus "p dvd q" unfolding dvd_def ..
  qed simp
qed simp
end

context field_hom
begin
sublocale inj_idom_divide_hom ..
end

subsection \<open>Example Interpretations\<close>

interpretation of_int_hom: ring_hom of_int by (unfold_locales, auto)
interpretation of_int_hom: comm_ring_hom of_int by (unfold_locales, auto)
interpretation of_int_hom: idom_hom of_int by (unfold_locales, auto)
interpretation of_int_hom: inj_ring_hom "of_int :: int \<Rightarrow> 'a :: {ring_1,ring_char_0}"
  by (unfold_locales, auto)
interpretation of_int_hom: inj_comm_ring_hom "of_int :: int \<Rightarrow> 'a :: {comm_ring_1,ring_char_0}"
  by (unfold_locales, auto)
interpretation of_int_hom: inj_idom_hom "of_int :: int \<Rightarrow> 'a :: {idom,ring_char_0}"
  by (unfold_locales, auto)

text \<open>Somehow @{const of_rat} is defined only on \<open>char_0\<close>.\<close>
interpretation of_rat_hom: field_char_0_hom "of_rat"
  by (unfold_locales, auto simp: of_rat_add of_rat_mult of_rat_inverse of_rat_minus)

interpretation of_real_hom: inj_ring_hom of_real by (unfold_locales, auto)
interpretation of_real_hom: inj_comm_ring_hom of_real by (unfold_locales, auto)
interpretation of_real_hom: inj_idom_hom of_real by (unfold_locales, auto)
interpretation of_real_hom: field_hom of_real by (unfold_locales, auto)
interpretation of_real_hom: field_char_0_hom "of_real" by (unfold_locales, auto)

text \<open>Constant multiplication in a semiring is only a monoid homomorphism.\<close>

interpretation mult_hom: comm_monoid_add_hom "\<lambda>x. c * x" for c :: "'a :: semiring_1"
  by (unfold_locales, auto simp: field_simps)

end


(* Title:      Omega 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>Omega Algebras\<close>

theory Omega_Algebra
imports Kleene_Algebra
begin

text \<open>
\emph{Omega algebras}~\<^cite>\<open>"cohen00omega"\<close> extend Kleene algebras by an
$\omega$-operation that axiomatizes infinite iteration (just like the
Kleene star axiomatizes finite iteration).
\<close>

subsection \<open>Left Omega Algebras\<close>

text \<open>
In this section we consider \emph{left omega algebras}, i.e., omega
algebras based on left Kleene algebras. Surprisingly, we are still
looking for statements mentioning~$\omega$ that are true in omega
algebras, but do not already hold in left omega algebras.
\<close>

class left_omega_algebra = left_kleene_algebra_zero + omega_op +
  assumes omega_unfold: "x\<^sup>\<omega> \<le> x \<cdot> x\<^sup>\<omega>"
  and omega_coinduct: "y \<le> z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
begin

text \<open>First we prove some variants of the coinduction axiom.\<close>

lemma omega_coinduct_var1: "y \<le> 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  using local.omega_coinduct by fastforce

lemma  omega_coinduct_var2: "y \<le> x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis add.commute add_zero_l annir omega_coinduct)

lemma omega_coinduct_eq: "y = z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (simp add: local.omega_coinduct)

lemma omega_coinduct_eq_var1: "y = 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (simp add: omega_coinduct_var1)

lemma  omega_coinduct_eq_var2: "y = x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (simp add: omega_coinduct_var2)

lemma "y = x \<cdot> y + z \<Longrightarrow> y = x\<^sup>\<star> \<cdot> z + x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

lemma "y = 1 + x \<cdot> y \<Longrightarrow> y = x\<^sup>\<omega> + x\<^sup>\<star>"
  (* nitpick [expect=genuine] -- "3-element counterexample" *)
oops

lemma "y = x \<cdot> y \<Longrightarrow> y = x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

text \<open>Next we strengthen the unfold law to an equation.\<close>

lemma omega_unfold_eq [simp]: "x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule order.antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (simp add: local.mult_isol local.omega_unfold mult_assoc)
  thus "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_var2)
  show  "x\<^sup>\<omega> \<le> x \<cdot> x\<^sup>\<omega>"
    by (fact omega_unfold)
qed

lemma omega_unfold_var: "z + x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (simp add: local.omega_coinduct)

lemma "z + x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>We now prove subdistributivity and isotonicity of omega.\<close>

lemma omega_subdist: "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<le> (x + y) \<cdot> x\<^sup>\<omega>"
    by simp
  thus ?thesis
    by (rule omega_coinduct_var2)
qed

lemma omega_iso: "x \<le> y \<Longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (metis less_eq_def omega_subdist)

lemma omega_subdist_var: "x\<^sup>\<omega> + y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (simp add: omega_iso)

lemma zero_omega [simp]: "0\<^sup>\<omega> = 0"
  by (metis annil omega_unfold_eq)

text \<open>The next lemma is another variant of omega unfold\<close>

lemma star_omega_1 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule order.antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by simp
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by simp
  show "x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    using local.star_inductl_var_eq2 by auto
qed

text \<open>The next lemma says that~@{term "1\<^sup>\<omega>"} is the maximal element
of omega algebra. We therefore baptise it~$\top$.\<close>

lemma max_element: "x \<le> 1\<^sup>\<omega>"
  by (simp add: omega_coinduct_eq_var2)

definition top ("\<top>")
  where "\<top> = 1\<^sup>\<omega>"

lemma star_omega_3 [simp]: "(x\<^sup>\<star>)\<^sup>\<omega> = \<top>"
proof -
  have "1 \<le> x\<^sup>\<star>"
    by (fact star_ref)
  hence "\<top> \<le> (x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: omega_iso top_def)
  thus ?thesis
    by (simp add: local.order.antisym max_element top_def)
qed

text \<open>The following lemma is strange since it is counterintuitive
that one should be able to append something after an infinite
iteration.\<close>

lemma omega_1: "x\<^sup>\<omega> \<cdot> y \<le> x\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<cdot> y \<le> x \<cdot> x\<^sup>\<omega> \<cdot> y"
    by simp
  thus ?thesis
    by (metis mult.assoc omega_coinduct_var2)
qed

lemma "x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  (*nitpick [expect=genuine] -- "2-element counterexample"*)
oops

lemma omega_sup_id: "1 \<le> y \<Longrightarrow> x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  using order.eq_iff local.mult_isol omega_1 by fastforce

lemma omega_top [simp]: "x\<^sup>\<omega> \<cdot> \<top> = x\<^sup>\<omega>"
  by (simp add: max_element omega_sup_id top_def)

lemma supid_omega: "1 \<le> x \<Longrightarrow> x\<^sup>\<omega> = \<top>"
  by (simp add: local.order.antisym max_element omega_iso top_def)

lemma "x\<^sup>\<omega> = \<top> \<Longrightarrow> 1 \<le> x"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>Next we prove a simulation law for the omega operation\<close>

lemma omega_simulation: "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
proof -
  assume hyp: "z \<cdot> x \<le> y \<cdot> z"
  have "z \<cdot> x\<^sup>\<omega> = z \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (simp add: mult_assoc)
  also have "... \<le> y \<cdot> z \<cdot> x\<^sup>\<omega>"
    by (simp add: hyp local.mult_isor)
  finally show "z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_var2)
qed

lemma "z \<cdot> x \<le> y \<cdot> z \<Longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<cdot> z"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

lemma "y \<cdot> z  \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<omega> \<le> z \<cdot> x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "2-element counterexample" *)
oops

lemma "y \<cdot> z  \<le> z \<cdot> x \<Longrightarrow> y\<^sup>\<omega> \<cdot> z \<le> x\<^sup>\<omega>"
  (* nitpick [expect=genuine] -- "4-element counterexample" *)
oops

text \<open>Next we prove transitivity of omega elements.\<close>

lemma omega_omega: "(x\<^sup>\<omega>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_1 omega_unfold_eq)

(*
lemma "x\<^sup>\<omega> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
nitpick -- "no proof, no counterexample"

lemma "(x\<^sup>\<omega>)\<^sup>\<omega> = x\<^sup>\<omega>"
nitpick -- "no proof, no counterexample"
*)

text \<open>The next lemmas are axioms of Wagner's complete axiomatisation
for omega-regular languages~\<^cite>\<open>"wagner77omega"\<close>, but in a slightly
different setting.\<close>

lemma wagner_1 [simp]: "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule order.antisym)
  have "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x \<cdot> x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: local.star_slide_var mult_assoc)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc)
  also have "... = x \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc)
  thus "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    using calculation omega_coinduct_eq_var2 by auto
   show "x\<^sup>\<omega> \<le> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (simp add: mult_assoc omega_coinduct_eq_var2)
qed

lemma wagner_2_var: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
proof -
  have "x \<cdot> y \<cdot> x \<le> x \<cdot> y \<cdot> x"
    by auto
  thus "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (simp add: mult_assoc omega_simulation)
qed

lemma wagner_2 [simp]: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> = (x \<cdot> y)\<^sup>\<omega>"
proof (rule order.antisym)
  show "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (rule wagner_2_var)
  have "(x \<cdot> y)\<^sup>\<omega> = x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<omega>"
    by simp
  thus "(x \<cdot> y)\<^sup>\<omega> \<le> x \<cdot> (y \<cdot> x)\<^sup>\<omega>"
    by (metis mult.assoc mult_isol wagner_2_var)
qed

text \<open>
This identity is called~(A8) in Wagner's paper.
\<close>

lemma wagner_3:
assumes "x \<cdot> (x + y)\<^sup>\<omega> + z = (x + y)\<^sup>\<omega>"
shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
proof (rule order.antisym)
  show  "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    using assms local.join.sup_commute omega_coinduct_eq by auto
  have "x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    using assms local.join.sup_commute local.star_inductl_eq by auto
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (simp add: omega_subdist)
qed

text \<open>
This identity is called~(R4) in Wagner's paper.
\<close>

lemma wagner_1_var [simp]: "(x\<^sup>\<star> \<cdot> x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (simp add: local.star_slide_var)

lemma star_omega_4 [simp]: "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega>"
proof (rule order.antisym)
  have "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
  also have "... \<le> 1 + x\<^sup>\<omega> \<cdot> \<top>"
    by (simp add: omega_sup_id)
  finally show "(x\<^sup>\<omega>)\<^sup>\<star> \<le> 1 + x\<^sup>\<omega>"
    by simp
  show "1 + x\<^sup>\<omega> \<le> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
qed

lemma star_omega_5 [simp]: "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> = x\<^sup>\<omega>"
proof (rule order.antisym)
  show "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> \<le> x\<^sup>\<omega>"
    by (rule omega_1)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (simp add: omega_sup_id)
qed

text \<open>The next law shows how omegas below a sum can be unfolded.\<close>

lemma omega_sum_unfold: "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<omega> = (x + y)\<^sup>\<omega>"
proof -
  have "(x + y)\<^sup>\<omega> = x \<cdot> (x + y)\<^sup>\<omega> + y \<cdot> (x+y)\<^sup>\<omega>"
    by (metis distrib_right omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc wagner_3)
qed

text \<open>
The next two lemmas apply induction and coinduction to this law.
\<close>

lemma omega_sum_unfold_coind: "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
  by (simp add: omega_coinduct_eq omega_sum_unfold)

lemma omega_sum_unfold_ind: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (simp add: local.star_inductl_eq omega_sum_unfold)

lemma wagner_1_gen: "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> ((x + y) \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<omega>"
    using local.join.le_sup_iff local.join.sup.cobounded1 local.mult_isol_var local.star_subdist_var omega_iso by presburger
  thus ?thesis
    by (metis wagner_1)
qed

lemma wagner_1_var_gen: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by simp
  also have "... \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute mult_isol wagner_1_gen)
  also have "... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using local.mult_isor local.star_subdist by auto
  thus ?thesis
    by (metis calculation order_trans star_omega_1)
qed

text \<open>The next lemma is a variant of the denest law for the star at
the level of omega.\<close>

lemma omega_denest [simp]: "(x + y)\<^sup>\<omega> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
proof (rule order.antisym)
  show "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (rule omega_sum_unfold_coind)
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le>  (x + y)\<^sup>\<omega>"
    by (rule wagner_1_var_gen)
  hence "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (simp add: omega_sum_unfold_ind)
  thus "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (simp add: wagner_1_var_gen)
qed

text \<open>The next lemma yields a separation theorem for infinite
iteration in the presence of a quasicommutation property. A
nondeterministic loop over~@{term x} and~@{term y} can be refined into
separate infinite loops over~@{term x} and~@{term y}.\<close>

lemma omega_sum_refine:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
proof (rule order.antisym)
  have a: "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    using assms local.quasicomm_var by blast
  have "(x + y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute omega_sum_unfold)
  also have "... \<le> y\<^sup>\<omega> + x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using a local.join.sup_mono local.mult_isol_var by blast
  also have "... \<le> x \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    using local.eq_refl local.join.sup_commute mult_assoc star_omega_1 by presburger
  finally show "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
    by (metis add_commute local.omega_coinduct)
  have "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega> + (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    using local.join.sup.cobounded2 local.join.sup.mono local.mult_isol_var local.star_subdist omega_iso omega_subdist by presburger
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (metis local.join.sup_idem star_omega_1)
qed

text \<open>The following theorem by Bachmair and
Dershowitz~\<^cite>\<open>"bachmair86commutation"\<close> is a corollary.\<close>

lemma bachmair_dershowitz:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = 0 \<longleftrightarrow> x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
  by (metis add_commute assms local.annir local.join.le_bot local.no_trivial_inverse omega_subdist omega_sum_refine)

text \<open>
The next lemmas consider an abstract variant of the empty word
property from language theory and match it with the absence of
infinite iteration~\<^cite>\<open>"struth12regeq"\<close>.
\<close>

definition (in dioid_one_zero) ewp
where "ewp x \<equiv> \<not>(\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0)"

lemma ewp_super_id1: "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<Longrightarrow> ewp x"
  by (metis ewp_def mult_oner)

lemma "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<longleftrightarrow> ewp x"
  (* nitpick [expect=genuine] -- "3-element counterexample" *)
oops

text \<open>The next facts relate the absence of the empty word property
with the absence of infinite iteration.\<close>

lemma ewp_neg_and_omega: "\<not> ewp x \<longleftrightarrow> x\<^sup>\<omega> = 0"
proof
  assume "\<not> ewp x"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    by (meson ewp_def)
  thus "x\<^sup>\<omega> = 0"
    by simp
next
  assume "x\<^sup>\<omega> = 0"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    using local.join.le_bot local.omega_coinduct_var2 by blast
  thus "\<not> ewp x"
    by (meson ewp_def)
qed

lemma ewp_alt1: "(\<forall>z. x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> z) \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis add_comm less_eq_def omega_coinduct omega_unfold_eq order_prop)

lemma ewp_alt: "x\<^sup>\<omega> = 0 \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis annir order.antisym ewp_alt1 join.bot_least)

text \<open>So we have obtained a condition for Arden's lemma in omega
algebra.\<close>

lemma omega_super_id1: "0 \<noteq> 1 \<Longrightarrow> 1 \<le> x \<Longrightarrow> x\<^sup>\<omega> \<noteq> 0"
  using ewp_neg_and_omega ewp_super_id1 by blast

lemma omega_super_id2: "0 \<noteq> 1 \<Longrightarrow> x\<^sup>\<omega> = 0 \<Longrightarrow> \<not>(1 \<le> x)"
  using omega_super_id1 by blast

text \<open>The next lemmas are abstract versions of Arden's lemma from
language theory.\<close>

lemma ardens_lemma_var:
  assumes "x\<^sup>\<omega> = 0"
  and "z + x \<cdot> y = y"
  shows "x\<^sup>\<star> \<cdot> z = y"
proof -
  have "y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (simp add: assms(2) local.omega_coinduct_eq)
  hence "y \<le> x\<^sup>\<star> \<cdot> z"
    by (simp add: assms(1))
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (simp add: assms(2) order.eq_iff local.star_inductl_eq)
qed

lemma ardens_lemma: "\<not> ewp x \<Longrightarrow> z + x \<cdot> y = y \<Longrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (simp add: ardens_lemma_var ewp_neg_and_omega)

lemma ardens_lemma_equiv:
  assumes "\<not> ewp x"
  shows "z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (metis ardens_lemma_var assms ewp_neg_and_omega local.conway.dagger_unfoldl_distr mult_assoc)

lemma ardens_lemma_var_equiv: "x\<^sup>\<omega> = 0 \<Longrightarrow> (z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y)"
  by (simp add: ardens_lemma_equiv ewp_neg_and_omega)

lemma arden_conv1: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<Longrightarrow> \<not> ewp x"
  by (metis add_zero_l annir ewp_neg_and_omega omega_unfold_eq)

lemma arden_conv2: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<Longrightarrow> x\<^sup>\<omega> = 0"
  using arden_conv1 ewp_neg_and_omega by blast

lemma arden_var3: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longleftrightarrow> x\<^sup>\<omega> = 0"
  using arden_conv2 ardens_lemma_var by blast

end

subsection \<open>Omega Algebras\<close>

class omega_algebra = kleene_algebra + left_omega_algebra

end


theory Chapter9_1
imports "HOL-IMP.Types" "Short_Theory"
begin

text\<open>
\section*{Chapter 9}

\exercise
Reformulate the inductive predicates \ @{prop"\<Gamma> \<turnstile> a : \<tau>"},
\ @{prop"\<Gamma> \<turnstile> (b::bexp)"} \
and \ \mbox{@{prop"\<Gamma> \<turnstile> (c::com)"}} \ as three recursive functions
\<close>

fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option" where
(* your definition/proof here *)

fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" where
(* your definition/proof here *)

fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool" where
(* your definition/proof here *)

text\<open> and prove \<close>

lemma atyping_atype: "(\<Gamma> \<turnstile> a : \<tau>) = (atype \<Gamma> a = Some \<tau>)"
(* your definition/proof here *)

lemma btyping_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
(* your definition/proof here *)

lemma ctyping_cok: "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Modify the evaluation and typing of @{typ aexp} by allowing @{typ int}s to be coerced
to @{typ real}s with the predefined coercion function
\noquotes{@{term[source] "real_of_int :: int \<Rightarrow> real"}} where necessary.
Now every @{typ aexp} has a value. Define an evaluation function:
\<close>

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
(* your definition/proof here *)

text\<open>
Similarly, every @{typ aexp} has a type.
Define a function that computes the type of an @{typ aexp}
\<close>

fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty" where
(* your definition/proof here *)

text\<open> and prove that it computes the correct type: \<close>

lemma  "\<Gamma> \<turnstile> s \<Longrightarrow>  atyp \<Gamma> a = type (aval a s)"
(* your definition/proof here *)

text\<open>
Note that Isabelle inserts the coercion @{typ real} automatically.
For example, if you write @{term "Rv(i+r)"} where @{text"i :: int"} and
@{text "r :: real"} then it becomes @{term "Rv(real i + x)"}.
\endexercise
\bigskip

For the following two exercises copy theory @{short_theory "Types"} and modify it as required.

\begin{exercise}
Add a @{text REPEAT} loop (see Exercise~\ref{exe:IMP:REPEAT}) to the typed version of IMP
and update the type soundness proof.
\end{exercise}

\begin{exercise}
Modify the typed version of IMP as follows. Values are now either integers or booleans.
Thus variables can have boolean values too. Merge the two expressions types
@{typ aexp} and @{typ bexp} into one new type @{text exp} of expressions
that has the constructors of both types (of course without real constants).
Combine @{const taval} and @{const tbval} into one evaluation predicate
@{text "eval :: exp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"}. Similarly combine the two typing predicates
into one: @{text "\<Gamma> \<turnstile> e : \<tau>"} where @{text "e :: exp"} and the IMP-type @{text \<tau>} can
be one of @{text Ity} or @{text Bty}.
Adjust the small-step semantics and the type soundness proof.
\end{exercise}
\<close>

end


(*  Author:     Lars Hupel, TU München
*)

section \<open>Disjoint FSets\<close>

theory Disjoint_FSets
  imports
    "HOL-Library.Finite_Map"
    Disjoint_Sets
begin

context
  includes fset.lifting
begin

lift_definition fdisjnt :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is disjnt .

lemma fdisjnt_alt_def: "fdisjnt M N \<longleftrightarrow> (M |\<inter>| N = {||})"
by transfer (simp add: disjnt_def)

lemma fdisjnt_insert: "x |\<notin>| N \<Longrightarrow> fdisjnt M N \<Longrightarrow> fdisjnt (finsert x M) N"
by transfer' (rule disjnt_insert)

lemma fdisjnt_subset_right: "N' |\<subseteq>| N \<Longrightarrow> fdisjnt M N \<Longrightarrow> fdisjnt M N'"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_subset_left: "N' |\<subseteq>| N \<Longrightarrow> fdisjnt N M \<Longrightarrow> fdisjnt N' M"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_union_right: "fdisjnt M A \<Longrightarrow> fdisjnt M B \<Longrightarrow> fdisjnt M (A |\<union>| B)"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_union_left: "fdisjnt A M \<Longrightarrow> fdisjnt B M \<Longrightarrow> fdisjnt (A |\<union>| B) M"
unfolding fdisjnt_alt_def by auto

lemma fdisjnt_swap: "fdisjnt M N \<Longrightarrow> fdisjnt N M"
including fset.lifting by transfer' (auto simp: disjnt_def)

lemma distinct_append_fset:
  assumes "distinct xs" "distinct ys" "fdisjnt (fset_of_list xs) (fset_of_list ys)"
  shows "distinct (xs @ ys)"
using assms
by transfer' (simp add: disjnt_def)

lemma fdisjnt_contrI:
  assumes "\<And>x. x |\<in>| M \<Longrightarrow> x |\<in>| N \<Longrightarrow> False"
  shows "fdisjnt M N"
using assms
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_Union_left: "fdisjnt (ffUnion S) T \<longleftrightarrow> fBall S (\<lambda>S. fdisjnt S T)"
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_Union_right: "fdisjnt T (ffUnion S) \<longleftrightarrow> fBall S (\<lambda>S. fdisjnt T S)"
by transfer' (auto simp: disjnt_def)

lemma fdisjnt_ge_max: "fBall X (\<lambda>x. x > fMax Y) \<Longrightarrow> fdisjnt X Y"
by transfer (auto intro: disjnt_ge_max)

end

(* FIXME should be provable without lifting *)
lemma fmadd_disjnt: "fdisjnt (fmdom m) (fmdom n) \<Longrightarrow> m ++\<^sub>f n = n ++\<^sub>f m"
unfolding fdisjnt_alt_def
including fset.lifting fmap.lifting
apply transfer
apply (rule ext)
apply (auto simp: map_add_def split: option.splits)
done

end


section \<open> Examples using Prisms \<close>

theory Prisms_Examples
  imports Prisms
begin

text \<open> We demonstrate prisms for manipulating an algebraic data type with three constructors . \<close>

datatype D = A int | B string | C bool

fun fromA :: "D \<Rightarrow> int option" where "fromA (A x) = Some x" | "fromA _ = None"
fun fromB :: "D \<Rightarrow> string option" where "fromB (B x) = Some x" | "fromB _ = None"
fun fromC :: "D \<Rightarrow> bool option" where "fromC (C x) = Some x" | "fromC _ = None"

text \<open> We create a prism for each of the three constructors. \<close>

definition A\<^sub>_prism :: "int \<Longrightarrow>\<^sub>\<triangle> D" ("A\<^sub>\<triangle>") where
[lens_defs]: "A\<^sub>\<triangle> = \<lparr> prism_match = fromA, prism_build = A \<rparr>"

definition B_prism :: "string \<Longrightarrow>\<^sub>\<triangle> D" ("B\<^sub>\<triangle>") where
[lens_defs]: "B\<^sub>\<triangle> = \<lparr> prism_match = fromB, prism_build = B \<rparr>"

definition C_prism :: "bool \<Longrightarrow>\<^sub>\<triangle> D" ("C\<^sub>\<triangle>") where
[lens_defs]: "C\<^sub>\<triangle> = \<lparr> prism_match = fromC, prism_build = C \<rparr>"

text \<open> All three are well-behaved. \<close>

lemma A_wb_prism [simp]: "wb_prism A\<^sub>\<triangle>"
  using fromA.elims by (unfold_locales, auto simp add: lens_defs)

lemma B_wb_prism [simp]: "wb_prism B\<^sub>\<triangle>"
  using fromB.elims by (unfold_locales, auto simp add: lens_defs)

lemma C_wb_prism [simp]: "wb_prism C\<^sub>\<triangle>"
  using fromC.elims by (unfold_locales, auto simp add: lens_defs)

text \<open> All three prisms are codependent with each other. \<close>

lemma D_codeps: "A\<^sub>\<triangle> \<nabla> B\<^sub>\<triangle>" "A\<^sub>\<triangle> \<nabla> C\<^sub>\<triangle>" "B\<^sub>\<triangle> \<nabla> C\<^sub>\<triangle>"
  by (rule prism_diff_intro, simp add: lens_defs)+

end


(*  Title:      HOL/ex/Set_Comprehension_Pointfree_Examples.thy
    Author:     Lukas Bulwahn, Rafal Kolanski
    Copyright   2012 TU Muenchen
*)

section \<open>Examples for the set comprehension to pointfree simproc\<close>

theory Set_Comprehension_Pointfree_Examples
imports MainRLT
begin

declare [[simproc add: finite_Collect]]

lemma
  "finite (UNIV::'a set) \<Longrightarrow> finite {p. \<exists>x::'a. p = (x, x)}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B}"
  by simp

lemma
  "finite B \<Longrightarrow> finite A' \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> a \<in> A' \<and> b \<in> B}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B \<and> b \<in> B'}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite {f a b c| a b c. a \<in> A \<and> b \<in> B \<and> c \<in> C}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow>
     finite {f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow> finite E \<Longrightarrow>
    finite {f a b c d e | a b c d e. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D \<and> e \<in> E}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow> finite D \<Longrightarrow> finite E \<Longrightarrow>
    finite {f a d c b e | e b c d a. b \<in> B \<and> a \<in> A \<and> e \<in> E' \<and> c \<in> C \<and> d \<in> D \<and> e \<in> E \<and> b \<in> B'}"
  by simp

lemma
  "\<lbrakk> finite A ; finite B ; finite C ; finite D \<rbrakk>
  \<Longrightarrow> finite ({f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D})"
  by simp

lemma
  "finite ((\<lambda>(a,b,c,d). f a b c d) ` (A \<times> B \<times> C \<times> D))
  \<Longrightarrow> finite ({f a b c d| a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D})"
  by simp

lemma
  "finite S \<Longrightarrow> finite {s'. \<exists>s\<in>S. s' = f a e s}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. a \<in> A \<and> b \<in> B \<and> a \<notin> Z}"
  by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a b x y| a b x y. a \<in> A \<and> b \<in> B \<and> (x,y) \<in> R}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a b x y| a b x y. a \<in> A \<and> (x,y) \<in> R \<and> b \<in> B}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite R \<Longrightarrow> finite {f a (x, b) y| y b x a. a \<in> A \<and> (x,y) \<in> R \<and> b \<in> B}"
by simp

lemma
  "finite A \<Longrightarrow> finite AA \<Longrightarrow> finite B \<Longrightarrow> finite {f a b| a b. (a \<in> A \<or> a \<in> AA) \<and> b \<in> B \<and> a \<notin> Z}"
by simp

lemma
  "finite A1 \<Longrightarrow> finite A2 \<Longrightarrow> finite A3 \<Longrightarrow> finite A4 \<Longrightarrow> finite A5 \<Longrightarrow> finite B \<Longrightarrow>
     finite {f a b c | a b c. ((a \<in> A1 \<and> a \<in> A2) \<or> (a \<in> A3 \<and> (a \<in> A4 \<or> a \<in> A5))) \<and> b \<in> B \<and> a \<notin> Z}"
apply simp
oops

lemma "finite B \<Longrightarrow> finite {c. \<exists>x. x \<in> B \<and> c = a * x}"
by simp

lemma
  "finite A \<Longrightarrow> finite B \<Longrightarrow> finite {f a * g b |a b. a \<in> A \<and> b \<in> B}"
by simp

lemma
  "finite S \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> finite {f x y| x y. g x y \<in> S}"
  by (auto intro: finite_vimageI)

lemma
  "finite A \<Longrightarrow> finite S \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> finite {f x y z | x y z. g x y \<in> S & z \<in> A}"
  by (auto intro: finite_vimageI)

lemma
  "finite S \<Longrightarrow> finite A \<Longrightarrow> inj (\<lambda>(x, y). g x y) \<Longrightarrow> inj (\<lambda>(x, y). h x y)
    \<Longrightarrow> finite {f a b c d | a b c d. g a c \<in> S \<and> h b d \<in> A}"
  by (auto intro: finite_vimageI)

lemma
  assumes "finite S" shows "finite {(a,b,c,d). ([a, b], [c, d]) \<in> S}"
using assms by (auto intro!: finite_vimageI simp add: inj_on_def)
  (* injectivity to be automated with further rules and automation *)

schematic_goal (* check interaction with schematics *)
  "finite {x :: ?'A \<Rightarrow> ?'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b}
   = finite ((\<lambda>(b :: ?'B, a:: ?'A). Pair_Rep a b) ` (UNIV \<times> UNIV))"
  by simp

declare [[simproc del: finite_Collect]]

section \<open>Testing simproc in code generation\<close>

definition union :: "nat set => nat set => nat set"
where
  "union A B = {x. x \<in> A \<or> x \<in> B}"

definition common_subsets :: "nat set \<Rightarrow> nat set \<Rightarrow> nat set set"
where
  "common_subsets S1 S2 = {S. S \<subseteq> S1 \<and> S \<subseteq> S2}"

definition products :: "nat set => nat set => nat set"
where
  "products A B = {c. \<exists>a b. a \<in> A \<and> b \<in> B \<and> c = a * b}"

export_code union common_subsets products checking SML

end