(*  Title:      HOL/Word/Misc_Arithmetic.thy  *)

section \<open>Miscellaneous lemmas, mostly for arithmetic\<close>

theory Misc_Arithmetic
  imports Misc_Auxiliary "HOL-Library.Z2"
begin

lemma one_mod_exp_eq_one [simp]:
  "1 mod (2 * 2 ^ n) = (1::int)"
  using power_gt1 [of 2 n] by (auto intro: mod_pos_pos_trivial)

lemma mod_2_neq_1_eq_eq_0: "k mod 2 \<noteq> 1 \<longleftrightarrow> k mod 2 = 0"
  for k :: int
  by (fact not_mod_2_eq_1_eq_0)

lemma z1pmod2: "(2 * b + 1) mod 2 = (1::int)"
  for b :: int
  by arith

lemma diff_le_eq': "a - b \<le> c \<longleftrightarrow> a \<le> b + c"
  for a b c :: int
  by arith

lemma zless2: "0 < (2 :: int)"
  by (fact zero_less_numeral)

lemma zless2p: "0 < (2 ^ n :: int)"
  by arith

lemma zle2p: "0 \<le> (2 ^ n :: int)"
  by arith

lemma p1mod22k': "(1 + 2 * b) mod (2 * 2 ^ n) = 1 + 2 * (b mod 2 ^ n)"
  for b :: int
  using zle2p by (rule pos_zmod_mult_2)

