(*  Title:      HOL/Library/Product_Order.thy
    Author:     Brian Huffman
*)

section \<open>Pointwise order on product types\<close>

theory Product_Order
imports Product_Plus
begin

subsection \<open>Pointwise ordering\<close>

instantiation prod :: (ord, ord) ord
begin

definition
  "x \<le> y \<longleftrightarrow> fst x \<le> fst y \<and> snd x \<le> snd y"

definition
  "(x::'a \<times> 'b) < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

instance ..

end

lemma fst_mono: "x \<le> y \<Longrightarrow> fst x \<le> fst y"
  unfolding less_eq_prod_def by simp

lemma snd_mono: "x \<le> y \<Longrightarrow> snd x \<le> snd y"
  unfolding less_eq_prod_def by simp

lemma Pair_mono: "x \<le> x' \<Longrightarrow> y \<le> y' \<Longrightarrow> (x, y) \<le> (x', y')"
  unfolding less_eq_prod_def by simp

lemma Pair_le [simp]: "(a, b) \<le> (c, d) \<longleftrightarrow> a \<le> c \<and> b \<le> d"
  unfolding less_eq_prod_def by simp

instance prod :: (preorder, preorder) preorder
proof
  fix x y z :: "'a \<times> 'b"
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    by (rule less_prod_def)
  show "x \<le> x"
    unfolding less_eq_prod_def
    by fast
  assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
    unfolding less_eq_prod_def
    by (fast elim: order_trans)
qed

instance prod :: (order, order) order
  by standard auto

subsection \<open>Binary infimum and supremum\<close>

instantiation prod :: (inf, inf) inf
begin

definition "inf x y = (inf (fst x) (fst y), inf (snd x) (snd y))"

lemma inf_Pair_Pair [simp]: "inf (a, b) (c, d) = (inf a c, inf b d)"
  unfolding inf_prod_def by simp

lemma fst_inf [simp]: "fst (inf x y) = inf (fst x) (fst y)"
  unfolding inf_prod_def by simp

lemma snd_inf [simp]: "snd (inf x y) = inf (snd x) (snd y)"
  unfolding inf_prod_def by simp

instance ..

end

instance prod :: (semilattice_inf, semilattice_inf) semilattice_inf
  by standard auto

instantiation prod :: (sup, sup) sup
begin

definition
  "sup x y = (sup (fst x) (fst y), sup (snd x) (snd y))"

lemma sup_Pair_Pair [simp]: "sup (a, b) (c, d) = (sup a c, sup b d)"
  unfolding sup_prod_def by simp

lemma fst_sup [simp]: "fst (sup x y) = sup (fst x) (fst y)"
  unfolding sup_prod_def by simp

lemma snd_sup [simp]: "snd (sup x y) = sup (snd x) (snd y)"
  unfolding sup_prod_def by simp

instance ..

end

instance prod :: (semilattice_sup, semilattice_sup) semilattice_sup
  by standard auto

instance prod :: (lattice, lattice) lattice ..

instance prod :: (distrib_lattice, distrib_lattice) distrib_lattice
  by standard (auto simp add: sup_inf_distrib1)

subsection \<open>Top and bottom elements\<close>

instantiation prod :: (top, top) top
begin

definition
  "top = (top, top)"

instance ..

end

lemma fst_top [simp]: "fst top = top"
  unfolding top_prod_def by simp

lemma snd_top [simp]: "snd top = top"
  unfolding top_prod_def by simp

lemma Pair_top_top: "(top, top) = top"
  unfolding top_prod_def by simp

instance prod :: (order_top, order_top) order_top
  by standard (auto simp add: top_prod_def)

instantiation prod :: (bot, bot) bot
begin

definition
  "bot = (bot, bot)"

instance ..

end

lemma fst_bot [simp]: "fst bot = bot"
  unfolding bot_prod_def by simp

lemma snd_bot [simp]: "snd bot = bot"
  unfolding bot_prod_def by simp

lemma Pair_bot_bot: "(bot, bot) = bot"
  unfolding bot_prod_def by simp

instance prod :: (order_bot, order_bot) order_bot
  by standard (auto simp add: bot_prod_def)

instance prod :: (bounded_lattice, bounded_lattice) bounded_lattice ..

instance prod :: (boolean_algebra, boolean_algebra) boolean_algebra
  by standard (auto simp add: prod_eqI diff_eq)

subsection \<open>Complete lattice operations\<close>

instantiation prod :: (Inf, Inf) Inf
begin

definition "Inf A = (INF x\<in>A. fst x, INF x\<in>A. snd x)"

instance ..

end

instantiation prod :: (Sup, Sup) Sup
begin

definition "Sup A = (SUP x\<in>A. fst x, SUP x\<in>A. snd x)"

instance ..

end

instance prod :: (conditionally_complete_lattice, conditionally_complete_lattice)
    conditionally_complete_lattice
  by standard (force simp: less_eq_prod_def Inf_prod_def Sup_prod_def bdd_below_def bdd_above_def
    intro!: cInf_lower cSup_upper cInf_greatest cSup_least)+

instance prod :: (complete_lattice, complete_lattice) complete_lattice
  by standard (simp_all add: less_eq_prod_def Inf_prod_def Sup_prod_def
    INF_lower SUP_upper le_INF_iff SUP_le_iff bot_prod_def top_prod_def)

lemma fst_Inf: "fst (Inf A) = (INF x\<in>A. fst x)"
  by (simp add: Inf_prod_def)

lemma fst_INF: "fst (INF x\<in>A. f x) = (INF x\<in>A. fst (f x))"
  by (simp add: fst_Inf image_image)

lemma fst_Sup: "fst (Sup A) = (SUP x\<in>A. fst x)"
  by (simp add: Sup_prod_def)

lemma fst_SUP: "fst (SUP x\<in>A. f x) = (SUP x\<in>A. fst (f x))"
  by (simp add: fst_Sup image_image)

lemma snd_Inf: "snd (Inf A) = (INF x\<in>A. snd x)"
  by (simp add: Inf_prod_def)

lemma snd_INF: "snd (INF x\<in>A. f x) = (INF x\<in>A. snd (f x))"
  by (simp add: snd_Inf image_image)

lemma snd_Sup: "snd (Sup A) = (SUP x\<in>A. snd x)"
  by (simp add: Sup_prod_def)

lemma snd_SUP: "snd (SUP x\<in>A. f x) = (SUP x\<in>A. snd (f x))"
  by (simp add: snd_Sup image_image)

lemma INF_Pair: "(INF x\<in>A. (f x, g x)) = (INF x\<in>A. f x, INF x\<in>A. g x)"
  by (simp add: Inf_prod_def image_image)

lemma SUP_Pair: "(SUP x\<in>A. (f x, g x)) = (SUP x\<in>A. f x, SUP x\<in>A. g x)"
  by (simp add: Sup_prod_def image_image)

text \<open>Alternative formulations for set infima and suprema over the product
of two complete lattices:\<close>

lemma INF_prod_alt_def: \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
  "Inf (f ` A) = (Inf ((fst \<circ> f) ` A), Inf ((snd \<circ> f) ` A))"
  by (simp add: Inf_prod_def image_image)

lemma SUP_prod_alt_def: \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
  "Sup (f ` A) = (Sup ((fst \<circ> f) ` A), Sup((snd \<circ> f) ` A))"
  by (simp add: Sup_prod_def image_image)

subsection \<open>Complete distributive lattices\<close>

instance prod :: (complete_distrib_lattice, complete_distrib_lattice) complete_distrib_lattice \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
proof
  fix A::"('a\<times>'b) set set"
  show "Inf (Sup ` A) \<le> Sup (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
    by (simp add: Inf_prod_def Sup_prod_def INF_SUP_set image_image)
qed

subsection \<open>Bekic's Theorem\<close>
text \<open>
  Simultaneous fixed points over pairs can be written in terms of separate fixed points.
  Transliterated from HOLCF.Fix by Peter Gammie
\<close>

lemma lfp_prod:
  fixes F :: "'a::complete_lattice \<times> 'b::complete_lattice \<Rightarrow> 'a \<times> 'b"
  assumes "mono F"
  shows "lfp F = (lfp (\<lambda>x. fst (F (x, lfp (\<lambda>y. snd (F (x, y)))))),
                 (lfp (\<lambda>y. snd (F (lfp (\<lambda>x. fst (F (x, lfp (\<lambda>y. snd (F (x, y)))))), y)))))"
  (is "lfp F = (?x, ?y)")
proof(rule lfp_eqI[OF assms])
  have 1: "fst (F (?x, ?y)) = ?x"
    by (rule trans [symmetric, OF lfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono lfp_mono)+
  have 2: "snd (F (?x, ?y)) = ?y"
    by (rule trans [symmetric, OF lfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono lfp_mono)+
  from 1 2 show "F (?x, ?y) = (?x, ?y)" by (simp add: prod_eq_iff)
next
  fix z assume F_z: "F z = z"
  obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F (x, y)) = x" by simp
  from F_z z have F_y: "snd (F (x, y)) = y" by simp
  let ?y1 = "lfp (\<lambda>y. snd (F (x, y)))"
  have "?y1 \<le> y" by (rule lfp_lowerbound, simp add: F_y)
  hence "fst (F (x, ?y1)) \<le> fst (F (x, y))"
    by (simp add: assms fst_mono monoD)
  hence "fst (F (x, ?y1)) \<le> x" using F_x by simp
  hence 1: "?x \<le> x" by (simp add: lfp_lowerbound)
  hence "snd (F (?x, y)) \<le> snd (F (x, y))"
    by (simp add: assms snd_mono monoD)
  hence "snd (F (?x, y)) \<le> y" using F_y by simp
  hence 2: "?y \<le> y" by (simp add: lfp_lowerbound)
  show "(?x, ?y) \<le> z" using z 1 2 by simp
qed

lemma gfp_prod:
  fixes F :: "'a::complete_lattice \<times> 'b::complete_lattice \<Rightarrow> 'a \<times> 'b"
  assumes "mono F"
  shows "gfp F = (gfp (\<lambda>x. fst (F (x, gfp (\<lambda>y. snd (F (x, y)))))),
                 (gfp (\<lambda>y. snd (F (gfp (\<lambda>x. fst (F (x, gfp (\<lambda>y. snd (F (x, y)))))), y)))))"
  (is "gfp F = (?x, ?y)")
