Theory MFMC_Misc

(* Author: Andreas Lochbihler, ETH Zurich *)

section ‹Preliminaries›

theory MFMC_Misc imports
  "HOL-Probability.Probability"
  "HOL-Library.Transitive_Closure_Table"
  "HOL-Library.Complete_Partial_Order2"
  "HOL-Library.Bourbaki_Witt_Fixpoint"
begin

hide_const (open) cycle
hide_const (open) path
hide_const (open) cut
hide_const (open) orthogonal

lemmas disjE [consumes 1, case_names left right, cases pred] = disjE

lemma inj_on_Pair2 [simp]: "inj_on (Pair x) A"
by(simp add: inj_on_def)

lemma inj_on_Pair1 [simp]: "inj_on (λx. (x, y)) A"
by(simp add: inj_on_def)

lemma inj_map_prod': "⟦ inj f; inj g ⟧ ⟹ inj_on (map_prod f g) X"
by(rule subset_inj_on[OF prod.inj_map subset_UNIV])

lemma not_range_Inr: "x ∉ range Inr ⟷ x ∈ range Inl"
by(cases x) auto

lemma not_range_Inl: "x ∉ range Inl ⟷ x ∈ range Inr"
by(cases x) auto

lemma Chains_into_chain: "M ∈ Chains {(x, y). R x y} ⟹ Complete_Partial_Order.chain R M"
by(simp add: Chains_def chain_def)

lemma chain_dual: "Complete_Partial_Order.chain (≥) = Complete_Partial_Order.chain (≤)"
by(auto simp add: fun_eq_iff chain_def)

lemma Cauchy_real_Suc_diff:
  fixes X :: "nat ⇒ real" and x :: real
  assumes bounded: "⋀n. ¦f (Suc n) - f n¦ ≤ (c / x ^ n)"
  and x: "1 < x"
  shows "Cauchy f"
proof(cases "c > 0")
  case c: True
  show ?thesis
  proof(rule metric_CauchyI)
    fix ε :: real
    assume "0 < ε"

    from bounded[of 0] x have c_nonneg: "0 ≤ c" by simp
    from x have "0 < ln x" by simp
    from reals_Archimedean3[OF this] obtain M :: nat
      where "ln (c * x) - ln (ε * (x - 1)) < real M * ln x" by blast
    hence "exp (ln (c * x) - ln (ε * (x - 1))) < exp (real M * ln x)" by(rule exp_less_mono)
    hence M: "c * (1 / x) ^ M / (1 - 1 / x) < ε" using ‹0 < ε› x c
      by (simp add: exp_diff exp_of_nat_mult field_simps del: ln_mult)

    { fix n m :: nat
      assume "n ≥ M" "m ≥ M"
      then have "¦f m - f n¦ ≤ c * ((1 / x) ^ M - (1 / x) ^ max m n) / (1 - 1 / x)"
      proof(induction n m rule: linorder_wlog)
        case sym thus ?case by(simp add: abs_minus_commute max.commute min.commute)
      next
        case (le m n)
        then show ?case
        proof(induction k≡"n - m" arbitrary: n m)
          case 0 thus ?case using x c_nonneg by(simp add: field_simps mult_left_mono)
        next
          case (Suc k m n)
          from ‹Suc k = _› obtain m' where m: "m = Suc m'" by(cases m) simp_all
          with ‹Suc k = _› Suc.prems have "k = m' - n" "n ≤ m'" "M ≤ n" "M ≤ m'" by simp_all
          hence "¦f m' - f n¦ ≤ c * ((1 / x) ^ M - (1 / x) ^ (max m' n)) / (1 - 1 / x)" by(rule Suc)
          also have "… = c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x)" using ‹n ≤ m'› by(simp add: max_def)
          moreover
          from bounded have "¦f m - f m'¦ ≤ (c / x ^ m')" by(simp add: m)
          ultimately have "¦f m' - f n¦ + ¦f m - f m'¦ ≤ c * ((1 / x) ^ M - (1 / x) ^ m') / (1 - 1 / x) + …" by simp
          also have "… ≤ c * ((1 / x) ^ M - (1 / x) ^ m) / (1 - 1 / x)" using m x by(simp add: field_simps)
          also have "¦f m - f n¦ ≤ ¦f m' - f n¦ + ¦f m - f m'¦"
            using abs_triangle_ineq4[of "f m' - f n" "f m - f m'"] by simp
          ultimately show ?case using ‹n ≤ m› by(simp add: max_def)
        qed
      qed
      also have "… < c * (1 / x) ^ M / (1 - 1 / x)" using x c by(auto simp add: field_simps)
      also have "… < ε" using M .
      finally have "¦f m - f n¦ < ε" . }
    thus "∃M. ∀m≥M. ∀n≥M. dist (f m) (f n) < ε" unfolding dist_real_def by blast
  qed