lemma p1mod22k: "(2 * b + 1) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n) + 1"
  for b :: int
  by (simp add: p1mod22k' add.commute)

lemma ex_eq_or: "(\<exists>m. n = Suc m \<and> (m = k \<or> P m)) \<longleftrightarrow> n = Suc k \<or> (\<exists>m. n = Suc m \<and> P m)"
  by auto

lemma power_minus_simp: "0 < n \<Longrightarrow> a ^ n = a * a ^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma funpow_minus_simp: "0 < n \<Longrightarrow> f ^^ n = f \<circ> f ^^ (n - 1)"
  by (auto dest: gr0_implies_Suc)

lemma power_numeral: "a ^ numeral k = a * a ^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma funpow_numeral [simp]: "f ^^ numeral k = f \<circ> f ^^ (pred_numeral k)"
  by (simp add: numeral_eq_Suc)

lemma replicate_numeral [simp]: "replicate (numeral k) x = x # replicate (pred_numeral k) x"
  by (simp add: numeral_eq_Suc)

lemma rco_alt: "(f \<circ> g) ^^ n \<circ> f = f \<circ> (g \<circ> f) ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (simp_all add: o_def)
  done

lemma list_exhaust_size_gt0:
  assumes "\<And>a list. y = a # list \<Longrightarrow> P"
  shows "0 < length y \<Longrightarrow> P"
  apply (cases y)
   apply simp
  apply (rule assms)
  apply fastforce
  done

lemma list_exhaust_size_eq0:
  assumes "y = [] \<Longrightarrow> P"
  shows "length y = 0 \<Longrightarrow> P"
  apply (cases y)
   apply (rule assms)
   apply simp
  apply simp
  done

lemma size_Cons_lem_eq: "y = xa # list \<Longrightarrow> size y = Suc k \<Longrightarrow> size list = k"
  by auto

lemmas ls_splits = prod.split prod.split_asm if_split_asm

\<comment> \<open>simplifications for specific word lengths\<close>
lemmas n2s_ths [THEN eq_reflection] = add_2_eq_Suc add_2_eq_Suc'

lemmas s2n_ths = n2s_ths [symmetric]

lemma and_len: "xs = ys \<Longrightarrow> xs = ys \<and> length xs = length ys"
  by auto

lemma size_if: "size (if p then xs else ys) = (if p then size xs else size ys)"
  by auto

lemma tl_if: "tl (if p then xs else ys) = (if p then tl xs else tl ys)"
  by auto

lemma hd_if: "hd (if p then xs else ys) = (if p then hd xs else hd ys)"
  by auto

lemma if_Not_x: "(if p then \<not> x else x) = (p = (\<not> x))"
  by auto

lemma if_x_Not: "(if p then x else \<not> x) = (p = x)"
  by auto

lemma if_same_and: "(If p x y \<and> If p u v) = (if p then x \<and> u else y \<and> v)"
  by auto

lemma if_same_eq: "(If p x y  = (If p u v)) = (if p then x = u else y = v)"
  by auto

lemma if_same_eq_not: "(If p x y = (\<not> If p u v)) = (if p then x = (\<not> u) else y = (\<not> v))"
  by auto

\<comment> \<open>note -- \<open>if_Cons\<close> can cause blowup in the size, if \<open>p\<close> is complex, so make a simproc\<close>
lemma if_Cons: "(if p then x # xs else y # ys) = If p x y # If p xs ys"
  by auto

lemma if_single: "(if xc then [xab] else [an]) = [if xc then xab else an]"
  by auto

lemma if_bool_simps:
  "If p True y = (p \<or> y) \<and> If p False y = (\<not> p \<and> y) \<and>
    If p y True = (p \<longrightarrow> y) \<and> If p y False = (p \<and> y)"
  by auto

lemmas if_simps =
  if_x_Not if_Not_x if_cancel if_True if_False if_bool_simps

lemmas seqr = eq_reflection [where x = "size w"] for w (* FIXME: delete *)

lemma the_elemI: "y = {x} \<Longrightarrow> the_elem y = x"
  by simp

lemma nonemptyE: "S \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> R) \<Longrightarrow> R"
  by auto

lemma gt_or_eq_0: "0 < y \<or> 0 = y"
  for y :: nat
  by arith

lemmas xtr1 = xtrans(1)
lemmas xtr2 = xtrans(2)
lemmas xtr3 = xtrans(3)
lemmas xtr4 = xtrans(4)
lemmas xtr5 = xtrans(5)
lemmas xtr6 = xtrans(6)
lemmas xtr7 = xtrans(7)
lemmas xtr8 = xtrans(8)

lemmas nat_simps = diff_add_inverse2 diff_add_inverse
lemmas nat_iffs = le_add1 le_add2

lemma sum_imp_diff: "j = k + i \<Longrightarrow> j - i = k"
  for k :: nat
  by arith

lemmas pos_mod_sign2 = zless2 [THEN pos_mod_sign [where b = "2::int"]]
lemmas pos_mod_bound2 = zless2 [THEN pos_mod_bound [where b = "2::int"]]

lemma nmod2: "n mod 2 = 0 \<or> n mod 2 = 1"
  for n :: int
  by arith

lemma eme1p:
  "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (1 + n) mod d = 1 + n mod d" for n d :: int
  using emep1 [of n d] by (simp add: ac_simps)

lemma le_diff_eq': "a \<le> c - b \<longleftrightarrow> b + a \<le> c"
  for a b c :: int
  by arith

lemma less_diff_eq': "a < c - b \<longleftrightarrow> b + a < c"
  for a b c :: int
  by arith

lemma diff_less_eq': "a - b < c \<longleftrightarrow> a < b + c"
  for a b c :: int
  by arith

lemmas m1mod22k = mult_pos_pos [OF zless2 zless2p, THEN zmod_minus1]

lemma z1pdiv2: "(2 * b + 1) div 2 = b"
  for b :: int
  by arith

lemmas zdiv_le_dividend = xtr3 [OF div_by_1 [symmetric] zdiv_mono2,
  simplified int_one_le_iff_zero_less, simplified]

lemma axxbyy: "a + m + m = b + n + n \<Longrightarrow> a = 0 \<or> a = 1 \<Longrightarrow> b = 0 \<or> b = 1 \<Longrightarrow> a = b \<and> m = n"
  for a b m n :: int
  by arith

lemma axxmod2: "(1 + x + x) mod 2 = 1 \<and> (0 + x + x) mod 2 = 0"
  for x :: int
  by arith

lemma axxdiv2: "(1 + x + x) div 2 = x \<and> (0 + x + x) div 2 = x"
  for x :: int
  by arith

lemmas iszero_minus =
  trans [THEN trans, OF iszero_def neg_equal_0_iff_equal iszero_def [symmetric]]

lemmas zadd_diff_inverse =
  trans [OF diff_add_cancel [symmetric] add.commute]

lemmas add_diff_cancel2 =
  add.commute [THEN diff_eq_eq [THEN iffD2]]

lemmas rdmods [symmetric] = mod_minus_eq
  mod_diff_left_eq mod_diff_right_eq mod_add_left_eq
  mod_add_right_eq mod_mult_right_eq mod_mult_left_eq

lemma mod_plus_right: "(a + x) mod m = (b + x) mod m \<longleftrightarrow> a mod m = b mod m"
  for a b m x :: nat
  by (induct x) (simp_all add: mod_Suc, arith)

lemma nat_minus_mod: "(n - n mod m) mod m = 0"
  for m n :: nat
  by (induct n) (simp_all add: mod_Suc)

lemmas nat_minus_mod_plus_right =
  trans [OF nat_minus_mod mod_0 [symmetric],
    THEN mod_plus_right [THEN iffD2], simplified]

lemmas push_mods' = mod_add_eq
  mod_mult_eq mod_diff_eq
  mod_minus_eq

lemmas push_mods = push_mods' [THEN eq_reflection]
lemmas pull_mods = push_mods [symmetric] rdmods [THEN eq_reflection]

lemma nat_mod_eq: "b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
  for a b n :: nat
  by (induct a) auto

lemmas nat_mod_eq' = refl [THEN [2] nat_mod_eq]

lemma nat_mod_lem: "0 < n \<Longrightarrow> b < n \<longleftrightarrow> b mod n = b"
  for b n :: nat
  apply safe
   apply (erule nat_mod_eq')
  apply (erule subst)
  apply (erule mod_less_divisor)
  done

lemma mod_nat_add: "x < z \<Longrightarrow> y < z \<Longrightarrow> (x + y) mod z = (if x + y < z then x + y else x + y - z)"
  for x y z :: nat
  apply (rule nat_mod_eq)
   apply auto
  apply (rule trans)
   apply (rule le_mod_geq)
   apply simp
  apply (rule nat_mod_eq')
  apply arith
  done

lemma mod_nat_sub: "x < z \<Longrightarrow> (x - y) mod z = x - y"
  for x y :: nat
  by (rule nat_mod_eq') arith

lemma int_mod_eq: "0 \<le> b \<Longrightarrow> b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
  for a b n :: int
  by (metis mod_pos_pos_trivial)

lemmas int_mod_eq' = mod_pos_pos_trivial (* FIXME delete *)

lemmas int_mod_le = zmod_le_nonneg_dividend (* FIXME: delete *)

lemma mod_add_if_z:
  "x < z \<Longrightarrow> y < z \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> z \<Longrightarrow>
    (x + y) mod z = (if x + y < z then x + y else x + y - z)"
  for x y z :: int
  by (auto intro: int_mod_eq)

lemma mod_sub_if_z:
  "x < z \<Longrightarrow> y < z \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> z \<Longrightarrow>
    (x - y) mod z = (if y \<le> x then x - y else x - y + z)"
  for x y z :: int
  by (auto intro: int_mod_eq)

lemmas zmde = mult_div_mod_eq [symmetric, THEN diff_eq_eq [THEN iffD2], symmetric]
lemmas mcl = mult_cancel_left [THEN iffD1, THEN make_pos_rule]

(* already have this for naturals, div_mult_self1/2, but not for ints *)
lemma zdiv_mult_self: "m \<noteq> 0 \<Longrightarrow> (a + m * n) div m = a div m + n"
  for a m n :: int
  apply (rule mcl)
   prefer 2
   apply (erule asm_rl)
  apply (simp add: zmde ring_distribs)
  done

lemma mod_power_lem: "a > 1 \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
  for a :: int
  by (simp add: mod_eq_0_iff_dvd le_imp_power_dvd)

lemma pl_pl_rels: "a + b = c + d \<Longrightarrow> a \<ge> c \<and> b \<le> d \<or> a \<le> c \<and> b \<ge> d"
  for a b c d :: nat
  by arith

lemmas pl_pl_rels' = add.commute [THEN [2] trans, THEN pl_pl_rels]

lemma minus_eq: "m - k = m \<longleftrightarrow> k = 0 \<or> m = 0"
  for k m :: nat
  by arith

lemma pl_pl_mm: "a + b = c + d \<Longrightarrow> a - c = d - b"
  for a b c d :: nat
  by arith

lemmas pl_pl_mm' = add.commute [THEN [2] trans, THEN pl_pl_mm]

lemmas dme = div_mult_mod_eq
lemmas dtle = div_times_less_eq_dividend
lemmas th2 = order_trans [OF order_refl [THEN [2] mult_le_mono] div_times_less_eq_dividend]

lemma td_gal: "0 < c \<Longrightarrow> a \<ge> b * c \<longleftrightarrow> a div c \<ge> b"
  for a b c :: nat
  apply safe
   apply (erule (1) xtr4 [OF div_le_mono div_mult_self_is_m])
  apply (erule th2)
  done

lemmas td_gal_lt = td_gal [simplified not_less [symmetric], simplified]

lemmas div_mult_le = div_times_less_eq_dividend

lemmas sdl = div_nat_eqI

lemma given_quot: "f > 0 \<Longrightarrow> (f * l + (f - 1)) div f = l"
  for f l :: nat
  by (rule div_nat_eqI) (simp_all)

lemma given_quot_alt: "f > 0 \<Longrightarrow> (l * f + f - Suc 0) div f = l"
  for f l :: nat
  apply (frule given_quot)
  apply (rule trans)
   prefer 2
   apply (erule asm_rl)
  apply (rule_tac f="\<lambda>n. n div f" in arg_cong)
  apply (simp add : ac_simps)
  done

lemma diff_mod_le: "a < d \<Longrightarrow> b dvd d \<Longrightarrow> a - a mod b \<le> d - b"
  for a b d :: nat
  apply (unfold dvd_def)
  apply clarify
  apply (case_tac k)
   apply clarsimp
  apply clarify
  apply (cases "b > 0")
   apply (drule mult.commute [THEN xtr1])
   apply (frule (1) td_gal_lt [THEN iffD1])
   apply (clarsimp simp: le_simps)
   apply (rule minus_mod_eq_mult_div [symmetric, THEN [2] xtr4])
   apply (rule mult_mono)
      apply auto
  done

lemma less_le_mult': "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> (w + 1) * c \<le> b * c"
  for b c w :: int
  apply (rule mult_right_mono)
   apply (rule zless_imp_add1_zle)
   apply (erule (1) mult_right_less_imp_less)
  apply assumption
  done

lemma less_le_mult: "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> w * c + c \<le> b * c"
  for b c w :: int
  using less_le_mult' [of w c b] by (simp add: algebra_simps)

lemmas less_le_mult_minus = iffD2 [OF le_diff_eq less_le_mult,
  simplified left_diff_distrib]

lemma gen_minus: "0 < n \<Longrightarrow> f n = f (Suc (n - 1))"
  by auto

lemma mpl_lem: "j \<le> i \<Longrightarrow> k < j \<Longrightarrow> i - j + k < i"
  for i j k :: nat
  by arith

lemma nonneg_mod_div: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> (a mod b) \<and> 0 \<le> a div b"
  for a b :: int
  by (cases "b = 0") (auto intro: pos_imp_zdiv_nonneg_iff [THEN iffD2])

declare iszero_0 [intro]

lemma min_pm [simp]: "min a b + (a - b) = a"
  for a b :: nat
  by arith

lemma min_pm1 [simp]: "a - b + min a b = a"
  for a b :: nat
  by arith

lemma rev_min_pm [simp]: "min b a + (a - b) = a"
  for a b :: nat
  by arith

lemma rev_min_pm1 [simp]: "a - b + min b a = a"
  for a b :: nat
  by arith

lemma min_minus [simp]: "min m (m - k) = m - k"
  for m k :: nat
  by arith

lemma min_minus' [simp]: "min (m - k) m = m - k"
  for m k :: nat
  by arith

lemmas m2pths = pos_mod_sign pos_mod_bound [OF zless2p]

lemma not_B1_is_B0: "y \<noteq> 1 \<Longrightarrow> y = 0"
  for y :: bit
  by (cases y) auto

lemma B1_ass_B0:
  fixes y :: bit
  assumes y: "y = 0 \<Longrightarrow> y = 1"
  shows "y = 1"
  apply (rule classical)
  apply (drule not_B1_is_B0)
  apply (erule y)
  done

end


theory FixRestr
  imports HOLCF
begin

find_consts name:funpow
term Nat.funpow

definition chainFrom :: "('a => 'a) => ('a :: cpo) => bool"
  where "chainFrom F x = ((\<forall>n. (F^^n) x \<sqsubseteq> F ((F^^n) x)) \<and> (F (\<Squnion> i. ((F^^i) x)) = (\<Squnion> i. F ((F^^i) x))))"

lemma chainFrom_chain [simp]: "chainFrom F x \<Longrightarrow> chain (\<lambda>i. (F^^i) x)"
  by (rule chainI, auto simp add: chainFrom_def)

lemma iterate_stays_above: "chainFrom F x  \<Longrightarrow> x \<sqsubseteq> (F^^n) x"
  apply (drule chainFrom_chain)
  apply (rule nat_induct)
  apply (auto simp add: chain_def)
  by (metis rev_below_trans)

lemma lub_chainFrom_arg: "chainFrom F x \<Longrightarrow> F (\<Squnion> i. ((F^^i) x)) = (\<Squnion> i. F ((F^^i) x))"
  by (simp add: chainFrom_def)

definition
  "fixR" :: "'a \<Rightarrow> ('a::cpo => 'a) \<Rightarrow> 'a" where
  "fixR x F = (if chainFrom F x then (\<Squnion>i. (F^^i) x) else x)"

lemma iterate_below_fix: "chainFrom F x  \<Longrightarrow> (F^^n) x \<sqsubseteq> fixR x F"
  unfolding fixR_def
  apply (subst if_P, assumption)
  using chainFrom_chain
  by (rule is_ub_thelub)

lemma fix_eq: "chainFrom F x \<Longrightarrow> fixR x F = F (fixR x F)"
  apply (simp add: fixR_def)
  apply (subst lub_range_shift [of _ 1, symmetric])
  apply (erule chainFrom_chain)
  thm contlub_cfun_arg
  apply (subst lub_chainFrom_arg, assumption)
  apply (drule chainFrom_chain)
  apply (simp add: chain_def)
  done

lemma fixR_ind: "\<lbrakk> adm P; P x; chainFrom F x; \<And>i. \<lbrakk>x \<sqsubseteq> (F^^i) x ; P ((F^^i) x)\<rbrakk> \<Longrightarrow> P (F ((F^^i) x)) \<rbrakk> \<Longrightarrow> P (fixR x F)"
  unfolding fixR_def
  apply (subst if_P, assumption)
  apply (erule admD)
  apply (erule chainFrom_chain)
  apply (rule nat_induct)
  apply (simp_all add: iterate_stays_above)
  done

lemma fixR_ind2:
  assumes adm: "adm P"
  assumes above: "chainFrom F x"
  assumes 0: "P x" and 1: "P (F x)"
  assumes step: "!!y. \<lbrakk>x \<sqsubseteq> y ; P y; P (F y)\<rbrakk> \<Longrightarrow> P (F (F y))"
  shows "P (fixR x F)"
  unfolding fixR_def
  apply (subst if_P, fact)
  apply (rule admD [OF adm chainFrom_chain[OF above]])
  apply (rule nat_less_induct)
  apply (case_tac n)
  apply (simp add: 0)
  apply (case_tac nat)
  apply (simp add: 1)
  apply (frule_tac x=nat in spec)
  apply (simp add: step iterate_stays_above[OF above])
done

lemma parallel_fixR_ind:
  assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
  assumes aboveF: "chainFrom F x1"
  assumes aboveG: "chainFrom G x2"
  assumes base: "P x1 x2"
  assumes step: "!!y z. \<lbrakk> x1 \<sqsubseteq> y ; x2 \<sqsubseteq> z; P y z \<rbrakk> \<Longrightarrow> P (F y) (G z)"
  shows "P (fixR x1 F) (fixR x2 G)"
proof -
  from adm have adm': "adm (split P)"
    unfolding split_def .
  have "!!i. P ((F^^i) x1) ((G^^i) x2)"
    by (induct_tac i, simp add: base, simp add: step iterate_stays_above[OF aboveF] iterate_stays_above[OF aboveG])
  hence "!!i. split P ((F^^i) x1, (G^^i) x2)"
    by simp
  hence "split P (\<Squnion>i. ((F^^i) x1, (G^^i) x2))"
    apply - apply (rule admD [OF adm']) by(auto intro: ch2ch_Pair simp add: chainFrom_chain[OF aboveF] chainFrom_chain[OF aboveG])
  hence "split P (\<Squnion>i. ((F^^i) x1), \<Squnion>i. (G^^i) x2)"
    by (simp add: lub_Pair chainFrom_chain[OF aboveF] chainFrom_chain[OF aboveG])
  hence "P (\<Squnion>i. (F^^i) x1) (\<Squnion>i. (G^^i) x2)"
    by simp
  thus "P (fixR x1 F) (fixR x2 G)"
    using aboveF aboveG
    by (simp add: fixR_def)
qed

(*
lemma fix1_cont2cont[simp,cont2cont]:"\<lbrakk> cont F ; cont G ; \<And> y. G y \<sqsubseteq> (F y) \<cdot> (G y) \<rbrakk> \<Longrightarrow> cont (\<lambda>y. fix1 (G y) (F y))"
  unfolding fix1_def by auto
*)

lemma[simp]: "(fixR x (\<lambda> _. x)) = x"
  by (rule fixR_ind, auto)

(*
lemma fix_least_below: "x \<sqsubseteq> F \<cdot> x \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> F\<cdot>y \<sqsubseteq> y \<Longrightarrow> fix1 x F \<sqsubseteq> y"
  apply (simp add: fix1_def)
  apply (rule lub_below)
  apply (erule chain_iterate_from)
  apply (induct_tac i)
  apply simp
  apply simp
  apply (erule rev_below_trans) back
  apply (erule monofun_cfun_arg)
  done

lemmas start_below_fix1[simp] = iterate_below_fix[where n = 0, simplified]

lemma fix1_alt_start:
  assumes "x \<sqsubseteq> y" and "y \<sqsubseteq> F \<cdot> x"
  shows "fix1 x F = fix1 y F"
proof(rule below_antisym)
  have "x \<sqsubseteq> F \<cdot> x" using assms by (metis below.r_trans)
  have "y \<sqsubseteq> F \<cdot> y" using assms by (metis monofun_cfun_arg rev_below_trans)
  show "fix1 x F \<sqsubseteq> fix1 y F"
    by (rule parallel_fix1_ind[OF _ `x \<sqsubseteq> F \<cdot> x` `y \<sqsubseteq> F \<cdot> y`], auto intro: monofun_cfun_arg assms(1))
  show "fix1 y F \<sqsubseteq> fix1 x F"
    apply (rule fix_least_below[OF `y \<sqsubseteq> F \<cdot> y`])
    apply (subst fix_eq[OF `x \<sqsubseteq> F\<cdot>x`])
    apply (rule below_trans[OF  `y \<sqsubseteq> F \<cdot> x`])
    apply (rule monofun_cfun_arg)
    apply (rule start_below_fix1[OF `x \<sqsubseteq> F\<cdot>x`])
    apply (subst fix_eq[OF `x \<sqsubseteq> F\<cdot>x`, symmetric])
    apply (rule below_refl)
    done
qed
*)

end


(* Author: Maximilian Schäffeler, adapted from HOL-Analysis.Bounded_Continuous_Function *)

section \<open>Bounded Functions\<close>

theory Bounded_Functions
  imports
    "HOL.Topological_Spaces"
    "HOL-Analysis.Uniform_Limit"
    "HOL-Probability.Probability"
begin

subsection \<open>Definition\<close>

definition\<^marker>\<open>tag important\<close> "bfun = {f. bounded (range f)}"

typedef (overloaded) ('a, 'b) bfun ("(_ \<Rightarrow>\<^sub>b _)" [22] 21) =
  "bfun::('a \<Rightarrow> 'b :: metric_space) set"
  morphisms apply_bfun Bfun
  by (fastforce simp: bounded_def bfun_def)

declare [[coercion "apply_bfun :: ('a \<Rightarrow>\<^sub>b ('b :: metric_space)) \<Rightarrow> 'a \<Rightarrow> 'b"]]

setup_lifting type_definition_bfun

lemma bounded_apply_bfun[intro, simp]: "bounded ((apply_bfun x) ` X)"
  using apply_bfun by (fastforce simp: bfun_def bounded_def)

lemma apply_bfun_bdd_above[simp, intro]:
  fixes f :: "'c \<Rightarrow>\<^sub>b real"
  shows "bdd_above (f ` X)"
  by (auto intro: bounded_imp_bdd_above)

lemma bfun_eqI[intro]: "(\<And>x. apply_bfun f x = apply_bfun g x) \<Longrightarrow> f = g"
  by transfer auto

lemma bfun_eqD[dest]: "f = g \<Longrightarrow> (\<And>x. apply_bfun f x = apply_bfun g x)"
  by auto

lemma bfunE:
  assumes "f \<in> bfun"
  obtains g where "f = apply_bfun g"
  by (blast intro: apply_bfun_cases assms)

lemma const_bfun: "(\<lambda>x. b) \<in> bfun"
  by (auto simp: bfun_def image_def)

lift_definition const_bfun::"'b \<Rightarrow> ('a \<Rightarrow>\<^sub>b ('b :: metric_space))" is "\<lambda>(c::'b) _. c"
  by (rule const_bfun)

lemma bounded_dist_le_SUP_dist:
  "bounded (range f) \<Longrightarrow> bounded (range g) \<Longrightarrow> dist (f x) (g x) \<le> (SUP x. dist (f x) (g x))"
  by (auto intro!: cSUP_upper bounded_imp_bdd_above bounded_dist_comp)

instantiation bfun :: (type, metric_space) metric_space
begin

lift_definition\<^marker>\<open>tag important\<close> dist_bfun :: "('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> real"
  is "\<lambda>f g. (SUP x. dist (f x) (g x))" .

definition uniformity_bfun :: "(('a \<Rightarrow>\<^sub>b 'b) \<times> 'a \<Rightarrow>\<^sub>b 'b) filter"
  where "uniformity_bfun = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

definition open_bfun :: "('a \<Rightarrow>\<^sub>b 'b) set \<Rightarrow> bool"
  where "open_bfun S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"

lemma dist_bounded:
  fixes f g :: "'a \<Rightarrow>\<^sub>b 'b"
  shows "dist (f x) (g x) \<le> dist f g"
  by transfer (auto intro!: bounded_dist_le_SUP_dist simp: bfun_def)

lemma dist_bound:
  fixes f g :: "'a \<Rightarrow>\<^sub>b ('b :: metric_space)"
  assumes "\<And>x. dist (f x) (g x) \<le> b"
  shows "dist f g \<le> b"
  using assms
  by transfer (auto intro!: cSUP_least)

lemma dist_fun_lt_imp_dist_val_lt:
  fixes f g :: "'a \<Rightarrow>\<^sub>b 'b"
  assumes "dist f g < e"
  shows "dist (f x) (g x) < e"
  using dist_bounded assms
  by (rule le_less_trans)

instance
proof
  fix f g h :: "'a \<Rightarrow>\<^sub>b 'b"
  show "dist f g = 0 \<longleftrightarrow> f = g"
  proof
    have "\<And>x. dist (f x) (g x) \<le> dist f g"
      by (rule dist_bounded)
    also assume "dist f g = 0"
    finally show "f = g"
      by (auto simp: apply_bfun_inject[symmetric])
  qed (auto simp: dist_bfun_def intro!: cSup_eq)
  show "dist f g \<le> dist f h + dist g h"
  proof (rule dist_bound)
    fix x
    have "dist (f x) (g x) \<le> dist (f x) (h x) + dist (g x) (h x)"
      by (rule dist_triangle2)
    also have "dist (f x) (h x) \<le> dist f h"
      by (rule dist_bounded)
    also have "dist (g x) (h x) \<le> dist g h"
      by (rule dist_bounded)
    finally show "dist (f x) (g x) \<le> dist f h + dist g h"
      by simp
  qed
qed (rule open_bfun_def uniformity_bfun_def)+

end

lift_definition PiC::"'a set \<Rightarrow> ('a \<Rightarrow> ('b :: metric_space) set) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b) set"
  is "\<lambda>I X. Pi I X \<inter> bfun"
  by auto

lemma mem_PiC_iff: "x \<in> PiC I X \<longleftrightarrow> apply_bfun x \<in> Pi I X"
  by transfer simp

lemmas mem_PiCD = mem_PiC_iff[THEN iffD1]
  and mem_PiCI = mem_PiC_iff[THEN iffD2]

lemma tendsto_bfun_uniform_limit:
  fixes f::"'i \<Rightarrow> 'a \<Rightarrow>\<^sub>b ('b :: metric_space)"
  assumes "(f \<longlongrightarrow> l) F"
  shows "uniform_limit UNIV f l F"
proof (rule uniform_limitI)
  fix e::real assume "e > 0"
  from tendstoD[OF assms this] have "\<forall>\<^sub>F x in F. dist (f x) l < e" .
  then show "\<forall>\<^sub>F n in F. \<forall>x\<in>UNIV. dist ((f n) x) (l x) < e"
    by eventually_elim (auto simp: dist_fun_lt_imp_dist_val_lt)
qed

lemma uniform_limit_tendsto_bfun:
  fixes f::"'i \<Rightarrow> 'a \<Rightarrow>\<^sub>b ('b :: metric_space)"
    and l::"'a \<Rightarrow>\<^sub>b 'b"
  assumes "uniform_limit UNIV f l F"
  shows "(f \<longlongrightarrow> l) F"
proof (rule tendstoI)
  fix e::real assume "e > 0"
  then have "e / 2 > 0" by simp
  from uniform_limitD[OF assms this]
  have "\<forall>\<^sub>F i in F. \<forall>x. dist (f i x) (l x) < e / 2" by simp
  then have "\<forall>\<^sub>F x in F. dist (f x) l \<le> e / 2"
    by eventually_elim (blast intro: dist_bound less_imp_le)
  then show "\<forall>\<^sub>F x in F. dist (f x) l < e"
    by eventually_elim (use \<open>0 < e\<close> in auto)
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Supremum Norm\<close>

instantiation\<^marker>\<open>tag unimportant\<close> bfun :: (type, real_normed_vector) real_vector
begin

lemma uminus_cont: "f \<in> bfun \<Longrightarrow> (\<lambda>x. - f x) \<in> bfun" for f::"'a \<Rightarrow> 'b"
  by (auto simp: bfun_def)

lemma plus_cont: "f \<in> bfun \<Longrightarrow> g \<in> bfun \<Longrightarrow> (\<lambda>x. f x + g x) \<in> bfun" for f g::"'a \<Rightarrow> 'b"
  by (auto simp: bfun_def bounded_plus_comp)

lemma minus_cont: "f \<in> bfun \<Longrightarrow> g \<in> bfun \<Longrightarrow> (\<lambda>x. f x - g x) \<in> bfun" for f g::"'a \<Rightarrow> 'b"
  by (auto simp: bfun_def bounded_minus_comp)

lemma scaleR_cont: "f \<in> bfun \<Longrightarrow> (\<lambda>x. a *\<^sub>R f x) \<in> bfun" for f :: "'a \<Rightarrow> 'b"
  by (auto simp: bfun_def bounded_scaleR_comp)

lemma bfun_normI[intro]: "(\<And>x. norm (f x) \<le> b) \<Longrightarrow> f \<in> bfun"
  by (auto simp: bfun_def intro: boundedI)

lift_definition uminus_bfun::"('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b)" is "\<lambda>f x. - f x"
  by (rule uminus_cont)

lift_definition plus_bfun::"('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>b 'b"  is "\<lambda>f g x. f x + g x"
  by (rule plus_cont)

lift_definition minus_bfun::"('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>b 'b"  is "\<lambda>f g x. f x - g x"
  by (rule minus_cont)

lift_definition zero_bfun::"'a \<Rightarrow>\<^sub>b 'b" is "\<lambda>_. 0"
  by (rule const_bfun)

lemma const_bfun_0_eq_0[simp]: "const_bfun 0 = 0"
  by transfer simp

lift_definition scaleR_bfun::"real \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'b) \<Rightarrow> 'a \<Rightarrow>\<^sub>b 'b"  is "\<lambda>r g x. r *\<^sub>R g x"
  by (rule scaleR_cont)

lemmas [simp] =
  const_bfun.rep_eq
  uminus_bfun.rep_eq
  plus_bfun.rep_eq
  minus_bfun.rep_eq
  zero_bfun.rep_eq
  scaleR_bfun.rep_eq

instance
  by standard (auto simp: algebra_simps)
end

lemma scaleR_cont': "f \<in> bfun \<Longrightarrow> (\<lambda>x. a * f x) \<in> bfun" for f :: "'a \<Rightarrow> real"
  using scaleR_cont[of f a] by auto

lemma bfun_norm_le_SUP_norm:
  "f \<in> bfun \<Longrightarrow> norm (f x) \<le> (SUP x. norm (f x))"
  by (auto intro!: cSUP_upper bounded_imp_bdd_above simp: bfun_def bounded_norm_comp)

instantiation\<^marker>\<open>tag unimportant\<close> bfun :: (type, real_normed_vector) real_normed_vector
begin

definition norm_bfun :: "('a, 'b) bfun \<Rightarrow> real"
  where "norm_bfun f = dist f 0"

definition "sgn (f::('a,'b) bfun) = f /\<^sub>R norm f"

instance
proof
  fix a :: real
  fix f g :: "('a, 'b) bfun"
  show "dist f g = norm (f - g)"
    unfolding norm_bfun_def
    by transfer (simp add: dist_norm)
  show "norm (f + g) \<le> norm f + norm g"
    unfolding norm_bfun_def
    by transfer
      (auto intro!: cSUP_least norm_triangle_le add_mono bfun_norm_le_SUP_norm simp: dist_norm)
  show "norm (a *\<^sub>R f) = \<bar>a\<bar> * norm f"
    unfolding norm_bfun_def dist_bfun.rep_eq
    by (subst continuous_at_Sup_mono[of "\<lambda>x. \<bar>a\<bar> * x"])
      (fastforce intro!: monoI mult_left_mono continuous_intros bounded_imp_bdd_above
        simp: bounded_norm_comp image_comp)+
qed (auto simp: norm_bfun_def sgn_bfun_def)
end

lemma norm_bfun_def': "norm f = (\<Squnion>x. norm ((f :: 'a \<Rightarrow>\<^sub>b 'b :: real_normed_vector) x))"
  by(subst norm_conv_dist, simp add: dist_bfun.rep_eq)

lemma norm_le_norm_bfun: "norm (apply_bfun f x) \<le> norm f"
  by (simp add: apply_bfun bfun_norm_le_SUP_norm norm_bfun_def dist_bfun_def)

lemma abs_le_norm_bfun: "abs (apply_bfun f x) \<le> norm f"
  by (subst real_norm_def[symmetric]) (rule norm_le_norm_bfun)

lemma le_norm_bfun: "apply_bfun f x \<le> norm f"
  using abs_ge_self abs_le_norm_bfun
  by (rule order.trans)

subsection \<open>Complete Space\<close>

lemma tendsto_add: "P \<longlonglongrightarrow> (L :: 'a :: real_normed_vector) \<Longrightarrow> (\<lambda>n. P n + c) \<longlonglongrightarrow> L + c"
  by (intro tendsto_intros)

lemma lim_add: "convergent P \<Longrightarrow> lim (\<lambda>n. P n + (c :: 'a ::real_normed_vector)) = lim P + c"
  by (auto intro: limI dest: Bounded_Functions.tendsto_add simp add: convergent_LIMSEQ_iff)

lemma complete_bfun:
  assumes cauchy_f: "Cauchy (f :: nat \<Rightarrow> ('a,  'b :: {complete_space, real_normed_vector}) bfun)"
  shows "convergent f"
proof -
  let ?f = "\<lambda>x. lim (\<lambda>n. f n x)"

  from cauchy_f have cauchy_fx: "Cauchy (\<lambda>n. f n x)" for x
    by(fastforce intro: dist_fun_lt_imp_dist_val_lt CauchyI' dest: metric_CauchyD)+

  hence conv_fx: "convergent (\<lambda>n. f n x)" for x
    by(auto intro: Cauchy_convergent)

  have lim_f_bfun: "?f \<in> bfun"
  proof -
    have "\<exists>b. \<forall>x. norm (lim (\<lambda>n. f n x)) \<le> b"
    proof -
      obtain N b where dist_N: "dist (f n x) (f m x) < b" if "n \<ge> N" " m \<ge> N" for x m n
        using metric_CauchyD[OF cauchy_f zero_less_numeral]  dist_fun_lt_imp_dist_val_lt
        by metis
      have aux: "norm (lim (\<lambda>n. f n x)) \<le> b + norm (f N x)" for x
      proof-
        from conv_fx[unfolded convergent_LIMSEQ_iff]
        have tendsto_f_N: "(\<lambda>n. f (n + N) x) \<longlonglongrightarrow> ?f x"
          by (auto dest: LIMSEQ_ignore_initial_segment)
        hence tendsto_f_dist: "(\<lambda>n. dist (f (n + N) x) (f N x)) \<longlonglongrightarrow> dist (?f x) (f N x)"
          by (auto intro: tendsto_intros)
        have "dist (f (n + N) x) (f N x) \<le> b" for n
          by (auto intro!: less_imp_le simp: dist_N)
        hence "dist (?f x) (f N x) \<le> b"
          using lim_le[OF convergentI[OF tendsto_f_dist]]
          by (auto simp: limI[OF tendsto_f_dist, symmetric])
        thus "norm (?f x) \<le> b + norm (f N x)"
          using norm_triangle_ineq2 order_trans
          by (fastforce simp: dist_norm)
      qed
      show ?thesis
        by (auto intro!: exI[of _ "b + norm (f N)"] order.trans[OF aux] norm_le_norm_bfun)
    qed
    thus ?thesis
      by (auto intro: boundedI simp: bfun_def)
  qed

  hence bfun_lim_f_inv: "apply_bfun (Bfun ?f) = ?f"
    using bfun.Bfun_inverse by blast

  have "f \<longlonglongrightarrow> Bfun ?f"
  proof -
    have "\<And>e. e > 0 \<Longrightarrow> \<exists>N. \<forall>n \<ge> N. dist (Bfun ?f) (f n) < e"
    proof -
      fix e :: real
      assume "e > 0"
      hence "\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. dist (f n) (f m) < 0.5 * e" (is "\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. ?P n m N e")
        by(force intro!: metric_CauchyD[OF cauchy_f])
      then obtain N where dist_N: "?P n m N e" if "n \<ge> N" "m \<ge> N" for n m
        by auto
      have "\<forall>n x. dist (?f x) (f (n + N) x) \<le> 0.5 * e"
      proof safe
        fix n x
        have "(\<lambda>m. f m x) \<longlonglongrightarrow> ?f x"
          using conv_fx convergent_LIMSEQ_iff
          by blast
        hence tendsto_f_N: "(\<lambda>m. f (m + N) x) \<longlonglongrightarrow> ?f x"
          using LIMSEQ_ignore_initial_segment
          by auto
        hence tendsto_f_dist:
          "(\<lambda>m. dist (f (m + N) x) (f (n + N) x)) \<longlonglongrightarrow> dist (?f x) (f (n + N) x)"
          by (simp add: tendsto_dist)
        have "dist (f (m + N) x) (f (n + N) x) < 0.5 * e" for m
          by (fastforce intro!: dist_fun_lt_imp_dist_val_lt[OF dist_N])
        thus "dist (?f x) (f (n + N) x) \<le> 0.5 * e"
          by (fastforce intro: less_imp_le convergentI[OF tendsto_f_dist] intro!: lim_le
              simp only: limI[OF tendsto_f_dist, symmetric])
      qed
      hence "\<forall>n. (SUP x. dist (?f x) (f (n + N) x)) \<le> 0.5 * e"
        by (fastforce intro!: cSUP_least)
      hence aux: "\<forall>n. dist (Bfun ?f) (f (n + N)) \<le> 0.5 * e"
        unfolding dist_bfun_def
        by (simp add: bfun_lim_f_inv)
      have "0.5 * e < e"  by (simp add: \<open>0 < e\<close>)
      hence "\<forall>n. dist (Bfun ?f) (f (n + N)) < e"
        using aux le_less_trans by blast
      thus "\<exists>N. \<forall>n\<ge>N. dist (Bfun ?f) (f n) < e"
        by (metis add.commute less_eqE)
    qed
    thus ?thesis
      by (simp add: dist_commute metric_LIMSEQ_I)
  qed
  thus "convergent f"
    unfolding convergent_def
    by blast
qed

lemma norm_bound:
  fixes f :: "('a, 'b::real_normed_vector) bfun"
  assumes "\<And>x. norm (apply_bfun f x) \<le> b"
  shows "norm f \<le> b"
  using dist_bound[of f 0 b] assms
  by (simp add: dist_norm)

lemma bfun_bounded_norm_range: "bounded (range (\<lambda>s. norm (apply_bfun v s)))"
proof -
  obtain b where "\<forall>s. norm (v s) \<le> b"
    using norm_le_norm_bfun
    by fast
  thus ?thesis
    by (simp add: bounded_norm_comp)
qed

instance bfun :: (type, banach) banach
  by standard (auto simp: complete_bfun)

lemma bfun_prob_space_integrable:
  assumes "prob_space S" "v \<in> borel_measurable S"
  assumes "(v :: 'a \<Rightarrow> 'b :: {second_countable_topology, banach}) \<in> bfun"
  shows "integrable S v"
  using prob_space.finite_measure norm_le_norm_bfun[of "Bfun v"] Bfun_inverse[OF assms(3)] assms
  by (auto intro: finite_measure.integrable_const_bound)

lemma bfun_integral_bound:
  assumes "(v :: 'a \<Rightarrow> 'c :: {euclidean_space}) \<in> bfun"
  shows "(\<lambda>S. \<integral>x. v x \<partial>(S :: 'a pmf)) \<in> bfun"
proof -
  obtain b where bH: "\<forall>x. norm (v x) \<le> b"
    using bfun_norm_le_SUP_norm assms by fast
  have "(\<integral>x. norm (v x) \<partial>S) \<le> b" for S :: "'a pmf"
    using \<open>v \<in> bfun\<close> bfun_def bounded_norm_comp bH bfun_prob_space_integrable
    by (fastforce intro!: prob_space.integral_le_const prob_space_measure_pmf simp: bfun_def)
  hence "\<forall>S :: 'a pmf. norm (\<integral>x. (v x) \<partial>S) \<le> b"
    using integral_norm_bound order_trans by blast
  thus ?thesis
    unfolding bfun_def
    by (auto intro: boundedI)
qed

lemma scale_bfun[intro!]: "f \<in> bfun \<Longrightarrow> (\<lambda>x. (k::real) * f x) \<in> bfun"
  using scaleR_cont[of f k] by auto

lemma bfun_spec[intro]: "f \<in> bfun \<Longrightarrow> (\<lambda>x. f (g x)) \<in> bfun"
  unfolding bfun_def bounded_def by auto

lemma apply_bfun_bfun[simp]: "apply_bfun f \<in> bfun"
  using apply_bfun .

lemma bfun_integral_bound'[intro]: "(v :: 'a \<Rightarrow> 'c :: {euclidean_space}) \<in> bfun \<Longrightarrow>
      (\<lambda>S. \<integral>x. v x \<partial>((F S) :: 'a pmf)) \<in> bfun"
  using bfun_integral_bound
  by (subst bfun_spec[of _ F]) auto

lift_definition bfun_comp :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow>\<^sub>b 'c::metric_space) \<Rightarrow> ('a \<Rightarrow>\<^sub>b 'c)" is
  "\<lambda>g bf x. bf (g x)"
  by auto

subsection \<open>Order Instance\<close>

class ordered_real_normed_vector = real_normed_vector + ordered_real_vector

instance real :: ordered_real_normed_vector
  by standard

instantiation bfun :: (_,  ordered_real_normed_vector) ordered_real_normed_vector begin

definition "less_eq_bfun f g \<equiv> \<forall>x. apply_bfun f x \<le> apply_bfun g x"
definition "less_bfun f g \<equiv> \<forall>x. apply_bfun f x \<le> apply_bfun g x \<and> (\<exists>y. f y < g y)"

instance
proof (standard, goal_cases)
  case (1 x y)
  then show ?case
    by (auto dest: leD simp add: less_bfun_def less_eq_bfun_def)
      (metis order.not_eq_order_implies_strict)
qed (auto intro: order_trans antisym dest: leD not_le_imp_less
    simp: less_eq_bfun_def less_bfun_def eq_iff scaleR_left_mono scaleR_right_mono)
end

lemma less_eq_bfunI[intro]: "(\<And>x. apply_bfun f x \<le> apply_bfun g x) \<Longrightarrow> f \<le> g"
  unfolding less_eq_bfun_def
  by auto

lemma less_eq_bfunD[dest]: "f \<le> g \<Longrightarrow> (\<And>x. apply_bfun f x \<le> apply_bfun g x)"
  unfolding less_eq_bfun_def
  by auto

subsection \<open>Miscellaneous\<close>
instantiation bfun :: (type, one) one begin

lift_definition one_bfun :: "'s \<Rightarrow>\<^sub>b 'd::{metric_space, one}" is "\<lambda>x. 1"
  using const_bfun .

instance
  by standard
end

declare one_bfun.rep_eq [simp]

lemma apply_bfun_one [simp]: "apply_bfun (1 :: _ \<Rightarrow>\<^sub>b real) x = 1"
  using one_bfun.rep_eq
  by auto

lemma norm_bfun_one[simp]: "norm (1 :: 'a \<Rightarrow>\<^sub>b real) = 1"
  unfolding norm_bfun_def' by auto

lemma range_bfunI[intro]: "bounded (range f) \<Longrightarrow> f \<in> bfun"
  by (simp add: bfun_def)

lemma finite_bfun[simp]: "(\<lambda>(i::_::finite). f i) \<in> bfun"
  by (meson finite finite_imageI finite_imp_bounded range_bfunI)

lemma bounded_apply_bfun':
  assumes "bounded ((F :: 'c \<Rightarrow> 'd \<Rightarrow>\<^sub>b 'b::real_normed_vector) ` S)"
  shows "bounded ((\<lambda>b. (F b) x) ` S)"
proof -
  obtain b where "\<forall>x\<in>S. norm (F x) \<le> b"
    by (meson assms bounded_pos image_eqI)
  thus "bounded ((\<lambda>b. (F b) x) ` S)"
    by (fastforce intro: norm_le_norm_bfun dual_order.trans boundedI[of _ b])
qed

lemma bfun_tendsto_apply_bfun:
  assumes h: "(F :: (nat \<Rightarrow> 'a \<Rightarrow>\<^sub>b real)) \<longlonglongrightarrow> (y :: 'a \<Rightarrow>\<^sub>b real)"
  shows "(\<lambda>n. F n x) \<longlonglongrightarrow> y x"
proof -
  have aux: "(\<lambda>n. dist (F n) y) \<longlonglongrightarrow> 0"
    using h
    using tendsto_dist_iff by blast
  have "\<And>n. dist (F n x) (y x) \<le> dist (F n) y"
    unfolding dist_bfun_def
    using Bounded_Continuous_Function.bounded_dist_le_SUP_dist by fastforce
  hence "\<And>n. norm (dist (F n x) (y x)) \<le> norm(dist (F n) y)"
    by auto
  hence "(\<lambda>n. dist (F n x) (y x)) \<longlonglongrightarrow> 0"
    by (subst Lim_transform_bound[OF _ aux]) auto
  thus ?thesis
    using tendsto_dist_iff by blast
qed

subsection \<open>Bounded Functions and Vectors\<close>
lemma vec_bfun[simp, intro]: "($) x \<in> bfun"
  using finite_bfun.

lemma norm_bfun_le_norm_vec: "norm (bfun.Bfun (($) (x :: real^'c :: finite))) \<le> norm x"
proof -
  have "norm (bfun.Bfun (($) (x :: real^'c :: finite))) \<le> (\<Squnion>xa. \<bar>x $ xa\<bar>)"
    unfolding norm_bfun_def dist_bfun_def
    by (auto simp: Bfun_inverse)
  also have "\<dots> \<le> norm x"
    using component_le_norm_cart
    by (auto intro: cSUP_least)
  finally show ?thesis
    by auto
qed

lemma bounded_linear_bfun_nth: "bounded_linear f \<Longrightarrow> bounded_linear (\<lambda>v. bfun.Bfun (($) (f v)))"
  using order_trans[OF Finite_Cartesian_Product.norm_nth_le onorm, of f]
  by (auto simp: Bfun_inverse mult.commute linear_simps dist_bfun_def norm_bfun_def
      intro!: bounded_linear_intro cSup_least)

lemma norm_vec_le_norm_bfun:
  "norm (vec_lambda (apply_bfun (x :: 'd::finite \<Rightarrow>\<^sub>b real))) \<le> norm x * card (UNIV :: 'd set)"
proof -
  have "norm (vec_lambda (apply_bfun x)) \<le> (\<Sum> i \<in> UNIV . \<bar>(apply_bfun x i)\<bar>)"
    using L2_set_le_sum_abs
    unfolding norm_vec_def L2_set_def
    by auto
  also have "\<dots> \<le> (card (UNIV :: 'd set) * (\<Squnion>xa. \<bar>apply_bfun x xa\<bar>))"
    by (auto intro!: sum_bounded_above cSup_upper)
  finally show ?thesis
    by (simp add: norm_bfun_def dist_bfun_def mult.commute)
qed

end


theory "C-restr"
imports C "C-Meet" "HOLCF-Utils"
begin

subsubsection \<open>The demand of a $C$-function\<close>

text \<open>
The demand is the least amount of resources required to produce a non-bottom element,
if at all.
\<close>

definition demand :: "(C \<rightarrow> 'a::pcpo) \<Rightarrow> C" where
  "demand f = (if f\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom> then C\<^bsup>(LEAST n. f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>)\<^esup> else C\<^sup>\<infinity>)"

text \<open>
Because of continuity, a non-bottom value can always be obtained with finite resources.
\<close>

lemma finite_resources_suffice:
  assumes "f\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>"
  obtains n where "f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>"
proof-
  {
  assume "\<forall>n. f\<cdot>(C\<^bsup>n\<^esup>) = \<bottom>"
  hence "f\<cdot>C\<^sup>\<infinity> \<sqsubseteq> \<bottom>"
    by (auto intro: lub_below[OF ch2ch_Rep_cfunR[OF chain_iterate]]
             simp add: Cinf_def fix_def2 contlub_cfun_arg[OF chain_iterate])
  with assms have False by simp
  }
  thus ?thesis using that by blast
qed

text \<open>
Because of monotonicity, a non-bottom value can always be obtained with more resources.
\<close>

lemma more_resources_suffice:
  assumes "f\<cdot>r \<noteq> \<bottom>" and "r \<sqsubseteq> r'"
  shows "f\<cdot>r' \<noteq> \<bottom>"
  using assms(1) monofun_cfun_arg[OF assms(2), where  f = f]
  by auto

lemma infinite_resources_suffice:
  shows "f\<cdot>r \<noteq> \<bottom> \<Longrightarrow> f\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>"
  by (erule more_resources_suffice[OF _ below_Cinf])

lemma demand_suffices:
  assumes "f\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>"
  shows "f\<cdot>(demand f) \<noteq> \<bottom>"
  apply (simp add: assms demand_def)
  apply (rule finite_resources_suffice[OF assms])
  apply (rule LeastI)
  apply assumption
  done

lemma not_bot_demand:
  "f\<cdot>r \<noteq> \<bottom> \<longleftrightarrow> demand f \<noteq> C\<^sup>\<infinity> \<and> demand f \<sqsubseteq> r"
proof(intro iffI)
  assume "f\<cdot>r \<noteq> \<bottom>"
  thus "demand f \<noteq> C\<^sup>\<infinity> \<and> demand f \<sqsubseteq> r"
    apply (cases r rule:C_cases)
    apply (auto intro: Least_le simp add: demand_def dest: infinite_resources_suffice)
    done
next
  assume *: "demand f \<noteq> C\<^sup>\<infinity>  \<and> demand f \<sqsubseteq> r"
  then have "f\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>" by (auto intro: Least_le simp add: demand_def dest: infinite_resources_suffice)
  hence "f\<cdot>(demand f) \<noteq> \<bottom>" by (rule demand_suffices)
  moreover from * have "demand f \<sqsubseteq> r"..
  ultimately
  show "f\<cdot>r \<noteq> \<bottom>" by (rule more_resources_suffice)
qed

lemma infinity_bot_demand:
  "f\<cdot>C\<^sup>\<infinity> = \<bottom> \<longleftrightarrow> demand f = C\<^sup>\<infinity>"
  by (metis below_Cinf not_bot_demand)

lemma demand_suffices':
  assumes "demand f = C\<^bsup>n\<^esup>"
  shows "f\<cdot>(demand f) \<noteq> \<bottom>"
  by (metis C_eq_Cinf assms demand_suffices infinity_bot_demand)

lemma demand_Suc_Least:
  assumes [simp]: "f\<cdot>\<bottom> = \<bottom>"
  assumes "demand f \<noteq> C\<^sup>\<infinity>"
  shows "demand f = C\<^bsup>(Suc (LEAST n. f\<cdot>C\<^bsup>Suc n\<^esup> \<noteq> \<bottom>))\<^esup>"
proof-
  from assms
  have "demand f = C\<^bsup>(LEAST n. f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>)\<^esup>" by (auto simp add: demand_def)
  also
  then obtain n where "f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>" by (metis  demand_suffices')
  hence "(LEAST n. f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>) = Suc (LEAST n. f\<cdot>C\<^bsup>Suc n\<^esup> \<noteq> \<bottom>)"
    apply (rule Least_Suc) by simp
  finally show ?thesis.
qed

lemma demand_C_case[simp]: "demand (C_case\<cdot>f) = C \<cdot> (demand f)"
proof(cases "demand (C_case\<cdot>f) = C\<^sup>\<infinity>")
  case True
  then have "C_case\<cdot>f\<cdot>C\<^sup>\<infinity> = \<bottom>"
    by (metis infinity_bot_demand)
  with True
  show ?thesis apply auto by (metis infinity_bot_demand)
next
  case False
  hence "demand (C_case\<cdot>f) = C\<^bsup>Suc (LEAST n. (C_case\<cdot>f)\<cdot>C\<^bsup>Suc n\<^esup> \<noteq> \<bottom>)\<^esup>"
    by (rule demand_Suc_Least[OF C.case_rews(1)])
  also have "\<dots> = C\<cdot>C\<^bsup>LEAST n. f\<cdot>C\<^bsup>n\<^esup> \<noteq> \<bottom>\<^esup>" by simp
  also have "\<dots> = C\<cdot>(demand  f)"
    using False unfolding demand_def by auto
  finally show ?thesis.
qed

lemma demand_contravariant:
  assumes "f \<sqsubseteq> g"
  shows "demand g \<sqsubseteq> demand f"
proof(cases "demand f" rule:C_cases)
  fix n
  assume "demand f = C\<^bsup>n\<^esup>"
  hence "f\<cdot>(demand f) \<noteq> \<bottom>" by (metis demand_suffices')
  also note monofun_cfun_fun[OF assms]
  finally have "g\<cdot>(demand f) \<noteq> \<bottom>" by this (intro cont2cont)
  thus "demand g \<sqsubseteq> demand f" unfolding not_bot_demand by auto
qed auto

subsubsection \<open>Restricting functions with domain C\<close>

fixrec C_restr :: "C \<rightarrow> (C \<rightarrow> 'a::pcpo) \<rightarrow> (C \<rightarrow> 'a)"
  where "C_restr\<cdot>r\<cdot>f\<cdot>r' = (f\<cdot>(r \<sqinter> r'))"

abbreviation C_restr_syn :: "(C \<rightarrow> 'a::pcpo) \<Rightarrow> C \<Rightarrow> (C \<rightarrow> 'a)" ( "_|\<^bsub>_\<^esub>" [111,110] 110)
  where "f|\<^bsub>r\<^esub> \<equiv> C_restr\<cdot>r\<cdot>f"

lemma C_restr_C_restr[simp]: "(v|\<^bsub>r'\<^esub>)|\<^bsub>r\<^esub> = v|\<^bsub>(r' \<sqinter> r)\<^esub>"
  by (rule cfun_eqI) simp

lemma C_restr_eqD:
  assumes "f|\<^bsub>r\<^esub> = g|\<^bsub>r\<^esub>"
  assumes "r' \<sqsubseteq> r"
  shows "f\<cdot>r' = g\<cdot>r'"
by (metis C_restr.simps assms below_refl is_meetI)

lemma C_restr_eq_lower:
  assumes "f|\<^bsub>r\<^esub> = g|\<^bsub>r\<^esub>"
  assumes "r' \<sqsubseteq> r"
  shows "f|\<^bsub>r'\<^esub> = g|\<^bsub>r'\<^esub>"
by (metis C_restr_C_restr assms below_refl is_meetI)

lemma C_restr_below[intro, simp]:
  "x|\<^bsub>r\<^esub> \<sqsubseteq> x"
  apply (rule cfun_belowI)
  apply simp
  by (metis below_refl meet_below2 monofun_cfun_arg)

lemma C_restr_below_cong:
  "(\<And> r'. r' \<sqsubseteq> r \<Longrightarrow> f \<cdot> r' \<sqsubseteq> g \<cdot> r') \<Longrightarrow> f|\<^bsub>r\<^esub> \<sqsubseteq> g|\<^bsub>r\<^esub>"
  apply (rule cfun_belowI)
  apply simp
  by (metis below_refl meet_below1)

lemma C_restr_cong:
  "(\<And> r'. r' \<sqsubseteq> r \<Longrightarrow> f \<cdot> r' = g \<cdot> r') \<Longrightarrow> f|\<^bsub>r\<^esub> = g|\<^bsub>r\<^esub>"
  apply (intro below_antisym C_restr_below_cong )
  by (metis below_refl)+

lemma C_restr_C_cong:
  "(\<And> r'. r' \<sqsubseteq> r \<Longrightarrow> f \<cdot> (C\<cdot>r') = g \<cdot> (C\<cdot>r')) \<Longrightarrow> f\<cdot>\<bottom>=g\<cdot>\<bottom> \<Longrightarrow> f|\<^bsub>C\<cdot>r\<^esub> = g|\<^bsub>C\<cdot>r\<^esub>"
  apply (rule C_restr_cong)
  by (case_tac r', auto)

lemma C_restr_C_case[simp]:
  "(C_case\<cdot>f)|\<^bsub>C\<cdot>r\<^esub> = C_case\<cdot>(f|\<^bsub>r\<^esub>)"
  apply (rule cfun_eqI)
  apply simp
  apply (case_tac x)
  apply simp
  apply simp
  done

lemma C_restr_bot_demand:
  assumes "C\<cdot>r \<sqsubseteq> demand f"
  shows "f|\<^bsub>r\<^esub> = \<bottom>"
proof(rule cfun_eqI)
  fix r'
  have "f\<cdot>(r \<sqinter> r') = \<bottom>"
  proof(rule classical)
    have "r \<sqsubseteq> C \<cdot> r" by (rule below_C)
    also
    note assms
    also
    assume *: "f\<cdot>(r \<sqinter> r') \<noteq> \<bottom>"
    hence "demand f \<sqsubseteq> (r \<sqinter> r')" unfolding not_bot_demand by auto
    hence "demand f \<sqsubseteq> r"  by (metis below_refl meet_below1 below_trans)
    finally (below_antisym) have "r = demand f" by this (intro cont2cont)
    with assms
    have "demand f = C\<^sup>\<infinity>" by (cases "demand f" rule:C_cases) (auto simp add: iterate_Suc[symmetric] simp del: iterate_Suc)
    thus "f\<cdot>(r \<sqinter> r') = \<bottom>" by (metis not_bot_demand)
  qed
  thus "(f|\<^bsub>r\<^esub>)\<cdot>r' = \<bottom>\<cdot>r'" by simp
qed

subsubsection \<open>Restricting maps of C-ranged functions\<close>

definition env_C_restr :: "C \<rightarrow> ('var::type \<Rightarrow> (C \<rightarrow> 'a::pcpo)) \<rightarrow> ('var \<Rightarrow> (C \<rightarrow> 'a))" where
  "env_C_restr = (\<Lambda> r f.  cfun_comp\<cdot>(C_restr\<cdot>r)\<cdot>f)"

abbreviation env_C_restr_syn :: "('var::type \<Rightarrow> (C \<rightarrow> 'a::pcpo)) \<Rightarrow> C \<Rightarrow>  ('var \<Rightarrow> (C \<rightarrow> 'a))" ( "_|\<^sup>\<circ>\<^bsub>_\<^esub>" [111,110] 110)
  where "f|\<^sup>\<circ>\<^bsub>r\<^esub> \<equiv> env_C_restr\<cdot>r\<cdot>f"

lemma env_C_restr_upd[simp]: "(\<rho>(x := v))|\<^sup>\<circ>\<^bsub>r\<^esub> = (\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>)(x := v|\<^bsub>r\<^esub>)"
  unfolding env_C_restr_def by simp

lemma env_C_restr_lookup[simp]: "(\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>) v = \<rho> v|\<^bsub>r\<^esub>"
  unfolding env_C_restr_def by simp

lemma env_C_restr_bot[simp]: " \<bottom>|\<^sup>\<circ>\<^bsub>r\<^esub> = \<bottom>"
  unfolding env_C_restr_def by auto

lemma env_C_restr_restr_below[intro]: "\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub> \<sqsubseteq> \<rho>"
  by (auto intro: fun_belowI)

lemma env_C_restr_env_C_restr[simp]: "(v|\<^sup>\<circ>\<^bsub>r'\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub> = v|\<^sup>\<circ>\<^bsub>(r' \<sqinter> r)\<^esub>"
  unfolding env_C_restr_def by auto

lemma env_C_restr_cong:
  "(\<And> x r'. r' \<sqsubseteq> r \<Longrightarrow> f x \<cdot> r' = g x \<cdot> r') \<Longrightarrow> f|\<^sup>\<circ>\<^bsub>r\<^esub> = g|\<^sup>\<circ>\<^bsub>r\<^esub>"
  unfolding env_C_restr_def
  by (rule ext) (auto intro: C_restr_cong)

end


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

header {* Models of Kleene Algebras *}

theory Kleene_Algebra_Models
imports Kleene_Algebra Dioid_Models
begin

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

The interpretation proofs for some of the following models are quite
similar. One could, perhaps, abstract out common reasoning in the
future. *}

subsection {* Preliminary Lemmas *}

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

context dioid_one_zero
begin

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

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

end (* dioid_one_zero *)

subsection {* The Powerset Kleene Algebra over a Monoid *}

text {* We now show that the powerset dioid forms a Kleene
algebra. The Kleene star is defined as in language theory. *}

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

instantiation set :: (monoid_mult) kleene_algebra
begin

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

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

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

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

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

end (* instantiation *)

subsection {* Language Kleene Algebras *}

text {* We now specialise this fact to languages. *}

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

subsection {* Regular Languages *}

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

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

text {* The interpretation map that induces regular languages as the
images of regular expressions in the set of languages has also been
adapted from there. *}

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

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

setup_lifting type_definition_reg_lan

instantiation reg_lan :: (type) kleene_algebra
begin

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

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

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

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

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

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

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

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

end  (* instantiation *)

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

subsection {* Relation Kleene Algebras *}

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

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

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

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

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

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

subsection {* Trace Kleene Algebras *}

text {* Again, the proof that sets of traces form Kleene algebras
follows the same schema. *}

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

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

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

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

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

subsection {* Path Kleene Algebras *}

text {* We start with paths that include the empty path. *}

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

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

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

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

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

text {* We now consider a notion of paths that does not include the
empty path. *}

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

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

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

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

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

subsection {* The Distributive Lattice Kleene Algebra *}

text {* In the case of bounded distributive lattices, the star maps
all elements to to the maximal element. *}

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

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

subsection {* The Min-Plus Kleene Algebra *}

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

instantiation pnat :: commutative_kleene_algebra
begin

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

  instance
  proof
    fix x y z :: pnat
    show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by (metis star_pnat_def zero_pnat_top)
    show "z + x \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
      by (metis join_semilattice_class.add_lub monoid_mult_class.mult_1_left star_pnat_def)
    show "z + y \<cdot> x \<le> y \<longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"
      by (metis join_semilattice_class.add_lub monoid_mult_class.mult_1_right star_pnat_def)
    show "x \<cdot> y = y \<cdot> x"
      unfolding times_pnat_def by (cases x, cases y, simp_all)
  qed

end (* instantiation *)

end


theory Path_Model_Example
  imports VC_KAD GCD "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"
begin

definition pp_a ::  "'a ppath set \<Rightarrow> 'a ppath set" where
  "pp_a X = {(Node u) |u. \<not> (\<exists>v \<in> X. u = pp_first v)}"

interpretation ppath_aka: antidomain_kleene_algebra pp_a "op \<union>" pp_prod pp_one "{}" "op \<subseteq>" "op \<subset>" pp_star
  apply standard
  apply (clarsimp simp add: pp_prod_def pp_a_def)
  apply (simp add: pp_prod_def pp_a_def, safe, metis pp_first.simps(1) pp_first_pp_fusion)
  by (auto simp: pp_a_def pp_one_def)

definition pp_gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store ppath set" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {Cons s (Node (s (v := e s))) | s. True}"

definition p2pp :: "'a pred \<Rightarrow> 'a ppath set" where
  "p2pp P = {Node s |s. P s}"

lemma pp_a_neg [simp]: "pp_a (p2pp Q) = p2pp (-Q)"
  by (force simp add: pp_a_def p2pp_def)

lemma ppath_assign [simp]: "ppath_aka.fbox (v ::= e) (p2pp Q) = p2pp (\<lambda>s. Q (s(v := e s)))"
  by (force simp: ppath_aka.fbox_def pp_a_def p2pp_def pp_prod_def pp_gets_def)

(* Swap notation from relational to paths *)

no_notation spec_sugar ("PRE _ _ POST _" [64,64,64] 63)
   and relcomp (infixl ";" 70)
   and cond_sugar ("IF _ THEN _ ELSE _ FI" [64,64,64] 63)
   and whilei_sugar ("WHILE _ INV _ DO _ OD" [64,64,64] 63)
   and gets ("_ ::= _" [70, 65] 61)
   and rel_antidomain_kleene_algebra.fbox ("wp")
   and rel_antidomain_kleene_algebra.ads_d ("rdom")
   and p2r ("\<lceil>_\<rceil>")

notation ppath_aka.fbox ("wp")
  and ppath_aka.ads_d ("rdom")
  and p2pp ("\<lceil>_\<rceil>")
  and pp_prod (infixl ";" 70)

abbreviation spec_sugar :: "'a pred \<Rightarrow> 'a ppath set \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rdom \<lceil>P\<rceil> \<subseteq> wp X \<lceil>Q\<rceil>"

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a ppath set \<Rightarrow> 'a ppath set \<Rightarrow> 'a ppath set" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> ppath_aka.cond \<lceil>P\<rceil> X Y"

abbreviation whilei_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a ppath set \<Rightarrow> 'a ppath set" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> ppath_aka.whilei \<lceil>P\<rceil> \<lceil>I\<rceil> X"

lemma [simp]: "p2pp P; p2pp Q = p2pp (P \<sqinter> Q)"
  by (force simp: p2pp_def pp_prod_def)

lemma [intro!]:  "P \<le> Q \<Longrightarrow> \<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil>"
  by (force simp: p2pp_def)

lemma [simp]: "rdom \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (simp add: ppath_aka.addual.ars_r_def)

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

lemma euclid_diff:
   "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule ppath_aka.fbox_whilei, simp_all)
  apply (simp_all add: p2pp_def)
  apply auto[2]
  by (safe, metis gcd_commute_nat gcd_diff1_nat le_cases nat_less_le)

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

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (simp, simp add: p2pp_def, fastforce)

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

(* using a tactic *)

named_theorems ht

declare ppath_aka.fbox_whilei [ht]
  ppath_aka.fbox_seq_var [ht]
  subset_refl[ht]

method hoare = (rule ht; hoare?)

lemma euclid2:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
apply hoare
using gcd_red_nat by auto

lemma euclid_diff2:
   "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y \<and> x > 0 \<and> y > 0)
    (WHILE (\<lambda>s. s ''x''\<noteq> s ''y'') INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
     DO
        (IF (\<lambda>s. s ''x'' >  s ''y'')
         THEN (''x'' ::= (\<lambda>s. s ''x'' - s ''y''))
         ELSE (''y'' ::= (\<lambda>s. s ''y'' - s ''x''))
         FI)
    OD)
    POST (\<lambda>s. s ''x'' = gcd x y)"
  apply hoare
  apply auto
  apply (metis gcd_commute_nat gcd_diff1_nat le_cases nat_less_le)+
done

lemma varible_swap2:
  "PRE (\<lambda>s. s ''x'' = a \<and> s ''y'' = b)
    (''z'' ::= (\<lambda>s. s ''x''));
    (''x'' ::= (\<lambda>s. s ''y''));
    (''y'' ::= (\<lambda>s. s ''z''))
   POST (\<lambda>s. s ''x'' = b \<and> s ''y'' = a)"
  by clarsimp

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

lemma my_power2:
  "PRE (\<lambda>s::nat store. True)
   (''i'' ::= (\<lambda>s. 0));
   (''y'' ::= (\<lambda>s. 1));
   (WHILE (\<lambda>s. s ''i'' < n) INV (\<lambda>s. s ''y'' = x ^ (s ''i'') \<and> s ''i'' \<le> n)
     DO
       (''y'' ::= (\<lambda>s. (s ''y'') * x));
       (''i'' ::= (\<lambda>s. s ''i'' + 1))
     OD)
   POST (\<lambda>s. s ''y'' = x ^ n)"
  by hoare auto

lemma imp_reverse2:
  "PRE (\<lambda>s:: 'a list store. s ''x'' = X)
   (''y'' ::= (\<lambda>s. []));
   (WHILE (\<lambda>s. s ''x'' \<noteq> []) INV (\<lambda>s. rev (s ''x'') @ s ''y'' = rev X)
    DO
     (''y'' ::= (\<lambda>s. hd (s ''x'') # s ''y''));
     (''x'' ::= (\<lambda>s. tl (s ''x'')))
    OD)
   POST (\<lambda>s. s ''y''= rev X )"
  apply hoare
  apply auto
  apply (metis append.simps append_assoc hd_Cons_tl rev.simps(2))
done
end