proof(rule gfp_eqI[OF assms])
  have 1: "fst (F (?x, ?y)) = ?x"
    by (rule trans [symmetric, OF gfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono gfp_mono)+
  have 2: "snd (F (?x, ?y)) = ?y"
    by (rule trans [symmetric, OF gfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono gfp_mono)+
  from 1 2 show "F (?x, ?y) = (?x, ?y)" by (simp add: prod_eq_iff)
next
  fix z assume F_z: "F z = z"
  obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F (x, y)) = x" by simp
  from F_z z have F_y: "snd (F (x, y)) = y" by simp
  let ?y1 = "gfp (\<lambda>y. snd (F (x, y)))"
  have "y \<le> ?y1" by (rule gfp_upperbound, simp add: F_y)
  hence "fst (F (x, y)) \<le> fst (F (x, ?y1))"
    by (simp add: assms fst_mono monoD)
  hence "x \<le> fst (F (x, ?y1))" using F_x by simp
  hence 1: "x \<le> ?x" by (simp add: gfp_upperbound)
  hence "snd (F (x, y)) \<le> snd (F (?x, y))"
    by (simp add: assms snd_mono monoD)
  hence "y \<le> snd (F (?x, y))" using F_y by simp
  hence 2: "y \<le> ?y" by (simp add: gfp_upperbound)
  show "z \<le> (?x, ?y)" using z 1 2 by simp
qed

end


(*  Author: Tobias Nipkow, Alex Krauss, Dmitriy Traytel  *)

header "Regular Sets"

(*<*)
theory Pi_Regular_Set
imports Main
begin
(*>*)

type_synonym 'a lang = "'a list set"

definition conc :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a lang" (infixr "@@" 75) where
"A @@ B = {xs@ys | xs ys. xs:A & ys:B}"

overloading word_pow == "compow :: nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
begin
  primrec word_pow :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "word_pow 0 w = []" |
  "word_pow (Suc n) w = w @ word_pow n w"
end

overloading lang_pow == "compow :: nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
begin
  primrec lang_pow :: "nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang" where
  "lang_pow 0 A = {[]}" |
  "lang_pow (Suc n) A = A @@ (lang_pow n A)"
end

lemma word_pow_alt: "compow n w = concat (replicate n w)"
  by (induct n) auto

definition star :: "'a lang \<Rightarrow> 'a lang" where
"star A = (\<Union>n. A ^^ n)"

subsection{* Concatenation of Languages *}

lemma concI[simp,intro]: "u : A \<Longrightarrow> v : B \<Longrightarrow> u@v : A @@ B"
  by (auto simp add: conc_def)

lemma concE[elim]:
assumes "w \<in> A @@ B"
obtains u v where "u \<in> A" "v \<in> B" "w = u@v"
  using assms by (auto simp: conc_def)

lemma conc_mono: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A @@ B \<subseteq> C @@ D"
  by (auto simp: conc_def)

lemma conc_empty[simp]: shows "{} @@ A = {}" and "A @@ {} = {}"
  by auto

lemma conc_epsilon[simp]: shows "{[]} @@ A = A" and "A @@ {[]} = A"
  by (simp_all add:conc_def)

lemma conc_assoc: "(A @@ B) @@ C = A @@ (B @@ C)"
  by (auto elim!: concE) (simp only: append_assoc[symmetric] concI)

lemma conc_Un_distrib:
shows "A @@ (B \<union> C) = A @@ B \<union> A @@ C"
and   "(A \<union> B) @@ C = A @@ C \<union> B @@ C"
  by auto

lemma conc_UNION_distrib:
shows "A @@ UNION I M = UNION I (%i. A @@ M i)"
and   "UNION I M @@ A = UNION I (%i. M i @@ A)"
  by auto

lemma hom_image_conc: "\<lbrakk>\<And>xs ys. f (xs @ ys) = f xs @ f ys\<rbrakk> \<Longrightarrow> f ` (A @@ B) = f ` A @@ f ` B"
  unfolding conc_def by (auto simp: image_iff) metis

lemma map_image_conc[simp]: "map f ` (A @@ B) = map f ` A @@ map f ` B"
  by (simp add: hom_image_conc)

lemma conc_subset_lists: "A \<subseteq> lists S \<Longrightarrow> B \<subseteq> lists S \<Longrightarrow> A @@ B \<subseteq> lists S"
  by(fastforce simp: conc_def in_lists_conv_set)

subsection{* Iteration of Languages *}

lemma lang_pow_add: "A ^^ (n + m) = A ^^ n @@ A ^^ m"
  by (induct n) (auto simp: conc_assoc)

lemma lang_pow_simps: "(A ^^ Suc n) = (A ^^ n @@ A)"
  using lang_pow_add[of n "Suc 0" A] by auto

lemma lang_pow_empty: "{} ^^ n = (if n = 0 then {[]} else {})"
  by (induct n) auto

lemma lang_pow_empty_Suc[simp]: "({}::'a lang) ^^ Suc n = {}"
  by (simp add: lang_pow_empty)

lemma length_lang_pow_ub:
  "ALL w : A. length w \<le> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<le> k*n"
  by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma length_lang_pow_lb:
  "ALL w : A. length w \<ge> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<ge> k*n"
  by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma lang_pow_subset_lists: "A \<subseteq> lists S \<Longrightarrow> A ^^ n \<subseteq> lists S"
  by(induction n)(auto simp: conc_subset_lists[OF assms])

lemma star_subset_lists: "A \<subseteq> lists S \<Longrightarrow> star A \<subseteq> lists S"
  unfolding star_def by(blast dest: lang_pow_subset_lists)

lemma star_if_lang_pow[simp]: "w : A ^^ n \<Longrightarrow> w : star A"
  by (auto simp: star_def)

lemma Nil_in_star[iff]: "[] : star A"
proof (rule star_if_lang_pow)
  show "[] : A ^^ 0" by simp
qed

lemma star_if_lang[simp]: assumes "w : A" shows "w : star A"
proof (rule star_if_lang_pow)
  show "w : A ^^ 1" using `w : A` by simp
qed

lemma append_in_starI[simp]:
assumes "u : star A" and "v : star A" shows "u@v : star A"
proof -
  from `u : star A` obtain m where "u : A ^^ m" by (auto simp: star_def)
  moreover
  from `v : star A` obtain n where "v : A ^^ n" by (auto simp: star_def)
  ultimately have "u@v : A ^^ (m+n)" by (simp add: lang_pow_add)
  thus ?thesis by simp
qed

lemma conc_star_star: "star A @@ star A = star A"
  by (auto simp: conc_def)

lemma conc_star_comm:
  shows "A @@ star A = star A @@ A"
  unfolding star_def conc_pow_comm conc_UNION_distrib
  by simp

lemma star_induct[consumes 1, case_names Nil append, induct set: star]:
assumes "w : star A"
  and "P []"
  and step: "!!u v. u : A \<Longrightarrow> v : star A \<Longrightarrow> P v \<Longrightarrow> P (u@v)"
shows "P w"
proof -
  { fix n have "w : A ^^ n \<Longrightarrow> P w"
    by (induct n arbitrary: w) (auto intro: `P []` step star_if_lang_pow) }
  with `w : star A` show "P w" by (auto simp: star_def)
qed

lemma star_empty[simp]: "star {} = {[]}"
  by (auto elim: star_induct)

lemma star_epsilon[simp]: "star {[]} = {[]}"
  by (auto elim: star_induct)

lemma star_idemp[simp]: "star (star A) = star A"
  by (auto elim: star_induct)

lemma star_unfold_left: "star A = A @@ star A \<union> {[]}" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R" by (rule, erule star_induct) auto
qed auto

lemma concat_in_star: "set ws \<subseteq> A \<Longrightarrow> concat ws : star A"
  by (induct ws) simp_all

lemma in_star_iff_concat:
  "w : star A = (EX ws. set ws \<subseteq> A & w = concat ws & [] \<notin> set ws)"
  (is "_ = (EX ws. ?R w ws)")
proof
  assume "w : star A" thus "EX ws. ?R w ws"
  proof induct
    case Nil have "?R [] []" by simp
    thus ?case ..
  next
    case (append u v)
    moreover
    then obtain ws where "set ws \<subseteq> A \<and> v = concat ws \<and> [] \<notin> set ws" by blast
    ultimately have "?R (u@v) (if u = [] then ws else u#ws)" by auto
    thus ?case ..
  qed
next
  assume "EX us. ?R w us" thus "w : star A"
  by (auto simp: concat_in_star)
qed

lemma star_conv_concat: "star A = {concat ws|ws. set ws \<subseteq> A & [] \<notin> set ws}"
  by (fastforce simp: in_star_iff_concat)

lemma star_insert_eps[simp]: "star (insert [] A) = star(A)"
proof-
  { fix us
    have "set us \<subseteq> insert [] A \<Longrightarrow> EX vs. concat us = concat vs \<and> set vs \<subseteq> A"
      (is "?P \<Longrightarrow> EX vs. ?Q vs")
    proof
      let ?vs = "filter (%u. u \<noteq> []) us"
      show "?P \<Longrightarrow> ?Q ?vs" by (induct us) auto
    qed
  } thus ?thesis by (auto simp: star_conv_concat)
qed

lemma star_decom:
  assumes a: "x \<in> star A" "x \<noteq> []"
  shows "\<exists>a b. x = a @ b \<and> a \<noteq> [] \<and> a \<in> A \<and> b \<in> star A"
  using a by (induct rule: star_induct) (blast)+

lemma Ball_starI: "\<forall>a \<in> set as. [a] \<in> A \<Longrightarrow> as \<in> star A"
  by (induct as rule: rev_induct) auto

lemma map_image_star[simp]: "map f ` star A = star (map f ` A)"
  by (auto elim: star_induct) (auto elim: star_induct simp del: map_append simp: map_append[symmetric] intro!: imageI)

subsection {* Left-Quotients of Languages *}

definition lQuot :: "'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "lQuot x A = { xs. x#xs \<in> A }"

definition lQuots :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "lQuots xs A = { ys. xs @ ys \<in> A }"

abbreviation
  lQuotss :: "'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "lQuotss s As \<equiv> \<Union> (lQuots s ` As)"

lemma lQuot_empty[simp]:   "lQuot a {} = {}"
  and lQuot_epsilon[simp]: "lQuot a {[]} = {}"
  and lQuot_char[simp]:    "lQuot a {[b]} = (if a = b then {[]} else {})"
  and lQuot_chars[simp]:   "lQuot a {[b] | b. P b} = (if P a then {[]} else {})"
  and lQuot_union[simp]:   "lQuot a (A \<union> B) = lQuot a A \<union> lQuot a B"
  and lQuot_inter[simp]:   "lQuot a (A \<inter> B) = lQuot a A \<inter> lQuot a B"
  and lQuot_compl[simp]:   "lQuot a (-A) = - lQuot a A"
  by (auto simp: lQuot_def)

lemma lQuot_conc_subset: "lQuot a A @@ B \<subseteq> lQuot a (A @@ B)" (is "?L \<subseteq> ?R")
proof
  fix w assume "w \<in> ?L"
  then obtain u v where "w = u @ v" "a # u \<in> A" "v \<in> B"
    by (auto simp: lQuot_def)
  then have "a # w \<in> A @@ B"
    by (auto intro: concI[of "a # u", simplified])
  thus "w \<in> ?R" by (auto simp: lQuot_def)
qed

lemma lQuot_conc [simp]: "lQuot c (A @@ B) = (lQuot c A) @@ B \<union> (if [] \<in> A then lQuot c B else {})"
  unfolding lQuot_def conc_def
  by (auto simp add: Cons_eq_append_conv)

lemma lQuot_star [simp]: "lQuot c (star A) = (lQuot c A) @@ star A"
proof -
  have incl: "[] \<in> A \<Longrightarrow> lQuot c (star A) \<subseteq> (lQuot c A) @@ star A"
    unfolding lQuot_def conc_def
    apply(auto simp add: Cons_eq_append_conv)
    apply(drule star_decom)
    apply(auto simp add: Cons_eq_append_conv)
    done

  have "lQuot c (star A) = lQuot c (A @@ star A \<union> {[]})"
    by (simp only: star_unfold_left[symmetric])
  also have "... = lQuot c (A @@ star A)"
    by (simp only: lQuot_union) (simp)
  also have "... =  (lQuot c A) @@ (star A) \<union> (if [] \<in> A then lQuot c (star A) else {})"
    by simp
   also have "... =  (lQuot c A) @@ star A"
    using incl by auto
  finally show "lQuot c (star A) = (lQuot c A) @@ star A" .
qed

lemma lQuot_diff[simp]: "lQuot c (A - B) = lQuot c A - lQuot c B"
  by(auto simp add: lQuot_def)

lemma lQuot_lists[simp]: "c : S \<Longrightarrow> lQuot c (lists S) = lists S"
  by(auto simp add: lQuot_def)

lemma lQuots_simps [simp]:
  shows "lQuots [] A = A"
  and   "lQuots (c # s) A = lQuots s (lQuot c A)"
  and   "lQuots (s1 @ s2) A = lQuots s2 (lQuots s1 A)"
  unfolding lQuots_def lQuot_def by auto

lemma lQuots_append[iff]: "v \<in> lQuots w A \<longleftrightarrow> w @ v \<in> A"
  by (induct w arbitrary: v A) (auto simp add: lQuot_def)

subsection {* Right-Quotients of Languages *}

definition rQuot :: "'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "rQuot x A = { xs. xs @ [x] \<in> A }"

definition rQuots :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "rQuots xs A = { ys. ys @ rev xs \<in> A }"

abbreviation
  rQuotss :: "'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "rQuotss s As \<equiv> \<Union> (rQuots s ` As)"

lemma rQuot_rev_lQuot: "rQuot x A = rev ` lQuot x (rev ` A)"
  unfolding rQuot_def lQuot_def by (auto simp: rev_swap[symmetric])

lemma rQuots_rev_lQuots: "rQuots x A = rev ` lQuots x (rev ` A)"
  unfolding rQuots_def lQuots_def by (auto simp: rev_swap[symmetric])

lemma rQuot_empty[simp]:   "rQuot a {} = {}"
  and rQuot_epsilon[simp]: "rQuot a {[]} = {}"
  and rQuot_char[simp]:    "rQuot a {[b]} = (if a = b then {[]} else {})"
  and rQuot_union[simp]:   "rQuot a (A \<union> B) = rQuot a A \<union> rQuot a B"
  and rQuot_inter[simp]:   "rQuot a (A \<inter> B) = rQuot a A \<inter> rQuot a B"
  and rQuot_compl[simp]:   "rQuot a (-A) = - rQuot a A"
  by (auto simp: rQuot_def)

lemma lQuot_rQuot: "lQuot a (rQuot b A) = rQuot b (lQuot a A)"
  unfolding lQuot_def rQuot_def by auto

lemma rQuot_lQuot: "rQuot a (lQuot b A) = lQuot b (rQuot a A)"
  unfolding lQuot_def rQuot_def by auto

lemma rev_simp_invert: "(xs @ [x] = rev zs) = (zs = x # rev xs)"
  by (induct zs) auto

lemma rev_append_invert: "(xs @ ys = rev zs) = (zs = rev ys @ rev xs)"
  by (induct xs arbitrary: ys rule: rev_induct) auto

lemma image_rev_lists[simp]: "rev ` lists S = lists S"
proof (intro set_eqI)
  fix xs
  show "xs \<in> rev ` lists S \<longleftrightarrow> xs \<in> lists S"
  proof (induct xs rule: rev_induct)
    case (snoc x xs)
    thus ?case by (auto intro!: image_eqI[of _ rev] simp: rev_simp_invert)
  qed simp
qed

lemma image_rev_conc[simp]: "rev ` (A @@ B) = rev ` B @@ rev ` A"
  by auto (auto simp: rev_append[symmetric] simp del: rev_append)

lemma image_rev_star[simp]: "rev ` star A = star (rev ` A)"
  by (auto elim: star_induct) (auto elim: star_induct simp: rev_append[symmetric] simp del: rev_append)

lemma rQuot_conc [simp]: "rQuot c (A @@ B) = A @@ (rQuot c B) \<union> (if [] \<in> B then rQuot c A else {})"
  unfolding rQuot_rev_lQuot by (auto simp: image_image image_Un)

lemma rQuot_star [simp]: "rQuot c (star A) = star A @@ (rQuot c A)"
  unfolding rQuot_rev_lQuot by (auto simp: image_image)

lemma rQuot_diff[simp]: "rQuot c (A - B) = rQuot c A - rQuot c B"
  by(auto simp add: rQuot_def)

lemma rQuot_lists[simp]: "c : S \<Longrightarrow> rQuot c (lists S) = lists S"
  by(auto simp add: rQuot_def)

lemma rQuots_simps [simp]:
  shows "rQuots [] A = A"
  and   "rQuots (c # s) A = rQuots s (rQuot c A)"
  and   "rQuots (s1 @ s2) A = rQuots s2 (rQuots s1 A)"
  unfolding rQuots_def rQuot_def by auto

lemma rQuots_append[iff]: "v \<in> rQuots w A \<longleftrightarrow> v @ rev w \<in> A"
  by (induct w arbitrary: v A) (auto simp add: rQuot_def)

subsection {* Two-Sided-Quotients of Languages *}

definition biQuot :: "'a \<Rightarrow> 'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "biQuot x y A = { xs. x # xs @ [y] \<in> A }"

definition biQuots :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "biQuots xs ys A = { zs. xs @ zs @ rev ys \<in> A }"

abbreviation
  biQuotss :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "biQuotss xs ys As \<equiv> \<Union> (biQuots xs ys ` As)"

lemma biQuot_rQuot_lQuot: "biQuot x y A = rQuot y (lQuot x A)"
  unfolding biQuot_def rQuot_def lQuot_def by auto

lemma biQuot_lQuot_rQuot: "biQuot x y A = lQuot x (rQuot y A)"
  unfolding biQuot_def rQuot_def lQuot_def by auto

lemma biQuots_rQuots_lQuots: "biQuots x y A = rQuots y (lQuots x A)"
  unfolding biQuots_def rQuots_def lQuots_def by auto

lemma biQuots_lQuots_rQuots: "biQuots x y A = lQuots x (rQuots y A)"
  unfolding biQuots_def rQuots_def lQuots_def by auto

lemma biQuot_empty[simp]:   "biQuot a b {} = {}"
  and biQuot_epsilon[simp]: "biQuot a b {[]} = {}"
  and biQuot_char[simp]:    "biQuot a b {[c]} = {}"
  and biQuot_union[simp]:   "biQuot a b (A \<union> B) = biQuot a b A \<union> biQuot a b B"
  and biQuot_inter[simp]:   "biQuot a b (A \<inter> B) = biQuot a b A \<inter> biQuot a b B"
  and biQuot_compl[simp]:   "biQuot a b (-A) = - biQuot a b A"
  by (auto simp: biQuot_def)

lemma biQuot_conc [simp]: "biQuot a b (A @@ B) =
  lQuot a A @@ rQuot b B \<union>
  (if [] \<in> A \<and> [] \<in> B then biQuot a b A \<union> biQuot a b B
  else if [] \<in> A then biQuot a b B
  else if [] \<in> B then biQuot a b A
  else {})"
  unfolding biQuot_rQuot_lQuot by auto

lemma biQuot_star [simp]: "biQuot a b (star A) = biQuot a b A \<union> lQuot a A @@ star A @@ rQuot b A"
  unfolding biQuot_rQuot_lQuot by auto

lemma biQuot_diff[simp]: "biQuot a b (A - B) = biQuot a b A - biQuot a b B"
  by(auto simp add: biQuot_def)

lemma biQuot_lists[simp]: "a : S \<Longrightarrow> b : S \<Longrightarrow> biQuot a b (lists S) = lists S"
  by(auto simp add: biQuot_def)

lemma biQuots_simps [simp]:
  shows "biQuots [] [] A = A"
  and   "biQuots (a#as) (b#bs) A = biQuots as bs (biQuot a b A)"
  and   "\<lbrakk>length s1 = length t1; length s2 = length t2\<rbrakk> \<Longrightarrow>
    biQuots (s1 @ s2) (t1 @ t2) A = biQuots s2 t2 (biQuots s1 t1 A)"
  unfolding biQuots_def biQuot_def by auto

lemma biQuots_append[iff]: "v \<in> biQuots u w A \<longleftrightarrow> u @ v @ rev w \<in> A"
  unfolding biQuots_def by auto

subsection {* Arden's Lemma *}

lemma arden_helper:
  assumes eq: "X = A @@ X \<union> B"
  shows "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
proof (induct n)
  case 0
  show "X = (A ^^ Suc 0) @@ X \<union> (\<Union>m\<le>0. (A ^^ m) @@ B)"
    using eq by simp
next
  case (Suc n)
  have ih: "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" by fact
  also have "\<dots> = (A ^^ Suc n) @@ (A @@ X \<union> B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" using eq by simp
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> ((A ^^ Suc n) @@ B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
    by (simp add: conc_Un_distrib conc_assoc[symmetric] conc_pow_comm)
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)"
    by (auto simp add: le_Suc_eq)
  finally show "X = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)" .
qed

lemma Arden:
  assumes "[] \<notin> A"
  shows "X = A @@ X \<union> B \<longleftrightarrow> X = star A @@ B"
proof
  assume eq: "X = A @@ X \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from `[] \<notin> A` have "ALL u : A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "ALL u : A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "ALL u : A^^(?n+1)@@X. length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> A^^(?n+1)@@X" by auto
    hence "w : star A @@ B" using `w : X` using arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : star A @@ B"
    hence "EX n. w : A^^n @@ B" by(auto simp: conc_def star_def)
    hence "w : X" using arden_helper[OF eq] by blast
  } ultimately show "X = star A @@ B" by blast
next
  assume eq: "X = star A @@ B"
  have "star A = A @@ star A \<union> {[]}"
    by (rule star_unfold_left)
  then have "star A @@ B = (A @@ star A \<union> {[]}) @@ B"
    by metis
  also have "\<dots> = (A @@ star A) @@ B \<union> B"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = A @@ (star A @@ B) \<union> B"
    by (simp only: conc_assoc)
  finally show "X = A @@ X \<union> B"
    using eq by blast
qed

lemma reversed_arden_helper:
  assumes eq: "X = X @@ A \<union> B"
  shows "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
proof (induct n)
  case 0
  show "X = X @@ (A ^^ Suc 0) \<union> (\<Union>m\<le>0. B @@ (A ^^ m))"
    using eq by simp
next
  case (Suc n)
  have ih: "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" by fact
  also have "\<dots> = (X @@ A \<union> B) @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" using eq by simp
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (B @@ (A ^^ Suc n)) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
    by (simp add: conc_Un_distrib conc_assoc)
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))"
    by (auto simp add: le_Suc_eq)
  finally show "X = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))" .
qed

theorem reversed_Arden:
  assumes nemp: "[] \<notin> A"
  shows "X = X @@ A \<union> B \<longleftrightarrow> X = B @@ star A"
proof
 assume eq: "X = X @@ A \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from `[] \<notin> A` have "ALL u : A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "ALL u : A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "ALL u : X @@ A^^(?n+1). length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> X @@ A^^(?n+1)" by auto
    hence "w : B @@ star A" using `w : X` using reversed_arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : B @@ star A"
    hence "EX n. w : B @@ A^^n" by (auto simp: conc_def star_def)
    hence "w : X" using reversed_arden_helper[OF eq] by blast
  } ultimately show "X = B @@ star A" by blast