next
  case False
  with bounded[of 0] have [simp]: "c = 0" by simp
  have eq: "f m = f 0" for m
  proof(induction m)
    case (Suc m) from bounded[of m] Suc.IH show ?case by simp
  qed simp
  show ?thesis by(rule metric_CauchyI)(subst (1 2) eq; simp)
qed

lemma complete_lattice_ccpo_dual:
  "class.ccpo Inf (≥) ((>) :: _ :: complete_lattice ⇒ _)"
by(unfold_locales)(auto intro: Inf_lower Inf_greatest)

lemma card_eq_1_iff: "card A = Suc 0 ⟷ (∃x. A = {x})"
using card_eq_SucD by auto

lemma nth_rotate1: "n < length xs ⟹ rotate1 xs ! n = xs ! (Suc n mod length xs)"
apply(cases xs; clarsimp simp add: nth_append not_less)
apply(subgoal_tac "n = length list"; simp)
done

lemma set_zip_rightI: "⟦ x ∈ set ys; length xs ≥ length ys ⟧ ⟹ ∃z. (z, x) ∈ set (zip xs ys)"
by(fastforce simp add: in_set_zip in_set_conv_nth simp del: length_greater_0_conv intro!: nth_zip conjI[rotated])

lemma map_eq_append_conv:
  "map f xs = ys @ zs ⟷ (∃ys' zs'. xs = ys' @ zs' ∧ ys = map f ys' ∧ zs = map f zs')"
by(auto 4 4 intro: exI[where x="take (length ys) xs"] exI[where x="drop (length ys) xs"] simp add: append_eq_conv_conj take_map drop_map dest: sym)

lemma rotate1_append:
  "rotate1 (xs @ ys) = (if xs = [] then rotate1 ys else tl xs @ ys @ [hd xs])"
by(clarsimp simp add: neq_Nil_conv)

lemma in_set_tlD: "x ∈ set (tl xs) ⟹ x ∈ set xs"
by(cases xs) simp_all

lemma countable_converseI:
  assumes "countable A"
  shows "countable (converse A)"
proof -
  have "converse A = prod.swap ` A" by auto
  then show ?thesis using assms by simp
qed

lemma countable_converse [simp]: "countable (converse A) ⟷ countable A"
using countable_converseI[of A] countable_converseI[of "converse A"] by auto

lemma nn_integral_count_space_reindex:
  "inj_on f A ⟹(∫⇧+ y. g y ∂count_space (f ` A)) = (∫⇧+ x. g (f x) ∂count_space A)"
by(simp add: embed_measure_count_space'[symmetric] nn_integral_embed_measure' measurable_embed_measure1)

syntax
  "_nn_sum" :: "pttrn ⇒ 'a set ⇒ 'b ⇒ 'b::comm_monoid_add"  (‹(2∑⇧+ _∈_./ _)› [0, 51, 10] 10)
  "_nn_sum_UNIV" :: "pttrn ⇒ 'b ⇒ 'b::comm_monoid_add" (‹(2∑⇧+ _./ _)› [0, 10] 10)
syntax_consts
  "_nn_sum" "_nn_sum_UNIV" ⇌ nn_integral
translations
  "∑⇧+ i∈A. b" ⇌ "CONST nn_integral (CONST count_space A) (λi. b)"
  "∑⇧+ i. b" ⇌ "∑⇧+ i∈CONST UNIV. b"

inductive_simps rtrancl_path_simps:
  "rtrancl_path R x [] y"
  "rtrancl_path R x (a # bs) y"

definition restrict_rel :: "'a set ⇒ ('a × 'a) set ⇒ ('a × 'a) set"
where "restrict_rel A R = {(x, y)∈R. x ∈ A ∧ y ∈ A}"

lemma in_restrict_rel_iff: "(x, y) ∈ restrict_rel A R ⟷ (x, y) ∈ R ∧ x ∈ A ∧ y ∈ A"
by(simp add: restrict_rel_def)

lemma restrict_relE: "⟦ (x, y) ∈ restrict_rel A R; ⟦ (x, y) ∈ R; x ∈ A; y ∈ A ⟧ ⟹ thesis ⟧ ⟹ thesis"
by(simp add: restrict_rel_def)

lemma restrict_relI [intro!]: "⟦ (x, y) ∈ R; x ∈ A; y ∈ A ⟧ ⟹ (x, y) ∈ restrict_rel A R"
by(simp add: restrict_rel_def)

lemma Field_restrict_rel_subset: "Field (restrict_rel A R) ⊆ A ∩ Field R"
by(auto simp add: Field_def in_restrict_rel_iff)

lemma Field_restrict_rel [simp]: "Refl R ⟹ Field (restrict_rel A R) = A ∩ Field R"
using Field_restrict_rel_subset[of A R]
by auto (auto simp add: Field_def dest: refl_onD)