next
  assume eq: "X = B @@ star A"
  have "star A = {[]} \<union> star A @@ A"
    unfolding conc_star_comm[symmetric]
    by(metis Un_commute star_unfold_left)
  then have "B @@ star A = B @@ ({[]} \<union> star A @@ A)"
    by metis
  also have "\<dots> = B \<union> B @@ (star A @@ A)"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = B \<union> (B @@ star A) @@ A"
    by (simp only: conc_assoc)
  finally show "X = X @@ A \<union> B"
    using eq by blast
qed

subsection {* Lists of Fixed Length *}

abbreviation listsN where "listsN n S \<equiv> {xs. xs \<in> lists S \<and> length xs = n}"

lemma tl_listsN: "A \<subseteq> listsN (n + 1) S \<Longrightarrow> tl ` A \<subseteq> listsN n S"
proof (intro image_subsetI)
  fix xs assume "A \<subseteq> listsN (n + 1) S" "xs \<in> A"
  thus "tl xs \<in> listsN n S" by (induct xs) auto
qed

lemma map_tl_listsN: "A \<subseteq> lists (listsN (n + 1) S) \<Longrightarrow> map tl ` A \<subseteq> lists (listsN n S)"
proof (intro image_subsetI)
  fix xss assume "A \<subseteq> lists (listsN (n + 1) S)" "xss \<in> A"
  hence "set xss \<subseteq> listsN (n + 1) S" by auto
  hence "\<forall>xs \<in> set xss. tl xs \<in> listsN n S" using tl_listsN[of "set xss" S n] by auto
  thus "map tl xss \<in> lists (listsN n S)" by (induct xss) auto
qed

(*<*)
end
(*>*)


theory MyList
imports Main
begin

datatype 'a list = Nil | Cons 'a "'a list"

fun app ::  "'a list => 'a list => 'a list" where
   "app Nil ys = ys"
 | "app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list => 'a list" where
   "rev Nil = Nil"
 | "rev (Cons x xs) = app (rev xs) (Cons x Nil)"

fun mycount :: "'a list \<Rightarrow> nat" where
   "mycount Nil = 0"
 | "mycount (Cons x xs) = Suc (mycount xs)"

fun myremove :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "myremove x Nil = Nil"
 | "myremove x (Cons y xs) =
    (if x=y
      then (myremove x xs)
      else (Cons y (myremove x xs)))"

fun mydedup :: "'a list \<Rightarrow> 'a list" where
   "mydedup Nil = Nil"
 | "mydedup (Cons x xs) = Cons x (myremove x (mydedup xs))"

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

fun myhas :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" where
   "myhas x Nil = False"
 | "myhas x (Cons y xs) =
    (if x=y
      then True
      else (myhas x xs))"

fun mycindex :: "'a \<Rightarrow> 'a list \<Rightarrow> int" where
   "mycindex x xs =
    (if (myhas x xs)
      then int (myiindex x xs)
      else -1::int)"

fun myindex :: "'a \<Rightarrow> 'a list \<Rightarrow> int option" where
  "myindex x xs =
    (if (myhas x xs)
      then Some (int (myiindex x xs))
      else None)"

value "rev (Cons True (Cons False Nil))"

(* a comment *)

lemma app_Nil2 [simp]: "app xs Nil = xs"
  apply (induction xs)
  apply (auto)
done

lemma app_assoc [simp]: "app (app xs ys) zs = app xs (app ys zs)"
  apply (induction xs)
  apply (auto)
done

lemma rev_app [simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
  apply (induction xs)
  apply (auto)
done

theorem rev_rev [simp]: "rev (rev xs) = xs"
  apply (induction xs)
  apply (auto)
done

theorem app_count [simp]: "mycount (app xs ys) = (mycount xs) + (mycount ys)"
  apply (induction xs)
  apply (auto)
done

theorem rev_count [simp]: "mycount (rev xs) = mycount xs"
  apply (induction xs)
  apply (auto)
done

theorem remove_idempotence [simp]: "myremove x (myremove x xs) = myremove x xs"
  apply (induction xs)
  apply (auto)
done

lemma remove_count_limit [simp]: "mycount (myremove x xs) \<le> mycount xs"
  apply (induction xs)
  apply (auto)
done

lemma remove_count_required [simp]: "mycount (myremove x (Cons x xs)) < mycount (Cons x xs)"
  apply (induction xs)
  apply (auto)
done

lemma remove_distributivity [simp]: "myremove x (myremove y xs) = myremove y (myremove x xs)"
  apply (induction xs)
  apply (auto)
done

lemma dedup_remove_distributivity [simp]: "mydedup (myremove x xs) = myremove x (mydedup xs)"
  apply (induction xs)
  apply (auto)
done

theorem dedup_idempotence [simp]: "mydedup (mydedup xs) = mydedup xs"
  apply (induction xs)
  apply (auto)
done

theorem dedup_count_limit [simp]: "mycount (mydedup xs) \<le> mycount xs"
  apply (induction xs)
  apply (auto)
by (meson dual_order.trans remove_count_limit)

theorem dedup_count_nonzero [simp]: "(mycount xs > 0) = (mycount (mydedup xs) > 0)"
  apply (induction xs)
  apply (auto)
done

theorem iindex_post_remove [simp]: "myiindex x (myremove x xs) = (mycount (myremove x xs)) + 1"
  apply (induction xs)
  apply (auto)
done

theorem remove_other [simp]: "x \<noteq> y \<longrightarrow> myremove x (Cons y xs) = Cons y (myremove x xs)"
  apply (induction xs)
  apply (auto)
done

lemma iindex_remove_limit [simp]: "x \<noteq> y \<longrightarrow> myiindex x (myremove y xs) \<le> myiindex x xs"
  apply (induction xs)
  apply (auto)
done

lemma iindex_dedup_limit [simp]: "myiindex x (mydedup xs) \<le> myiindex x xs"
  apply (induction xs)
  apply (auto)
by (meson dual_order.trans iindex_remove_limit)

lemma remove_other_still_has [simp]: "x \<noteq> y \<longrightarrow> myhas x (myremove y xs) = myhas x xs"
  apply (induction xs)
  apply (auto)
done

theorem dedup_no_remove [simp]: "(myhas x (mydedup xs)) = (myhas x xs)"
  apply (induction xs)
  apply (auto)
done

theorem cindex_dedup_limit [simp]: "mycindex x (mydedup xs) \<le> mycindex x xs"
  apply (induction xs)
  apply (auto)
by (meson dual_order.trans iindex_dedup_limit iindex_remove_limit)

theorem index_dedup_limit [simp]: "the (myindex x (mydedup xs)) \<le> the (myindex x xs)"
  apply (induction xs)
  apply (auto)
by (meson dual_order.trans iindex_dedup_limit iindex_remove_limit)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Symmetric\<close>
theory Binary_Relations_Symmetric
  imports
    Functions_Monotone
begin

consts symmetric_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  symmetric_on_pred \<equiv> "symmetric_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "symmetric_on_pred P R \<equiv> \<forall>x y. P x \<and> P y \<and> R x y \<longrightarrow> R y x"
end

lemma symmetric_onI [intro]:
  assumes "\<And>x y. P x \<Longrightarrow> P y \<Longrightarrow> R x y \<Longrightarrow> R y x"
  shows "symmetric_on P R"
  unfolding symmetric_on_pred_def using assms by blast

lemma symmetric_onD:
  assumes "symmetric_on P R"
  and "P x" "P y"
  and "R x y"
  shows "R y x"
  using assms unfolding symmetric_on_pred_def by blast

lemma symmetric_on_rel_inv_iff_symmetric_on [iff]:
  "symmetric_on P R\<inverse> \<longleftrightarrow> symmetric_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  by (blast dest: symmetric_onD)

lemma antimono_symmetric_on [iff]:
  "antimono (\<lambda>(P :: 'a \<Rightarrow> bool). symmetric_on P (R :: 'a \<Rightarrow> _))"
  by (intro antimonoI) (auto dest: symmetric_onD)

lemma symmetric_on_if_le_pred_if_symmetric_on:
  fixes P P' :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "symmetric_on P R"
  and "P' \<le> P"
  shows "symmetric_on P' R"
  using assms by (blast dest: symmetric_onD)

definition "symmetric (R :: 'a \<Rightarrow> _) \<equiv> symmetric_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma symmetric_eq_symmetric_on:
  "symmetric (R :: 'a \<Rightarrow> _) = symmetric_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding symmetric_def ..

lemma symmetricI [intro]:
  assumes "\<And>x y. R x y \<Longrightarrow> R y x"
  shows "symmetric R"
  unfolding symmetric_eq_symmetric_on using assms by (intro symmetric_onI)

lemma symmetricD:
  assumes "symmetric R"
  and "R x y"
  shows "R y x"
  using assms unfolding symmetric_eq_symmetric_on by (auto dest: symmetric_onD)

lemma symmetric_on_if_symmetric:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "symmetric R"
  shows "symmetric_on P R"
  using assms by (intro symmetric_onI) (blast dest: symmetricD)

lemma symmetric_rel_inv_iff_symmetric [iff]: "symmetric R\<inverse> \<longleftrightarrow> symmetric R"
  by (blast dest: symmetricD)

lemma rel_inv_eq_self_if_symmetric [simp]:
  assumes "symmetric R"
  shows "R\<inverse> = R"
  using assms by (blast dest: symmetricD)

lemma rel_iff_rel_if_symmetric:
  assumes "symmetric R"
  shows "R x y \<longleftrightarrow> R y x"
  using assms by (blast dest: symmetricD)

lemma symmetric_if_rel_inv_eq_self:
  assumes "R\<inverse> = R"
  shows "symmetric R"
  by (intro symmetricI, subst assms[symmetric]) simp

lemma symmetric_iff_rel_inv_eq_self: "symmetric R \<longleftrightarrow> R\<inverse> = R"
  using rel_inv_eq_self_if_symmetric symmetric_if_rel_inv_eq_self by blast

lemma symmetric_if_symmetric_on_in_field:
  assumes "symmetric_on (in_field R) R"
  shows "symmetric R"
  using assms by (intro symmetricI) (blast dest: symmetric_onD)

corollary symmetric_on_in_field_iff_symmetric [simp]:
  "symmetric_on (in_field R) R \<longleftrightarrow> symmetric R"
  using symmetric_if_symmetric_on_in_field symmetric_on_if_symmetric
  by blast

paragraph \<open>Instantiations\<close>

lemma symmetric_eq [iff]: "symmetric (=)"
  by (rule symmetricI) (rule sym)

lemma symmetric_top: "symmetric \<top>"
  by (rule symmetricI) auto

end


(* Title:      Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Iterings\<close>

text \<open>
This theory introduces algebraic structures with an operation that describes iteration in various relational computation models.
An iteration describes the repeated sequential execution of a computation.
This is typically modelled by fixpoints, but different computation models use different fixpoints in the refinement order.
We therefore look at equational and simulation axioms rather than induction axioms.
Our development is based on \cite{Guttmann2012c} and the proposed algebras generalise Kleene algebras.

We first consider a variant of Conway semirings \cite{BloomEsik1993a} based on idempotent left semirings.
Conway semirings expand semirings by an iteration operation satisfying Conway's sumstar and productstar axioms \cite{Conway1971}.
Many properties of iteration follow already from these equational axioms.

Next we introduce iterings, which use generalised versions of simulation axioms in addition to sumstar and productstar.
Unlike the induction axioms of the Kleene star, which hold only in partial-correctness models, the simulation axioms are also valid in total and general correctness models.
They are still powerful enough to prove the correctness of complex results such as separation theorems of \cite{Cohen2000} and Back's atomicity refinement theorem \cite{BackWright1999,Wright2004}.
\<close>

theory Iterings

imports Stone_Relation_Algebras.Semirings

begin

subsection \<open>Conway Semirings\<close>

text \<open>
In this section, we consider equational axioms for iteration.
The algebraic structures are based on idempotent left semirings, which are expanded by a unary iteration operation.
We start with an unfold property, one inequality of the sliding rule and distributivity over joins, which is similar to Conway's sumstar.
\<close>

class circ =
  fixes circ :: "'a \<Rightarrow> 'a" ("_\<^sup>\<circ>" [100] 100)

class left_conway_semiring = idempotent_left_semiring + circ +
  assumes circ_left_unfold: "1 \<squnion> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
  assumes circ_left_slide: "(x * y)\<^sup>\<circ> * x \<le> x * (y * x)\<^sup>\<circ>"
  assumes circ_sup_1: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
begin

text \<open>
We obtain one inequality of Conway's productstar, as well as of the other unfold rule.
\<close>

lemma circ_mult_sub:
  "1 \<squnion> x * (y * x)\<^sup>\<circ> * y \<le> (x * y)\<^sup>\<circ>"
  by (metis sup_right_isotone circ_left_slide circ_left_unfold mult_assoc mult_right_isotone)

lemma circ_right_unfold_sub:
  "1 \<squnion> x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
  by (metis circ_mult_sub mult_1_left mult_1_right)

lemma circ_zero:
  "bot\<^sup>\<circ> = 1"
  by (metis sup_monoid.add_0_right circ_left_unfold mult_left_zero)

lemma circ_increasing:
  "x \<le> x\<^sup>\<circ>"
  by (metis le_supI2 circ_left_unfold circ_right_unfold_sub mult_1_left mult_right_sub_dist_sup_left order_trans)

lemma circ_reflexive:
  "1 \<le> x\<^sup>\<circ>"
  by (metis sup_left_divisibility circ_left_unfold)

lemma circ_mult_increasing:
  "x \<le> x * x\<^sup>\<circ>"
  by (metis circ_reflexive mult_right_isotone mult_1_right)

lemma circ_mult_increasing_2:
  "x \<le> x\<^sup>\<circ> * x"
  by (metis circ_reflexive mult_left_isotone mult_1_left)

lemma circ_transitive_equal:
  "x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_idem circ_sup_1 circ_left_unfold mult_assoc)

text \<open>
While iteration is not idempotent, a fixpoint is reached after applying this operation twice.
Iteration is idempotent for the unit.
\<close>

lemma circ_circ_circ:
  "x\<^sup>\<circ>\<^sup>\<circ>\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_idem circ_sup_1 circ_increasing circ_transitive_equal le_iff_sup)

lemma circ_one:
  "1\<^sup>\<circ> = 1\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_circ_circ circ_zero)

lemma circ_sup_sub:
  "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_1 circ_left_slide)

lemma circ_plus_one:
  "x\<^sup>\<circ> = 1 \<squnion> x\<^sup>\<circ>"
  by (metis le_iff_sup circ_reflexive)

text \<open>
Iteration satisfies a characteristic property of reflexive transitive closures.
\<close>

lemma circ_rtc_2:
  "1 \<squnion> x \<squnion> x\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_assoc circ_increasing circ_plus_one circ_transitive_equal le_iff_sup)

lemma mult_zero_circ:
  "(x * bot)\<^sup>\<circ> = 1 \<squnion> x * bot"
  by (metis circ_left_unfold mult_assoc mult_left_zero)

lemma mult_zero_sup_circ:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (y * bot)\<^sup>\<circ>"
  by (metis circ_sup_1 mult_assoc mult_left_zero)

lemma circ_plus_sub:
  "x\<^sup>\<circ> * x \<le> x * x\<^sup>\<circ>"
  by (metis circ_left_slide mult_1_left mult_1_right)

lemma circ_loop_fixpoint:
  "y * (y\<^sup>\<circ> * z) \<squnion> z = y\<^sup>\<circ> * z"
  by (metis sup_commute circ_left_unfold mult_assoc mult_1_left mult_right_dist_sup)

lemma left_plus_below_circ:
  "x * x\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis sup.cobounded2 circ_left_unfold)

lemma right_plus_below_circ:
  "x\<^sup>\<circ> * x \<le> x\<^sup>\<circ>"
  using circ_right_unfold_sub by auto

lemma circ_sup_upper_bound:
  "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x \<squnion> y \<le> z\<^sup>\<circ>"
  by simp

lemma circ_mult_upper_bound:
  "x \<le> z\<^sup>\<circ> \<Longrightarrow> y \<le> z\<^sup>\<circ> \<Longrightarrow> x * y \<le> z\<^sup>\<circ>"
  by (metis mult_isotone circ_transitive_equal)

lemma circ_sub_dist:
  "x\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_sub circ_plus_one mult_1_left mult_right_sub_dist_sup_left order_trans)

lemma circ_sub_dist_1:
  "x \<le> (x \<squnion> y)\<^sup>\<circ>"
  using circ_increasing le_supE by blast

lemma circ_sub_dist_2:
  "x * y \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_commute circ_mult_upper_bound circ_sub_dist_1)

lemma circ_sub_dist_3:
  "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_commute circ_mult_upper_bound circ_sub_dist)

lemma circ_isotone:
  "x \<le> y \<Longrightarrow> x\<^sup>\<circ> \<le> y\<^sup>\<circ>"
  by (metis circ_sub_dist le_iff_sup)

lemma circ_sup_2:
  "(x \<squnion> y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_increasing circ_isotone circ_reflexive mult_isotone mult_1_left mult_1_right)

lemma circ_sup_one_left_unfold:
  "1 \<le> x \<Longrightarrow> x * x\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis antisym le_iff_sup mult_1_left mult_right_sub_dist_sup_left left_plus_below_circ)

lemma circ_sup_one_right_unfold:
  "1 \<le> x \<Longrightarrow> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis antisym le_iff_sup mult_left_sub_dist_sup_left mult_1_right right_plus_below_circ)

lemma circ_decompose_4:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_assoc sup_commute circ_sup_1 circ_loop_fixpoint circ_plus_one circ_rtc_2 circ_transitive_equal mult_assoc)

lemma circ_decompose_5:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_4 circ_loop_fixpoint antisym mult_right_sub_dist_sup_right mult_assoc)

lemma circ_decompose_6:
  "x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_commute circ_sup_1)

lemma circ_decompose_7:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x \<squnion> y)\<^sup>\<circ>"
  by (metis circ_sup_1 circ_decompose_6 circ_transitive_equal mult_assoc)

lemma circ_decompose_8:
  "(x \<squnion> y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis antisym eq_refl mult_assoc mult_isotone mult_1_right circ_mult_upper_bound circ_reflexive circ_sub_dist_3)

lemma circ_decompose_9:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ> * (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_4 mult_assoc)

lemma circ_decompose_10:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_ge2 circ_loop_fixpoint circ_reflexive circ_sup_one_right_unfold mult_assoc order_trans)

lemma circ_back_loop_prefixpoint:
  "(z * y\<^sup>\<circ>) * y \<squnion> z \<le> z * y\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_left_unfold mult_assoc mult_left_sub_dist_sup_left mult_right_isotone mult_1_right right_plus_below_circ)

text \<open>
We obtain the fixpoint and prefixpoint properties of iteration, but not least or greatest fixpoint properties.
\<close>

lemma circ_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . y * x \<squnion> z) (y\<^sup>\<circ> * z)"
  by (metis circ_loop_fixpoint is_fixpoint_def)

lemma circ_back_loop_is_prefixpoint:
  "is_prefixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
  by (metis circ_back_loop_prefixpoint is_prefixpoint_def)