lemma Partial_order_restrict_rel:
  assumes "Partial_order R"
  shows "Partial_order (restrict_rel A R)"
proof -
  from assms have "Refl R" by(simp add: order_on_defs)
  from Field_restrict_rel[OF this, of A] assms show ?thesis
    by(simp add: order_on_defs trans_def antisym_def)
      (auto intro: FieldI1 FieldI2 intro!: refl_onI simp add: in_restrict_rel_iff elim: refl_onD)
qed

lemma Chains_restrict_relD: "M ∈ Chains (restrict_rel A leq) ⟹ M ∈ Chains leq"
by(auto simp add: Chains_def in_restrict_rel_iff)

lemma bourbaki_witt_fixpoint_restrict_rel:
  assumes leq: "Partial_order leq"
  and chain_Field: "⋀M. ⟦ M ∈ Chains (restrict_rel A leq); M ≠ {} ⟧ ⟹ lub M ∈ A"
  and lub_least: "⋀M z. ⟦ M ∈ Chains leq; M ≠ {}; ⋀x. x ∈ M ⟹ (x, z) ∈ leq ⟧ ⟹ (lub M, z) ∈ leq"
  and lub_upper: "⋀M z. ⟦ M ∈ Chains leq; z ∈ M ⟧ ⟹ (z, lub M) ∈ leq"
  and increasing: "⋀x. ⟦ x ∈ A; x ∈ Field leq ⟧ ⟹ (x, f x) ∈ leq ∧ f x ∈ A"
  shows "bourbaki_witt_fixpoint lub (restrict_rel A leq) f"
proof
  show "Partial_order (restrict_rel A leq)" using leq by(rule Partial_order_restrict_rel)
next
  from leq have Refl: "Refl leq" by(simp add: order_on_defs)

  { fix M z
    assume M: "M ∈ Chains (restrict_rel A leq)"
    presume z: "z ∈ M"
    hence "M ≠ {}" by auto
    with M have lubA: "lub M ∈ A" by(rule chain_Field)
    from M have M': "M ∈ Chains leq" by(rule Chains_restrict_relD)
    then have *: "(z, lub M) ∈ leq" using z by(rule lub_upper)
    hence "lub M ∈ Field leq" by(rule FieldI2)
    with lubA show "lub M ∈ Field (restrict_rel A leq)" by(simp add: Field_restrict_rel[OF Refl])
    from Chains_FieldD[OF M z] have "z ∈ A" by(simp add: Field_restrict_rel[OF Refl])
    with * lubA show "(z, lub M ) ∈ restrict_rel A leq" by auto

    fix z
    assume upper: "⋀x. x ∈ M ⟹ (x, z) ∈ restrict_rel A leq"
    from upper[OF z] have "z ∈ Field (restrict_rel A leq)" by(auto simp add: Field_def)
    with Field_restrict_rel_subset[of A leq] have "z ∈ A" by blast
    moreover from lub_least[OF M' ‹M ≠ {}›] upper have "(lub M, z) ∈ leq"
      by(auto simp add: in_restrict_rel_iff)
    ultimately show "(lub M, z) ∈ restrict_rel A leq" using lubA by(simp add: in_restrict_rel_iff) }
  { fix x
    assume "x ∈ Field (restrict_rel A leq)"
    hence "x ∈ A" "x ∈ Field leq" by(simp_all add: Field_restrict_rel[OF Refl])
    with increasing[OF this] show "(x, f x) ∈ restrict_rel A leq" by auto }
  show "(SOME x. x ∈ M) ∈ M" "(SOME x. x ∈ M) ∈ M" if "M ≠ {}" for M :: "'a set"
    using that by(auto intro: someI)
qed

lemma Field_le [simp]: "Field {(x :: _ :: preorder, y). x ≤ y} = UNIV"
by(auto intro: FieldI1)

lemma Field_ge [simp]: "Field {(x :: _ :: preorder, y). y ≤ x} = UNIV"
by(auto intro: FieldI1)

lemma refl_le [simp]: "refl {(x :: _ :: preorder, y). x ≤ y}"
by(auto intro!: refl_onI simp add: Field_def)

lemma refl_ge [simp]: "refl {(x :: _ :: preorder, y). y ≤ x}"
by(auto intro!: refl_onI simp add: Field_def)

lemma partial_order_le [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x ≤ x'}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma partial_order_ge [simp]: "partial_order_on UNIV {(x :: _ :: order, x'). x' ≤ x}"
by(auto simp add: order_on_defs trans_def antisym_def)

lemma incseq_chain_range: "incseq f ⟹ Complete_Partial_Order.chain (≤) (range f)"
apply(rule chainI; clarsimp)
 using linear by (auto dest: incseqD)

end