lemma circ_circ_sup:
  "(1 \<squnion> x)\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_commute circ_sup_1 circ_decompose_4 circ_zero mult_1_right)

lemma circ_circ_mult_sub:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

lemma left_plus_circ:
  "(x * x\<^sup>\<circ>)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis circ_left_unfold circ_sup_1 mult_1_right mult_sub_right_one sup.absorb1 mult_assoc)

lemma right_plus_circ:
  "(x\<^sup>\<circ> * x)\<^sup>\<circ> = x\<^sup>\<circ>"
  by (metis sup_commute circ_isotone circ_loop_fixpoint circ_plus_sub circ_sub_dist eq_iff left_plus_circ)

lemma circ_square:
  "(x * x)\<^sup>\<circ> \<le> x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone left_plus_circ mult_right_isotone)

lemma circ_mult_sub_sup:
  "(x * y)\<^sup>\<circ> \<le> (x \<squnion> y)\<^sup>\<circ>"
  by (metis sup_ge1 sup_ge2 circ_isotone circ_square mult_isotone order_trans)

lemma circ_sup_mult_zero:
  "x\<^sup>\<circ> * y = (x \<squnion> y * bot)\<^sup>\<circ> * y"
proof -
  have "(x \<squnion> y * bot)\<^sup>\<circ> * y = x\<^sup>\<circ> * (1 \<squnion> y * bot) * y"
    by (metis mult_zero_sup_circ mult_zero_circ)
  also have "... = x\<^sup>\<circ> * (y \<squnion> y * bot)"
    by (metis mult_assoc mult_1_left mult_left_zero mult_right_dist_sup)
  also have "... = x\<^sup>\<circ> * y"
    by (metis sup_commute le_iff_sup zero_right_mult_decreasing)
  finally show ?thesis
    by simp
qed

lemma troeger_1:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * (x \<squnion> y)\<^sup>\<circ>)"
  by (metis circ_sup_1 circ_left_unfold mult_assoc)

lemma troeger_2:
  "(x \<squnion> y)\<^sup>\<circ> * z = x\<^sup>\<circ> * (y * (x \<squnion> y)\<^sup>\<circ> * z \<squnion> z)"
  by (metis circ_sup_1 circ_loop_fixpoint mult_assoc)

lemma troeger_3:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> * (1 \<squnion> y * bot)"
  by (metis mult_zero_sup_circ mult_zero_circ)

lemma circ_sup_sub_sup_one_1:
  "x \<squnion> y \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_increasing circ_left_unfold mult_1_left mult_1_right mult_left_sub_dist_sup mult_right_sub_dist_sup_left order_trans sup_mono)

lemma circ_sup_sub_sup_one_2:
  "x\<^sup>\<circ> * (x \<squnion> y) \<le> x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_sup_sub_sup_one_1 circ_transitive_equal mult_assoc mult_right_isotone)

lemma circ_sup_sub_sup_one:
  "x * x\<^sup>\<circ> * (x \<squnion> y) \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
  by (metis circ_sup_sub_sup_one_2 mult_assoc mult_right_isotone)

lemma circ_square_2:
  "(x * x)\<^sup>\<circ> * (x \<squnion> 1) \<le> x\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_increasing circ_mult_upper_bound circ_reflexive circ_square)

lemma circ_extra_circ:
  "(y * x\<^sup>\<circ>)\<^sup>\<circ> = (y * y\<^sup>\<circ> * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_decompose_6 circ_transitive_equal left_plus_circ mult_assoc)

lemma circ_circ_sub_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_mult_upper_bound circ_reflexive)

lemma circ_decompose_11:
  "(x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_decompose_10 circ_decompose_4 circ_decompose_5 circ_decompose_9 left_plus_circ)

lemma circ_mult_below_circ_circ:
  "(x * y)\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_increasing circ_isotone circ_reflexive dual_order.trans mult_left_isotone mult_right_isotone mult_1_right)

(*
lemma circ_right_unfold: "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_mult: "1 \<squnion> x * (y * x)\<^sup>\<circ> * y = (x * y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_slide: "(x * y)\<^sup>\<circ> * x = x * (y * x)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_plus_same: "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult_1: "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma "x\<^sup>\<circ> * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_circ_mult: "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
lemma circ_sup: "(x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=8] oops
lemma circ_unfold_sum: "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops

lemma mult_zero_sup_circ_2: "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot" nitpick [expect=genuine,card=7] oops
lemma sub_mult_one_circ: "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x" nitpick [expect=genuine] oops
lemma circ_back_loop_fixpoint: "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma circ_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>" nitpick [expect=genuine,card=7] oops
*)

end

text \<open>
The next class considers the interaction of iteration with a greatest element.
\<close>

class bounded_left_conway_semiring = bounded_idempotent_left_semiring + left_conway_semiring
begin

lemma circ_top:
  "top\<^sup>\<circ> = top"
  by (simp add: antisym circ_increasing)

lemma circ_right_top:
  "x\<^sup>\<circ> * top = top"
  by (metis sup_right_top circ_loop_fixpoint)

lemma circ_left_top:
  "top * x\<^sup>\<circ> = top"
  by (metis circ_right_top circ_top circ_decompose_11)

lemma mult_top_circ:
  "(x * top)\<^sup>\<circ> = 1 \<squnion> x * top"
  by (metis circ_left_top circ_left_unfold mult_assoc)

end

class left_zero_conway_semiring = idempotent_left_zero_semiring + left_conway_semiring
begin

lemma mult_zero_sup_circ_2:
  "(x \<squnion> y * bot)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * bot"
  by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_3)

lemma circ_unfold_sum:
  "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * y * (x \<squnion> y)\<^sup>\<circ>"
  by (metis mult_assoc mult_left_dist_sup mult_1_right troeger_1)

end

text \<open>
The next class assumes the full sliding equation.
\<close>

class left_conway_semiring_1 = left_conway_semiring +
  assumes circ_right_slide: "x * (y * x)\<^sup>\<circ> \<le> (x * y)\<^sup>\<circ> * x"
begin

lemma circ_slide_1:
  "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
  by (metis antisym circ_left_slide circ_right_slide)

text \<open>
This implies the full unfold rules and Conway's productstar.
\<close>

lemma circ_right_unfold_1:
  "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis circ_left_unfold circ_slide_1 mult_1_left mult_1_right)

lemma circ_mult_1:
  "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
  by (metis circ_left_unfold circ_slide_1 mult_assoc)

lemma circ_sup_9:
  "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_sup_1 circ_slide_1)

lemma circ_plus_same:
  "x\<^sup>\<circ> * x = x * x\<^sup>\<circ>"
  by (metis circ_slide_1 mult_1_left mult_1_right)

lemma circ_decompose_12:
  "x\<^sup>\<circ> * y\<^sup>\<circ> \<le> (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  by (metis circ_sup_9 circ_sub_dist_3)

end

class left_zero_conway_semiring_1 = left_zero_conway_semiring + left_conway_semiring_1
begin

lemma circ_back_loop_fixpoint:
  "(z * y\<^sup>\<circ>) * y \<squnion> z = z * y\<^sup>\<circ>"
  by (metis sup_commute circ_left_unfold circ_plus_same mult_assoc mult_left_dist_sup mult_1_right)

lemma circ_back_loop_is_fixpoint:
  "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * y\<^sup>\<circ>)"
  by (metis circ_back_loop_fixpoint is_fixpoint_def)

lemma circ_elimination:
  "x * y = bot \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero order_refl)

end

subsection \<open>Iterings\<close>

text \<open>
This section adds simulation axioms to Conway semirings.
We consider several classes with increasingly general simulation axioms.
\<close>

class itering_1 = left_conway_semiring_1 +
  assumes circ_simulate: "z * x \<le> y * z \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
begin

lemma circ_circ_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_sup circ_reflexive circ_simulate circ_sub_dist_3 circ_sup_one_left_unfold circ_transitive_equal mult_1_left order_refl)

lemma sub_mult_one_circ:
  "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
  by (metis circ_simulate mult_1_left mult_1_right order_refl)

text \<open>
The left simulation axioms is enough to prove a basic import property of tests.
\<close>

lemma circ_import:
  assumes "p \<le> p * p"
      and "p \<le> 1"
      and "p * x \<le> x * p"
    shows "p * x\<^sup>\<circ> = p * (p * x)\<^sup>\<circ>"
proof -
  have "p * x \<le> p * (p * x * p) * p"
    by (metis assms coreflexive_transitive eq_iff test_preserves_equation mult_assoc)
  hence "p * x\<^sup>\<circ> \<le> p * (p * x)\<^sup>\<circ>"
    by (metis (no_types) assms circ_simulate circ_slide_1 test_preserves_equation)
  thus ?thesis
    by (metis assms(2) circ_isotone mult_left_isotone mult_1_left mult_right_isotone antisym)
qed

end

text \<open>
Including generalisations of both simulation axioms allows us to prove separation rules.
\<close>

class itering_2 = left_conway_semiring_1 +
  assumes circ_simulate_right: "z * x \<le> y * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
  assumes circ_simulate_left: "x * z \<le> z * y \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
begin

subclass itering_1
  apply unfold_locales
  by (metis sup_monoid.add_0_right circ_simulate_right mult_left_zero)

lemma circ_simulate_left_1:
  "x * z \<le> z * y \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right circ_simulate_left mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_separate_1:
  assumes "y * x \<le> x * y"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y\<^sup>\<circ> * x \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis assms circ_simulate_left_1)
  hence "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot * y\<^sup>\<circ>"
    by (metis mult_assoc mult_left_isotone mult_right_dist_sup)
  also have "... = x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis circ_transitive_equal mult_assoc mult_left_zero)
  finally have "y\<^sup>\<circ> * (x * y\<^sup>\<circ>)\<^sup>\<circ> \<le> x\<^sup>\<circ> * (y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot)"
    using circ_simulate_right mult_assoc by fastforce
  also have "... = x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (simp add: sup_absorb1 zero_right_mult_decreasing)
  finally have "(x \<squnion> y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (simp add: circ_decompose_6 circ_sup_1)
  thus ?thesis
    by (simp add: antisym circ_sub_dist_3)
qed

lemma circ_circ_mult_1:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis sup_commute circ_circ_sup circ_separate_1 mult_1_left mult_1_right order_refl)

end

text \<open>
With distributivity, we also get Back's atomicity refinement theorem.
\<close>

class itering_3 = itering_2 + left_zero_conway_semiring_1
begin

lemma circ_simulate_1:
  assumes "y * x \<le> x * y"
    shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y"
    by (metis assms circ_simulate)
  hence "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis circ_simulate_left_1)
  thus ?thesis
    by (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_sup_circ_2)
qed

lemma atomicity_refinement:
  assumes "s = s * q"
      and "x = q * x"
      and "q * b = bot"
      and "r * b \<le> b * r"
      and "r * l \<le> l * r"
      and "x * l \<le> l * x"
      and "b * l \<le> l * b"
      and "q * l \<le> l * q"
      and "r\<^sup>\<circ> * q \<le> q * r\<^sup>\<circ>"
      and "q \<le> 1"
    shows "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
proof -
  have "(x \<squnion> b \<squnion> r) * l \<le> l * (x \<squnion> b \<squnion> r)"
    using assms(5-7) mult_left_dist_sup mult_right_dist_sup semiring.add_mono by presburger
  hence "s * (x \<squnion> b \<squnion> r \<squnion> l)\<^sup>\<circ> * q = s * l\<^sup>\<circ> * (x \<squnion> b \<squnion> r)\<^sup>\<circ> * q"
    by (metis sup_commute circ_separate_1 mult_assoc)
  also have "... = s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * r\<^sup>\<circ> * q)\<^sup>\<circ>"
  proof -
    have "(b \<squnion> r)\<^sup>\<circ> = b\<^sup>\<circ> * r\<^sup>\<circ>"
      by (simp add: assms(4) circ_separate_1)
    hence "b\<^sup>\<circ> * r\<^sup>\<circ> * (q * (x * b\<^sup>\<circ> * r\<^sup>\<circ>))\<^sup>\<circ> = (x \<squnion> b \<squnion> r)\<^sup>\<circ>"
      by (metis (full_types) assms(2) circ_sup_1 sup_assoc sup_commute mult_assoc)
    thus ?thesis
      by (metis circ_slide_1 mult_assoc)
  qed
  also have "... \<le> s * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * q * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(9) circ_isotone mult_assoc mult_right_isotone)
  also have "... \<le> s * q * l\<^sup>\<circ> * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(1,10) mult_left_isotone mult_right_isotone mult_1_right)
  also have "... \<le> s * l\<^sup>\<circ> * q * b\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(1,8) circ_simulate mult_assoc mult_left_isotone mult_right_isotone)
  also have "... \<le> s * l\<^sup>\<circ> * r\<^sup>\<circ> * (x * b\<^sup>\<circ> * q * r\<^sup>\<circ>)\<^sup>\<circ>"
    by (metis assms(3,10) sup_monoid.add_0_left circ_back_loop_fixpoint circ_plus_same mult_assoc mult_left_zero mult_left_isotone mult_right_isotone mult_1_right)
  also have "... \<le> s * (x * b\<^sup>\<circ> * q \<squnion> r \<squnion> l)\<^sup>\<circ>"
    by (metis sup_commute circ_sup_1 circ_sub_dist_3 mult_assoc mult_right_isotone)
  finally show ?thesis
    .
qed

end

text \<open>
The following class contains the most general simulation axioms we consider.
They allow us to prove further separation properties.
\<close>

class itering = idempotent_left_zero_semiring + circ +
  assumes circ_sup: "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y)\<^sup>\<circ> * x\<^sup>\<circ>"
  assumes circ_mult: "(x * y)\<^sup>\<circ> = 1 \<squnion> x * (y * x)\<^sup>\<circ> * y"
  assumes circ_simulate_right_plus: "z * x \<le> y * y\<^sup>\<circ> * z \<squnion> w \<longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * (z \<squnion> w * x\<^sup>\<circ>)"
  assumes circ_simulate_left_plus: "x * z \<le> z * y\<^sup>\<circ> \<squnion> w \<longrightarrow> x\<^sup>\<circ> * z \<le> (z \<squnion> x\<^sup>\<circ> * w) * y\<^sup>\<circ>"
begin

lemma circ_right_unfold:
  "1 \<squnion> x\<^sup>\<circ> * x = x\<^sup>\<circ>"
  by (metis circ_mult mult_1_left mult_1_right)

lemma circ_slide:
  "x * (y * x)\<^sup>\<circ> = (x * y)\<^sup>\<circ> * x"
proof -
  have "x * (y * x)\<^sup>\<circ> = Rf x (y * 1 \<squnion> y * (x * (y * x)\<^sup>\<circ> * y)) * x"
    by (metis (no_types) circ_mult mult_1_left mult_1_right mult_left_dist_sup mult_right_dist_sup mult_assoc)
  thus ?thesis
    by (metis (no_types) circ_mult mult_1_right mult_left_dist_sup mult_assoc)
qed

subclass itering_3
  apply unfold_locales
  apply (metis circ_mult mult_1_left mult_1_right)
  apply (metis circ_slide order_refl)
  apply (metis circ_sup circ_slide)
  apply (metis circ_slide order_refl)
  apply (metis sup_left_isotone circ_right_unfold mult_left_isotone mult_left_sub_dist_sup_left mult_1_right order_trans circ_simulate_right_plus)
  by (metis sup_commute sup_ge1 sup_right_isotone circ_mult mult_right_isotone mult_1_right order_trans circ_simulate_left_plus)

lemma circ_simulate_right_plus_1:
  "z * x \<le> y * y\<^sup>\<circ> * z \<Longrightarrow> z * x\<^sup>\<circ> \<le> y\<^sup>\<circ> * z"
  by (metis sup_monoid.add_0_right circ_simulate_right_plus mult_left_zero)

lemma circ_simulate_left_plus_1:
  "x * z \<le> z * y\<^sup>\<circ> \<Longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right circ_simulate_left_plus mult_assoc mult_left_zero mult_right_dist_sup)

lemma circ_simulate_2:
  "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longleftrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  apply (rule iffI)
  apply (metis sup_assoc sup_monoid.add_0_right circ_loop_fixpoint circ_simulate_left_plus_1 mult_assoc mult_left_zero mult_zero_sup_circ_2)
  by (metis circ_increasing mult_left_isotone order_trans)

lemma circ_simulate_absorb:
  "y * x \<le> x \<Longrightarrow> y\<^sup>\<circ> * x \<le> x \<squnion> y\<^sup>\<circ> * bot"
  by (metis circ_simulate_left_plus_1 circ_zero mult_1_right)

lemma circ_simulate_3:
  "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup.bounded_iff circ_reflexive circ_simulate_2 le_iff_sup mult_right_isotone mult_1_right)

lemma circ_separate_mult_1:
  "y * x \<le> x * y \<Longrightarrow> (x * y)\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_mult_sub_sup circ_separate_1)

lemma circ_separate_unfold:
  "(y * x\<^sup>\<circ>)\<^sup>\<circ> = y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * y * x * x\<^sup>\<circ> * (y * x\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis circ_back_loop_fixpoint circ_plus_same circ_unfold_sum sup_commute mult_assoc)

lemma separation:
  assumes "y * x \<le> x * y\<^sup>\<circ>"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y\<^sup>\<circ> * x * y\<^sup>\<circ> \<le> x * y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * bot"
    by (metis assms circ_simulate_left_plus_1 circ_transitive_equal mult_assoc mult_left_isotone)
  thus ?thesis
    by (metis sup_commute circ_sup_1 circ_simulate_right circ_sub_dist_3 le_iff_sup mult_assoc mult_left_zero zero_right_mult_decreasing)
qed

lemma simulation:
  "y * x \<le> x * y\<^sup>\<circ> \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_ge2 circ_isotone circ_mult_upper_bound circ_sub_dist separation)

lemma circ_simulate_4:
  assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    shows "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "x \<squnion> (x * x\<^sup>\<circ> * x * x \<squnion> x * x) = x * x\<^sup>\<circ>"
    by (metis (no_types) circ_back_loop_fixpoint mult_right_dist_sup sup_commute)
  hence "x \<le> x * x\<^sup>\<circ> * 1 \<squnion> x * x\<^sup>\<circ> * y"
    by (metis mult_1_right sup_assoc sup_ge1)
  hence "(1 \<squnion> y) * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    using assms mult_left_dist_sup mult_right_dist_sup by force
  hence "y * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis circ_sup_upper_bound circ_increasing circ_reflexive circ_simulate_right_plus_1 mult_right_isotone mult_right_sub_dist_sup_right order_trans)
  thus ?thesis
    by (metis circ_simulate_2)
qed

lemma circ_simulate_5:
  "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_sup_sub_sup_one circ_simulate_4 order_trans)

lemma circ_simulate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_commute circ_back_loop_fixpoint circ_simulate_5 mult_right_sub_dist_sup_left order_trans)

lemma circ_separate_4:
  assumes "y * x \<le> x * x\<^sup>\<circ> * (1 \<squnion> y)"
    shows "(x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
proof -
  have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * (1 \<squnion> y) * x\<^sup>\<circ>"
    by (simp add: assms mult_left_isotone)
  also have "... = x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * y * x\<^sup>\<circ>"
    by (simp add: circ_transitive_equal mult_left_dist_sup mult_right_dist_sup mult_assoc)
  also have "... \<le> x * x\<^sup>\<circ> \<squnion> x * x\<^sup>\<circ> * x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis assms sup_right_isotone circ_simulate_2 circ_simulate_4 mult_assoc mult_right_isotone)
  finally have "y * x * x\<^sup>\<circ> \<le> x * x\<^sup>\<circ> * y\<^sup>\<circ>"
    by (metis circ_reflexive circ_transitive_equal le_iff_sup mult_assoc mult_right_isotone mult_1_right)
  thus ?thesis
    by (metis circ_sup_1 left_plus_circ mult_assoc separation)
qed

lemma circ_separate_5:
  "y * x \<le> x * x\<^sup>\<circ> * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis circ_sup_sub_sup_one circ_separate_4 order_trans)

lemma circ_separate_6:
  "y * x \<le> x * (x \<squnion> y) \<Longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>"
  by (metis sup_commute circ_back_loop_fixpoint circ_separate_5 mult_right_sub_dist_sup_left order_trans)

end

class bounded_itering = bounded_idempotent_left_zero_semiring + itering
begin

subclass bounded_left_conway_semiring ..

(*
lemma "1 = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x = x * x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x * x\<^sup>\<circ> = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "(x * y)\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> * y\<^sup>\<circ> = (x \<squnion> y)\<^sup>\<circ>" nitpick [expect=genuine,card=6] oops
lemma "(x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 = 1\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "1 = (x * bot)\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "1 \<squnion> x * bot = x\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x\<^sup>\<circ> = x\<^sup>\<circ> * 1\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "z \<squnion> y * x = x \<longrightarrow> y\<^sup>\<circ> * z \<le> x" nitpick [expect=genuine] oops
lemma "y * x = x \<longrightarrow> y\<^sup>\<circ> * x \<le> x" nitpick [expect=genuine] oops
lemma "z \<squnion> x * y = x \<longrightarrow> z * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x * y = x \<longrightarrow> x * y\<^sup>\<circ> \<le> x" nitpick [expect=genuine] oops
lemma "x = z \<squnion> y * x \<longrightarrow> x \<le> y\<^sup>\<circ> * z" nitpick [expect=genuine] oops
lemma "x = y * x \<longrightarrow> x \<le> y\<^sup>\<circ>" nitpick [expect=genuine] oops
lemma "x * z = z * y \<longrightarrow> x\<^sup>\<circ> * z \<le> z * y\<^sup>\<circ>" nitpick [expect=genuine] oops

lemma "x\<^sup>\<circ> = (x * x)\<^sup>\<circ> * (x \<squnion> 1)" oops
lemma "y\<^sup>\<circ> * x\<^sup>\<circ> \<le> x\<^sup>\<circ> * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
lemma "y * x \<le> (1 \<squnion> x) * y\<^sup>\<circ> \<longrightarrow> (x \<squnion> y)\<^sup>\<circ> = x\<^sup>\<circ> * y\<^sup>\<circ>" oops
lemma "y * x \<le> x \<longrightarrow> y\<^sup>\<circ> * x \<le> 1\<^sup>\<circ> * x" oops
*)

end

text \<open>
We finally expand Conway semirings and iterings by an element that corresponds to the endless loop.
\<close>

class L =
  fixes L :: "'a"

class left_conway_semiring_L = left_conway_semiring + L +
  assumes one_circ_mult_split: "1\<^sup>\<circ> * x = L \<squnion> x"
  assumes L_split_sup: "x * (y \<squnion> L) \<le> x * y \<squnion> L"
begin

lemma L_def:
  "L = 1\<^sup>\<circ> * bot"
  by (metis sup_monoid.add_0_right one_circ_mult_split)

lemma one_circ_split:
  "1\<^sup>\<circ> = L \<squnion> 1"
  by (metis mult_1_right one_circ_mult_split)

lemma one_circ_circ_split:
  "1\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> 1"
  by (metis circ_one one_circ_split)

lemma sub_mult_one_circ:
  "x * 1\<^sup>\<circ> \<le> 1\<^sup>\<circ> * x"
  by (metis L_split_sup sup_commute mult_1_right one_circ_mult_split)

lemma one_circ_mult_split_2:
  "1\<^sup>\<circ> * x = x * 1\<^sup>\<circ> \<squnion> L"
proof -
  have 1: "x * 1\<^sup>\<circ> \<le> L \<squnion> x"
    using one_circ_mult_split sub_mult_one_circ by presburger
  have "x \<squnion> x * 1\<^sup>\<circ> = x * 1\<^sup>\<circ>"
    by (meson circ_back_loop_prefixpoint le_iff_sup sup.boundedE)
  thus ?thesis
    using 1 by (simp add: le_iff_sup one_circ_mult_split sup_assoc sup_commute)
qed

lemma sub_mult_one_circ_split:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
  by (metis sup_commute one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
  by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split:
  "x * L \<le> x * bot \<squnion> L"
  by (metis L_split_sup sup_monoid.add_0_left)

lemma L_left_zero:
  "L * x = L"
  by (metis L_def mult_assoc mult_left_zero)

lemma one_circ_L:
  "1\<^sup>\<circ> * L = L"
  by (metis L_def circ_transitive_equal mult_assoc)

lemma mult_L_circ:
  "(x * L)\<^sup>\<circ> = 1 \<squnion> x * L"
  by (metis L_left_zero circ_left_unfold mult_assoc)

lemma mult_L_circ_mult:
  "(x * L)\<^sup>\<circ> * y = y \<squnion> x * L"
  by (metis L_left_zero mult_L_circ mult_assoc mult_1_left mult_right_dist_sup)

lemma circ_L:
  "L\<^sup>\<circ> = L \<squnion> 1"
  by (metis L_left_zero sup_commute circ_left_unfold)

lemma L_below_one_circ:
  "L \<le> 1\<^sup>\<circ>"
  by (metis L_def zero_right_mult_decreasing)

lemma circ_circ_mult_1:
  "x\<^sup>\<circ> * 1\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis L_left_zero sup_commute circ_sup_1 circ_circ_sup mult_zero_circ one_circ_split)

lemma circ_circ_mult:
  "1\<^sup>\<circ> * x\<^sup>\<circ> = x\<^sup>\<circ>\<^sup>\<circ>"
  by (metis antisym circ_circ_mult_1 circ_circ_sub_mult sub_mult_one_circ)

lemma circ_circ_split:
  "x\<^sup>\<circ>\<^sup>\<circ> = L \<squnion> x\<^sup>\<circ>"
  by (metis circ_circ_mult one_circ_mult_split)

lemma circ_sup_6:
  "L \<squnion> (x \<squnion> y)\<^sup>\<circ> = (x\<^sup>\<circ> * y\<^sup>\<circ>)\<^sup>\<circ>"
  by (metis sup_assoc sup_commute circ_sup_1 circ_circ_sup circ_circ_split circ_decompose_4)

end

class itering_L = itering + L +
  assumes L_def: "L = 1\<^sup>\<circ> * bot"
begin

lemma one_circ_split:
  "1\<^sup>\<circ> = L \<squnion> 1"
  by (metis L_def sup_commute antisym circ_sup_upper_bound circ_reflexive circ_simulate_absorb mult_1_right order_refl zero_right_mult_decreasing)

lemma one_circ_mult_split:
  "1\<^sup>\<circ> * x = L \<squnion> x"
  by (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)

lemma sub_mult_one_circ_split:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> L"
  by (metis sup_commute one_circ_mult_split sub_mult_one_circ)

lemma sub_mult_one_circ_split_2:
  "x * 1\<^sup>\<circ> \<le> x \<squnion> 1\<^sup>\<circ>"
  by (metis L_def sup_right_isotone order_trans sub_mult_one_circ_split zero_right_mult_decreasing)

lemma L_split:
  "x * L \<le> x * bot \<squnion> L"
  by (metis L_def mult_assoc mult_left_isotone mult_right_dist_sup sub_mult_one_circ_split_2)

subclass left_conway_semiring_L
  apply unfold_locales
  apply (metis L_def sup_commute circ_loop_fixpoint mult_assoc mult_left_zero mult_zero_circ one_circ_split)
  by (metis sup_commute mult_assoc mult_left_isotone one_circ_mult_split sub_mult_one_circ)

lemma circ_left_induct_mult_L:
  "L \<le> x \<Longrightarrow> x * y \<le> x \<Longrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis circ_one circ_simulate le_iff_sup one_circ_mult_split)

lemma circ_left_induct_mult_iff_L:
  "L \<le> x \<Longrightarrow> x * y \<le> x \<longleftrightarrow> x * y\<^sup>\<circ> \<le> x"
  by (metis sup.bounded_iff circ_back_loop_fixpoint circ_left_induct_mult_L le_iff_sup)

lemma circ_left_induct_L:
  "L \<le> x \<Longrightarrow> x * y \<squnion> z \<le> x \<Longrightarrow> z * y\<^sup>\<circ> \<le> x"
  by (metis sup.bounded_iff circ_left_induct_mult_L le_iff_sup mult_right_dist_sup)

end

end


section \<open> SI Prefixes \<close>

theory SI_Prefix
  imports SI_Constants
begin

subsection \<open> Definitions \<close>

text \<open> Prefixes are simply numbers that can be composed with units using the scalar
  multiplication operator \<^const>\<open>scaleQ\<close>. \<close>

default_sort ring_char_0

definition deca :: "'a" where [si_eq]: "deca = 10^1"

definition hecto :: "'a" where [si_eq]: "hecto = 10^2"

definition kilo :: "'a" where [si_eq]: "kilo = 10^3"

definition mega :: "'a" where [si_eq]: "mega = 10^6"

definition giga :: "'a" where [si_eq]: "giga = 10^9"

definition tera :: "'a" where [si_eq]: "tera = 10^12"

definition peta :: "'a" where [si_eq]: "peta = 10^15"

definition exa :: "'a" where [si_eq]: "exa = 10^18"

definition zetta :: "'a" where [si_eq]: "zetta = 10^21"

definition yotta :: "'a" where [si_eq]: "yotta = 10^24"

default_sort field_char_0

definition deci :: "'a" where [si_eq]: "deci = 1/10^1"

definition centi :: "'a" where [si_eq]: "centi = 1/10^2"

definition milli :: "'a" where [si_eq]: "milli = 1/10^3"

definition micro :: "'a" where [si_eq]: "micro = 1/10^6"

definition nano :: "'a" where [si_eq]: "nano = 1/10^9"

definition pico :: "'a" where [si_eq]: "pico = 1/10^12"

definition femto :: "'a" where [si_eq]: "femto = 1/10^15"

definition atto :: "'a" where [si_eq]: "atto = 1/10^18"

definition zepto :: "'a" where [si_eq]: "zepto = 1/10^21"

definition yocto :: "'a" where [si_eq]: "yocto = 1/10^24"

subsection \<open> Examples \<close>

lemma "2.3 *\<^sub>Q (centi *\<^sub>Q metre)\<^sup>\<three> = 2.3 \<cdot> 1/10^6 *\<^sub>Q metre\<^sup>\<three>"
  by (si_simp)

lemma "1 *\<^sub>Q (centi *\<^sub>Q metre)\<^sup>-\<^sup>\<one> = 100 *\<^sub>Q metre\<^sup>-\<^sup>\<one>"
  by (si_simp)

subsection \<open> Binary Prefixes \<close>

text \<open> Although not in general applicable to physical quantities, we include these prefixes
  for completeness. \<close>

default_sort ring_char_0

definition kibi :: "'a" where [si_eq]: "kibi = 2^10"

definition mebi :: "'a" where [si_eq]: "mebi = 2^20"

definition gibi :: "'a" where [si_eq]: "gibi = 2^30"

definition tebi :: "'a" where [si_eq]: "tebi = 2^40"

definition pebi :: "'a" where [si_eq]: "pebi = 2^50"

definition exbi :: "'a" where [si_eq]: "exbi = 2^60"

definition zebi :: "'a" where [si_eq]: "zebi = 2^70"

definition yobi :: "'a" where [si_eq]: "yobi = 2^80"

default_sort type

end


section {* \isaheader{Examples from ITP-2010 slides (adopted to ICF v2)} *}
theory itp_2010
imports
  "../../ICF/Collections"
  "../../Lib/Code_Target_ICF"
begin

text {*
  Illustrates the various possibilities how to use the ICF in your own
  algorithms by simple examples. The examples all use the data refinement
  scheme, and either define a generic algorithm or fix the operations.
*}

subsection "List to Set"
text {*
  In this simple example we do conversion from a list to a set.
  We define an abstract algorithm.
  This is then refined by a generic algorithm using a locale and by a generic
  algorithm fixing its operations as parameters.
*}
  subsubsection "Straightforward version"
  -- "Abstract algorithm"
  fun set_a where
    "set_a [] s = s" |
    "set_a (a#l) s = set_a l (insert a s)"

  -- "Correctness of aa"
  lemma set_a_correct: "set_a l s = set l \<union> s"
    by (induct l arbitrary: s) auto

  -- "Generic algorithm"

  setup Locale_Code.open_block -- "Required to make definitions inside locales
    executable"
  fun (in StdSetDefs) set_i where
    "set_i [] s = s" |
    "set_i (a#l) s = set_i l (ins a s)"
  setup Locale_Code.close_block

  -- "Correct implementation of ca"
  lemma (in StdSet) set_i_impl: "invar s \<Longrightarrow> invar (set_i l s) \<and> \<alpha> (set_i l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  -- "Instantiation"
  (* We need to declare a constant to make the code generator work *)

  definition "hs_seti == hs.set_i"
  (*declare hs.set_i.simps[folded hs_seti_def, code]*)

  lemmas hs_set_i_impl = hs.set_i_impl[folded hs_seti_def]

export_code hs_seti in SML

  -- "Code generation"
  ML {* @{code hs_seti} *}
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

  subsubsection "Tail-Recursive version"
  -- "Abstract algorithm"
  fun set_a2 where
    "set_a2 [] = {}" |
    "set_a2 (a#l) = (insert a (set_a2 l))"

  -- "Correctness of aa"
  lemma set_a2_correct: "set_a2 l = set l"
    by (induct l) auto

  -- "Generic algorithm"
  setup Locale_Code.open_block
  fun (in StdSetDefs) set_i2 where
    "set_i2 [] = empty ()" |
    "set_i2 (a#l) = (ins a (set_i2 l))"
  setup Locale_Code.close_block

  -- "Correct implementation of ca"
  lemma (in StdSet) set_i2_impl: "invar s \<Longrightarrow> invar (set_i2 l) \<and> \<alpha> (set_i2 l) = set_a2 l"
    by (induct l) (auto simp add: correct)

  -- "Instantiation"
  definition "hs_seti2 == hs.set_i2"
  (*declare hsr.set_i2.simps[folded hs_seti2_def, code]*)

  lemmas hs_set_i2_impl = hs.set_i2_impl[folded hs_seti2_def]

  -- "Code generation"
  ML {* @{code hs_seti2} *}
  (*value "hs_seti [1,2,3::nat] hs_empty"*)

subsubsection "With explicit operation parameters"

  -- "Alternative for few operation parameters"
  fun set_i' where
    "!!ins. set_i' ins [] s = s" |
    "!!ins. set_i' ins (a#l) s = set_i' ins l (ins a s)"

  lemma (in StdSet) set_i'_impl:
    "invar s \<Longrightarrow> invar (set_i' ins l s) \<and> \<alpha> (set_i' ins l s) = set_a l (\<alpha> s)"
    by (induct l arbitrary: s) (auto simp add: correct)

  -- "Instantiation"
  definition "hs_seti' == set_i' hs.ins"
  lemmas hs_set_i'_impl = hs.set_i'_impl[folded hs_seti'_def]

  -- "Code generation"
  ML {* @{code hs_seti'} *}
  (*value "hs_seti' [1,2,3::nat] hs_empty"*)

subsection "Filter Average"
text {*
  In this more complex example, we develop a function that filters from a set all
  numbers that are above the average of the set.

  First, we formulate this as a generic algorithm using a locale.
  This solution shows how the ICF v2 overcomes some technical problems that
  ICF v1 had:
  \begin{itemize}
    \item Iterators are now polymorphic in the type, even inside locales.
      Hence, there is no special handling of iterators, as it was required
      in ICF v1.
    \item The Locale-Code package handles code generation for the instantiated
      locale. There is no need for lengthy boilerplate code as it was required
      in ICF v1.
  \end{itemize}

  Another possibility is to fix the used
  implementations beforehand. Changing the implementation is still easy by
  changing the used operations. In this example, all used operations are
  introduced by abbbreviations, localizing the required changes to a small part
  of the theory. This approach is more powerful, as operations are now
  polymorphic also in the element type. However, it only allows as single
  instantiation at a time, which is no option for generic algorithms.
*}

  abbreviation "average S == \<Sum>S div card S"

subsubsection "Generic Algorithm"
  locale MyContext =
    StdSet ops for ops :: "(nat,'s,'more) set_ops_scheme"
  begin
    definition avg_aux :: "'s \<Rightarrow> nat\<times>nat"
      where
      "avg_aux s == iterate s (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

    definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

    definition "filter_le_avg s == let a=avg s in
      iterate s (\<lambda>x s. if x\<le>a then ins x s else s) (empty ())"

    lemma avg_aux_correct: "invar s \<Longrightarrow> avg_aux s = (card (\<alpha> s), \<Sum>(\<alpha> s) )"
      apply (unfold avg_aux_def)
      apply (rule_tac
        I="\<lambda>it (c,sum). c=card (\<alpha> s - it) \<and> sum=\<Sum>(\<alpha> s - it)"
        in iterate_rule_P)
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      apply (subgoal_tac "\<alpha> s - (it - {x}) = insert x (\<alpha> s - it)")
      apply auto
      done

    lemma avg_correct: "invar s \<Longrightarrow> avg s = average (\<alpha> s)"
      unfolding avg_def
      using avg_aux_correct
      by auto

    lemma filter_le_avg_correct:
      "invar s \<Longrightarrow>
        invar (filter_le_avg s) \<and>
        \<alpha> (filter_le_avg s) = {x\<in>\<alpha> s. x\<le>average (\<alpha> s)}"
      unfolding filter_le_avg_def Let_def
      apply (rule_tac
        I="\<lambda>it r. invar r \<and> \<alpha> r = {x\<in>\<alpha> s - it. x\<le>average (\<alpha> s)}"
        in iterate_rule_P)
      apply (auto simp add: correct avg_correct)
      done
  end

  setup Locale_Code.open_block
  interpretation hs_ctx: MyContext hs_ops by unfold_locales
  interpretation rs_ctx: MyContext rs_ops by unfold_locales
  setup Locale_Code.close_block

  definition "hs_flt_avg_test \<equiv> hs.to_list
    o hs_ctx.filter_le_avg
    o hs.from_list"
  definition "rs_flt_avg_test \<equiv> rs.to_list
    o rs_ctx.filter_le_avg
    o rs.from_list"

  text "Code generation"
  ML_val {*
    if @{code hs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    <> @{code rs_flt_avg_test} (map @{code nat_of_integer} [1,2,3,4,6,7])
    then error "Oops"
    else ()
    *}

subsubsection "Using abbreviations"

  type_synonym 'a my_set = "'a hs"
  abbreviation "my_\<alpha> == hs.\<alpha>"
  abbreviation "my_invar == hs.invar"
  abbreviation "my_empty == hs.empty"
  abbreviation "my_ins == hs.ins"
  abbreviation "my_iterate == hs.iteratei"
  lemmas my_correct = hs.correct
  lemmas my_iterate_rule_P = hs.iterate_rule_P

  definition avg_aux :: "nat my_set \<Rightarrow> nat\<times>nat"
    where
    "avg_aux s == my_iterate s (\<lambda>_. True) (\<lambda>x (c,s). (c+1, s+x)) (0,0)"

  definition "avg s == case avg_aux s of (c,s) \<Rightarrow> s div c"

  definition "filter_le_avg s == let a=avg s in
    my_iterate s (\<lambda>_. True) (\<lambda>x s. if x\<le>a then my_ins x s else s) (my_empty ())"

  lemma avg_aux_correct: "my_invar s \<Longrightarrow> avg_aux s = (card (my_\<alpha> s), \<Sum>(my_\<alpha> s) )"
    apply (unfold avg_aux_def)
    apply (rule_tac
      I="\<lambda>it (c,sum). c=card (my_\<alpha> s - it) \<and> sum=\<Sum>(my_\<alpha> s - it)"
      in my_iterate_rule_P)
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    apply (subgoal_tac "my_\<alpha> s - (it - {x}) = insert x (my_\<alpha> s - it)")
    apply auto
    done

  lemma avg_correct: "my_invar s \<Longrightarrow> avg s = average (my_\<alpha> s)"
    unfolding avg_def
    using avg_aux_correct
    by auto

  lemma filter_le_avg_correct:
    "my_invar s \<Longrightarrow>
    my_invar (filter_le_avg s) \<and>
    my_\<alpha> (filter_le_avg s) = {x\<in>my_\<alpha> s. x\<le>average (my_\<alpha> s)}"
    unfolding filter_le_avg_def Let_def
    apply (rule_tac
      I="\<lambda>it r. my_invar r \<and> my_\<alpha> r = {x\<in>my_\<alpha> s - it. x\<le>average (my_\<alpha> s)}"
      in my_iterate_rule_P)
    apply (auto simp add: my_correct avg_correct)
    done

  definition "test_set == my_ins (1::nat) (my_ins 2 (my_ins 3 (my_empty ())))"

  export_code avg_aux avg filter_le_avg test_set in SML module_name Test

end


(*  Title:      HOL/Library/Product_Order.thy
    Author:     Brian Huffman
*)

section \<open>Pointwise order on product types\<close>

theory Product_Order
imports Product_Plus
begin

subsection \<open>Pointwise ordering\<close>

instantiation prod :: (ord, ord) ord
begin

definition
  "x \<le> y \<longleftrightarrow> fst x \<le> fst y \<and> snd x \<le> snd y"

definition
  "(x::'a \<times> 'b) < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

instance ..

end

lemma fst_mono: "x \<le> y \<Longrightarrow> fst x \<le> fst y"
  unfolding less_eq_prod_def by simp

lemma snd_mono: "x \<le> y \<Longrightarrow> snd x \<le> snd y"
  unfolding less_eq_prod_def by simp

lemma Pair_mono: "x \<le> x' \<Longrightarrow> y \<le> y' \<Longrightarrow> (x, y) \<le> (x', y')"
  unfolding less_eq_prod_def by simp

lemma Pair_le [simp]: "(a, b) \<le> (c, d) \<longleftrightarrow> a \<le> c \<and> b \<le> d"
  unfolding less_eq_prod_def by simp

lemma atLeastAtMost_prod_eq: "{a..b} = {fst a..fst b} \<times> {snd a..snd b}"
  by (auto simp: less_eq_prod_def)

instance prod :: (preorder, preorder) preorder
proof
  fix x y z :: "'a \<times> 'b"
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    by (rule less_prod_def)
  show "x \<le> x"
    unfolding less_eq_prod_def
    by fast
  assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
    unfolding less_eq_prod_def
    by (fast elim: order_trans)
qed

instance prod :: (order, order) order
  by standard auto

subsection \<open>Binary infimum and supremum\<close>

instantiation prod :: (inf, inf) inf
begin

definition "inf x y = (inf (fst x) (fst y), inf (snd x) (snd y))"

lemma inf_Pair_Pair [simp]: "inf (a, b) (c, d) = (inf a c, inf b d)"
  unfolding inf_prod_def by simp

lemma fst_inf [simp]: "fst (inf x y) = inf (fst x) (fst y)"
  unfolding inf_prod_def by simp

lemma snd_inf [simp]: "snd (inf x y) = inf (snd x) (snd y)"
  unfolding inf_prod_def by simp

instance ..

end

instance prod :: (semilattice_inf, semilattice_inf) semilattice_inf
  by standard auto

instantiation prod :: (sup, sup) sup
begin

definition
  "sup x y = (sup (fst x) (fst y), sup (snd x) (snd y))"

lemma sup_Pair_Pair [simp]: "sup (a, b) (c, d) = (sup a c, sup b d)"
  unfolding sup_prod_def by simp

lemma fst_sup [simp]: "fst (sup x y) = sup (fst x) (fst y)"
  unfolding sup_prod_def by simp

lemma snd_sup [simp]: "snd (sup x y) = sup (snd x) (snd y)"
  unfolding sup_prod_def by simp

instance ..

end

instance prod :: (semilattice_sup, semilattice_sup) semilattice_sup
  by standard auto

instance prod :: (lattice, lattice) lattice ..

instance prod :: (distrib_lattice, distrib_lattice) distrib_lattice
  by standard (auto simp add: sup_inf_distrib1)

subsection \<open>Top and bottom elements\<close>

instantiation prod :: (top, top) top
begin

definition
  "top = (top, top)"

instance ..

end

lemma fst_top [simp]: "fst top = top"
  unfolding top_prod_def by simp

lemma snd_top [simp]: "snd top = top"
  unfolding top_prod_def by simp

lemma Pair_top_top: "(top, top) = top"
  unfolding top_prod_def by simp

instance prod :: (order_top, order_top) order_top
  by standard (auto simp add: top_prod_def)

instantiation prod :: (bot, bot) bot
begin

definition
  "bot = (bot, bot)"

instance ..

end

lemma fst_bot [simp]: "fst bot = bot"
  unfolding bot_prod_def by simp

lemma snd_bot [simp]: "snd bot = bot"
  unfolding bot_prod_def by simp

lemma Pair_bot_bot: "(bot, bot) = bot"
  unfolding bot_prod_def by simp

instance prod :: (order_bot, order_bot) order_bot
  by standard (auto simp add: bot_prod_def)

instance prod :: (bounded_lattice, bounded_lattice) bounded_lattice ..

instance prod :: (boolean_algebra, boolean_algebra) boolean_algebra
  by standard (auto simp add: prod_eqI diff_eq)

subsection \<open>Complete lattice operations\<close>

instantiation prod :: (Inf, Inf) Inf
begin

definition "Inf A = (INF x\<in>A. fst x, INF x\<in>A. snd x)"

instance ..

end

instantiation prod :: (Sup, Sup) Sup
begin

definition "Sup A = (SUP x\<in>A. fst x, SUP x\<in>A. snd x)"

instance ..

end

instance prod :: (conditionally_complete_lattice, conditionally_complete_lattice)
    conditionally_complete_lattice
  by standard (force simp: less_eq_prod_def Inf_prod_def Sup_prod_def bdd_below_def bdd_above_def
    intro!: cInf_lower cSup_upper cInf_greatest cSup_least)+

instance prod :: (complete_lattice, complete_lattice) complete_lattice
  by standard (simp_all add: less_eq_prod_def Inf_prod_def Sup_prod_def
    INF_lower SUP_upper le_INF_iff SUP_le_iff bot_prod_def top_prod_def)

lemma fst_Inf: "fst (Inf A) = (INF x\<in>A. fst x)"
  by (simp add: Inf_prod_def)

lemma fst_INF: "fst (INF x\<in>A. f x) = (INF x\<in>A. fst (f x))"
  by (simp add: fst_Inf image_image)

lemma fst_Sup: "fst (Sup A) = (SUP x\<in>A. fst x)"
  by (simp add: Sup_prod_def)

lemma fst_SUP: "fst (SUP x\<in>A. f x) = (SUP x\<in>A. fst (f x))"
  by (simp add: fst_Sup image_image)

lemma snd_Inf: "snd (Inf A) = (INF x\<in>A. snd x)"
  by (simp add: Inf_prod_def)

lemma snd_INF: "snd (INF x\<in>A. f x) = (INF x\<in>A. snd (f x))"
  by (simp add: snd_Inf image_image)

lemma snd_Sup: "snd (Sup A) = (SUP x\<in>A. snd x)"
  by (simp add: Sup_prod_def)

lemma snd_SUP: "snd (SUP x\<in>A. f x) = (SUP x\<in>A. snd (f x))"
  by (simp add: snd_Sup image_image)

lemma INF_Pair: "(INF x\<in>A. (f x, g x)) = (INF x\<in>A. f x, INF x\<in>A. g x)"
  by (simp add: Inf_prod_def image_image)

lemma SUP_Pair: "(SUP x\<in>A. (f x, g x)) = (SUP x\<in>A. f x, SUP x\<in>A. g x)"
  by (simp add: Sup_prod_def image_image)

text \<open>Alternative formulations for set infima and suprema over the product
of two complete lattices:\<close>

lemma INF_prod_alt_def: \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
  "Inf (f ` A) = (Inf ((fst \<circ> f) ` A), Inf ((snd \<circ> f) ` A))"
  by (simp add: Inf_prod_def image_image)

lemma SUP_prod_alt_def: \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
  "Sup (f ` A) = (Sup ((fst \<circ> f) ` A), Sup((snd \<circ> f) ` A))"
  by (simp add: Sup_prod_def image_image)

subsection \<open>Complete distributive lattices\<close>

instance prod :: (complete_distrib_lattice, complete_distrib_lattice) complete_distrib_lattice \<^marker>\<open>contributor \<open>Alessandro Coglio\<close>\<close>
proof
  fix A::"('a\<times>'b) set set"
  show "Inf (Sup ` A) \<le> Sup (Inf ` {f ` A |f. \<forall>Y\<in>A. f Y \<in> Y})"
    by (simp add: Inf_prod_def Sup_prod_def INF_SUP_set image_image)
qed

subsection \<open>Bekic's Theorem\<close>
text \<open>
  Simultaneous fixed points over pairs can be written in terms of separate fixed points.
  Transliterated from HOLCF.Fix by Peter Gammie
\<close>

lemma lfp_prod:
  fixes F :: "'a::complete_lattice \<times> 'b::complete_lattice \<Rightarrow> 'a \<times> 'b"
  assumes "mono F"
  shows "lfp F = (lfp (\<lambda>x. fst (F (x, lfp (\<lambda>y. snd (F (x, y)))))),
                 (lfp (\<lambda>y. snd (F (lfp (\<lambda>x. fst (F (x, lfp (\<lambda>y. snd (F (x, y)))))), y)))))"
  (is "lfp F = (?x, ?y)")
proof(rule lfp_eqI[OF assms])
  have 1: "fst (F (?x, ?y)) = ?x"
    by (rule trans [symmetric, OF lfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono lfp_mono)+
  have 2: "snd (F (?x, ?y)) = ?y"
    by (rule trans [symmetric, OF lfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono lfp_mono)+
  from 1 2 show "F (?x, ?y) = (?x, ?y)" by (simp add: prod_eq_iff)
next
  fix z assume F_z: "F z = z"
  obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F (x, y)) = x" by simp
  from F_z z have F_y: "snd (F (x, y)) = y" by simp
  let ?y1 = "lfp (\<lambda>y. snd (F (x, y)))"
  have "?y1 \<le> y" by (rule lfp_lowerbound, simp add: F_y)
  hence "fst (F (x, ?y1)) \<le> fst (F (x, y))"
    by (simp add: assms fst_mono monoD)
  hence "fst (F (x, ?y1)) \<le> x" using F_x by simp
  hence 1: "?x \<le> x" by (simp add: lfp_lowerbound)
  hence "snd (F (?x, y)) \<le> snd (F (x, y))"
    by (simp add: assms snd_mono monoD)
  hence "snd (F (?x, y)) \<le> y" using F_y by simp
  hence 2: "?y \<le> y" by (simp add: lfp_lowerbound)
  show "(?x, ?y) \<le> z" using z 1 2 by simp
qed

lemma gfp_prod:
  fixes F :: "'a::complete_lattice \<times> 'b::complete_lattice \<Rightarrow> 'a \<times> 'b"
  assumes "mono F"
  shows "gfp F = (gfp (\<lambda>x. fst (F (x, gfp (\<lambda>y. snd (F (x, y)))))),
                 (gfp (\<lambda>y. snd (F (gfp (\<lambda>x. fst (F (x, gfp (\<lambda>y. snd (F (x, y)))))), y)))))"
  (is "gfp F = (?x, ?y)")
proof(rule gfp_eqI[OF assms])
  have 1: "fst (F (?x, ?y)) = ?x"
    by (rule trans [symmetric, OF gfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono gfp_mono)+
  have 2: "snd (F (?x, ?y)) = ?y"
    by (rule trans [symmetric, OF gfp_unfold])
       (blast intro!: monoI monoD[OF assms(1)] fst_mono snd_mono Pair_mono gfp_mono)+
  from 1 2 show "F (?x, ?y) = (?x, ?y)" by (simp add: prod_eq_iff)
next
  fix z assume F_z: "F z = z"
  obtain x y where z: "z = (x, y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F (x, y)) = x" by simp
  from F_z z have F_y: "snd (F (x, y)) = y" by simp
  let ?y1 = "gfp (\<lambda>y. snd (F (x, y)))"
  have "y \<le> ?y1" by (rule gfp_upperbound, simp add: F_y)
  hence "fst (F (x, y)) \<le> fst (F (x, ?y1))"
    by (simp add: assms fst_mono monoD)
  hence "x \<le> fst (F (x, ?y1))" using F_x by simp
  hence 1: "x \<le> ?x" by (simp add: gfp_upperbound)
  hence "snd (F (x, y)) \<le> snd (F (?x, y))"
    by (simp add: assms snd_mono monoD)
  hence "y \<le> snd (F (?x, y))" using F_y by simp
  hence 2: "y \<le> ?y" by (simp add: gfp_upperbound)
  show "z \<le> (?x, ?y)" using z 1 2 by simp
qed

end