(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Discrete-time Markov Processes\<close>

text \<open>In this file we construct discrete-time Markov processes, e.g. with arbitrary state spaces.\<close>

theory Discrete_Time_Markov_Process
  imports Markov_Models_Auxiliary
begin

lemma measure_eqI_PiM_sequence:
  fixes M :: "nat \<Rightarrow> 'a measure"
  assumes *[simp]: "sets P = PiM UNIV M" "sets Q = PiM UNIV M"
  assumes eq: "\<And>A n. (\<And>i. A i \<in> sets (M i)) \<Longrightarrow>
    P (prod_emb UNIV M {..n} (Pi\<^sub>E {..n} A)) = Q (prod_emb UNIV M {..n} (Pi\<^sub>E {..n} A))"
  assumes A: "finite_measure P"
  shows "P = Q"
proof (rule measure_eqI_PiM_infinite[OF * _ A])
  fix J :: "nat set" and F'
  assume J: "finite J" "\<And>i. i \<in> J \<Longrightarrow> F' i \<in> sets (M i)"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i \<in> J then F' i else space (M i))" for i
  then have F[simp, measurable]: "F i \<in> sets (M i)" for i
    using J by auto
  have emb_eq: "prod_emb UNIV M J (Pi\<^sub>E J F') = prod_emb UNIV M {..n} (Pi\<^sub>E {..n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J \<noteq> {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le \<open>finite J\<close> split: if_split_asm)
  qed

  show "emeasure P (prod_emb UNIV M J (Pi\<^sub>E J F')) = emeasure Q (prod_emb UNIV M J (Pi\<^sub>E J F'))"
    unfolding emb_eq by (rule eq) fact
qed

lemma distr_cong_simp:
  "M = K \<Longrightarrow> sets N = sets L \<Longrightarrow> (\<And>x. x \<in> space M =simp=> f x = g x) \<Longrightarrow> distr M N f = distr K L g"
  unfolding simp_implies_def by (rule distr_cong)

subsection \<open>Constructing Discrete-Time Markov Processes\<close>

locale discrete_Markov_process =
  fixes M :: "'a measure" and K :: "'a \<Rightarrow> 'a measure"
  assumes K[measurable]: "K \<in> M \<rightarrow>\<^sub>M prob_algebra M"
begin

lemma space_K: "x \<in> space M \<Longrightarrow> space (K x) = space M"
  using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma sets_K[measurable_cong]: "x \<in> space M \<Longrightarrow> sets (K x) = sets M"
  using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma prob_space_K: "x \<in> space M \<Longrightarrow> prob_space (K x)"
  using measurable_space[OF K] by (simp add: space_prob_algebra)

definition K' :: "'a \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a measure"
where
  "K' x n' \<omega>' = K (case_nat x \<omega>' n')"

lemma IT_K':
  assumes x: "x \<in> space M" shows "Ionescu_Tulcea (K' x) (\<lambda>_. M)"
  unfolding Ionescu_Tulcea_def K'_def[abs_def]
proof safe
  fix i show "(\<lambda>\<omega>'. K (case i of 0 \<Rightarrow> x | Suc x \<Rightarrow> \<omega>' x)) \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra M"
    using x by (intro measurable_prob_algebraD measurable_compose[OF _ K]) measurable
next
  fix i :: nat and \<omega> assume \<omega>: "\<omega> \<in> space (Pi\<^sub>M {0..<i} (\<lambda>_. M))"
  with x have "(case i of 0 \<Rightarrow> x | Suc x \<Rightarrow> \<omega> x) \<in> space M"
    by (auto simp: space_PiM split: nat.split)
  then show "prob_space (K (case i of 0 \<Rightarrow> x | Suc x \<Rightarrow> \<omega> x))"
    using K unfolding measurable_restrict_space2_iff prob_algebra_def by auto
qed

definition lim_sequence :: "'a \<Rightarrow> (nat \<Rightarrow> 'a) measure"
where
  "lim_sequence x = projective_family.lim UNIV (Ionescu_Tulcea.CI (K' x) (\<lambda>_. M)) (\<lambda>_. M)"

lemma
  assumes x: "x \<in> space M"
  shows space_lim_sequence: "space (lim_sequence x) = space (\<Pi>\<^sub>M i\<in>UNIV. M)"
    and sets_lim_sequence[measurable_cong]: "sets (lim_sequence x) = sets (\<Pi>\<^sub>M i\<in>UNIV. M)"
    and emeasure_lim_sequence_emb: "\<And>J X. finite J \<Longrightarrow> X \<in> sets (\<Pi>\<^sub>M j\<in>J. M) \<Longrightarrow>
      emeasure (lim_sequence x) (prod_emb UNIV (\<lambda>_. M) J X) =
      emeasure (Ionescu_Tulcea.CI (K' x) (\<lambda>_. M) J) X"
    and emeasure_lim_sequence_emb_I0o: "\<And>n X. X \<in> sets (\<Pi>\<^sub>M i \<in> {0..<n}. M) \<Longrightarrow>
      emeasure (lim_sequence x) (prod_emb UNIV (\<lambda>_. M) {0..<n} X) =
      emeasure (Ionescu_Tulcea.C (K' x) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) X"
proof -
  interpret Ionescu_Tulcea "K' x" "\<lambda>_. M"
    using x by (rule IT_K')
  show "space (lim_sequence x) = space (\<Pi>\<^sub>M i\<in>UNIV. M)"
    unfolding lim_sequence_def by simp
  show "sets (lim_sequence x) = sets (\<Pi>\<^sub>M i\<in>UNIV. M)"
    unfolding lim_sequence_def by simp

  { fix J :: "nat set" and X assume "finite J" "X \<in> sets (\<Pi>\<^sub>M j\<in>J. M)"
    then show "emeasure (lim_sequence x) (PF.emb UNIV J X) = emeasure (CI J) X"
      unfolding lim_sequence_def by (rule lim) }
  note emb = this

  have up_to_I0o[simp]: "up_to {0..<n} = n" for n
    unfolding up_to_def by (rule Least_equality) auto

  { fix n :: nat and X assume "X \<in> sets (\<Pi>\<^sub>M j\<in>{0..<n}. M)"
    then show "emeasure (lim_sequence x) (PF.emb UNIV {0..<n} X) = emeasure (C 0 n (\<lambda>x. undefined)) X"
      by (simp add: space_C emb CI_def space_PiM distr_id2 sets_C cong: distr_cong_simp) }
qed

lemma lim_sequence[measurable]: "lim_sequence \<in> M \<rightarrow>\<^sub>M prob_algebra (\<Pi>\<^sub>M i\<in>UNIV. M)"
proof (intro measurable_prob_algebra_generated[OF sets_PiM Int_stable_prod_algebra prod_algebra_sets_into_space])
  fix a assume [simp]: "a \<in> space M"
  interpret Ionescu_Tulcea "K' a" "\<lambda>_. M"
    by (rule IT_K') simp
  have sp: "space (lim_sequence a) = prod_emb UNIV (\<lambda>_. M) {} (\<Pi>\<^sub>E j\<in>{}. space M)" "space (CI {}) = {} \<rightarrow>\<^sub>E space M"
    by (auto simp: space_lim_sequence space_PiM prod_emb_def PF.space_P)
  show "prob_space (lim_sequence a)"
    apply standard
    using PF.prob_space_P[THEN prob_space.emeasure_space_1, of "{}"]
    apply (simp add: sp emeasure_lim_sequence_emb del: PiE_empty_domain)
    done
  show "sets (lim_sequence a) = sets (Pi\<^sub>M UNIV (\<lambda>i. M))"
    by (simp add: sets_lim_sequence)
next
  fix X :: "(nat \<Rightarrow> 'a) set" assume "X \<in> prod_algebra UNIV (\<lambda>i. M)"
  then obtain J :: "nat set" and F where J: "J \<noteq> {}" "finite J" "F \<in> J \<rightarrow> sets M"
    and X: "X = prod_emb UNIV (\<lambda>_. M) J (Pi\<^sub>E J F)"
    unfolding prod_algebra_def by auto
  then have Pi_F: "finite J" "Pi\<^sub>E J F \<in> sets (Pi\<^sub>M J (\<lambda>_. M))"
    by (auto intro: sets_PiM_I_finite)

  define n where "n = (LEAST n. \<forall>i\<ge>n. i \<notin> J)"
  have J_le_n: "J \<subseteq> {0..<n}"
    unfolding n_def
    using \<open>finite J\<close>
    apply -
    apply (rule LeastI2[of _ "Suc (Max J)"])
    apply (auto simp: Suc_le_eq not_le[symmetric])
    done

  have C: "(\<lambda>x. Ionescu_Tulcea.C (K' x) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) \<in> M \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<n} (\<lambda>_. M))"
    apply (induction n)
    apply (subst measurable_cong)
    apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
    apply assumption
    apply (rule measurable_compose[OF _ return_measurable])
    apply simp
    apply (subst measurable_cong)
    apply (rule Ionescu_Tulcea.C.simps[OF IT_K'])
    apply assumption
    apply (rule measurable_bind')
    apply assumption
    apply (subst measurable_cong)
  proof -
    fix n :: nat and w assume "w \<in> space (M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M))"
    then show "(case w of (x, xa) \<Rightarrow> Ionescu_Tulcea.eP (K' x) (\<lambda>_. M) (0 + n) xa) =
      (case w of (x, xa) \<Rightarrow> distr (K' x n xa) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) (fun_upd xa n))"
      by (auto simp: space_pair_measure Ionescu_Tulcea.eP_def[OF IT_K'] split: prod.split)
  next
    fix n show "(\<lambda>w. case w of (x, xa) \<Rightarrow> distr (K' x n xa) (Pi\<^sub>M {0..<Suc n} (\<lambda>i. M)) (fun_upd xa n))
         \<in> M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
      unfolding K'_def
      apply measurable
      apply (rule measurable_distr2[where M=M])
      apply (rule measurable_PiM_single')
      apply (simp add: split_beta')
      subgoal for i by (cases "i = n") auto
      subgoal by (auto simp: split_beta' PiE_iff extensional_def Pi_iff space_pair_measure space_PiM)
      apply (rule measurable_prob_algebraD)
      apply (rule measurable_compose[OF _ K])
      apply measurable
      done
  qed

  have "(\<lambda>a. emeasure (lim_sequence a) X) \<in> borel_measurable M \<longleftrightarrow>
    (\<lambda>a. emeasure (Ionescu_Tulcea.CI (K' a) (\<lambda>_. M) J) (Pi\<^sub>E J F)) \<in> borel_measurable M"
    unfolding X using J Pi_F by (intro measurable_cong emeasure_lim_sequence_emb) auto
  also have "\<dots>"
    apply (intro measurable_compose[OF _ measurable_emeasure_subprob_algebra[OF Pi_F(2)]])
    apply (subst measurable_cong)
    apply (subst Ionescu_Tulcea.CI_def[OF IT_K'])
    apply assumption
    apply (subst Ionescu_Tulcea.up_to_def[OF IT_K'])
    apply assumption
    unfolding n_def[symmetric]
    apply (rule refl)
    apply (rule measurable_compose[OF _ measurable_distr[OF measurable_restrict_subset[OF J_le_n]]])
    apply (rule C)
    done
  finally show "(\<lambda>a. emeasure (lim_sequence a) X) \<in> borel_measurable M" .
qed

  have [simp]: "space (K x) \<noteq> {}"
    using space_K[OF x] x by auto

  have [simp]: "((\<lambda>_. undefined::'a)(0 := x)) = case_nat x (\<lambda>_. undefined)" for x
    by (auto simp: fun_eq_iff split: nat.split)

  have "C 0 1 (\<lambda>_. undefined) \<bind> C 1 n = eP 0 (\<lambda>_. undefined) \<bind> C 1 n"
    using measurable_eP[of 0] measurable_C[of 1 n, measurable del]
    by (simp add: bind_return[where N="Pi\<^sub>M {0} (\<lambda>_. M)"])
  also have "\<dots> = K x \<bind> (\<lambda>y. C 1 n (case_nat y (\<lambda>_. undefined)))"
    using measurable_C[of 1 n, measurable del] x[THEN sets_K]
    by (simp add: eP_def K'_def bind_distr cong: measurable_cong_sets)
  finally show "C 0 1 (\<lambda>_. undefined) \<bind> C 1 n = K x \<bind> (\<lambda>y. C 1 n (case_nat y (\<lambda>_. undefined)))" .
qed

lemma lim_sequence_eq:
  assumes x: "x \<in> space M"
  shows "lim_sequence x = bind (K x) (\<lambda>y. distr (lim_sequence y) (\<Pi>\<^sub>M j\<in>UNIV. M) (case_nat y))"
    (is "_ = ?B x")
proof (rule measure_eqI_PiM_infinite)
  show "sets (lim_sequence x) = sets (\<Pi>\<^sub>M j\<in>UNIV. M)"
    using x by (rule sets_lim_sequence)
  have [simp]: "space (K x) \<noteq> {}"
    using space_K[OF x] x by auto
  show "sets (?B x) = sets (Pi\<^sub>M UNIV (\<lambda>j. M))"
    using x by (subst sets_bind) auto
  interpret lim_sequence: prob_space "lim_sequence x"
    using lim_sequence x by (auto simp: measurable_restrict_space2_iff prob_algebra_def)
  show "finite_measure (lim_sequence x)"
    by (rule lim_sequence.finite_measure)

  interpret Ionescu_Tulcea "K' x" "\<lambda>_. M"
    using x by (rule IT_K')

  let ?U = "\<lambda>_::nat. undefined :: 'a"

  fix J :: "nat set" and F'
  assume J: "finite J" "\<And>i. i \<in> J \<Longrightarrow> F' i \<in> sets M"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i \<in> J then F' i else space M)" for i
  then have F[simp, measurable]: "F i \<in> sets M" for i
    using J by auto
  have emb_eq: "PF.emb UNIV J (Pi\<^sub>E J F') = PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J \<noteq> {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le \<open>finite J\<close> split: if_split_asm)
  qed

  have "emeasure (lim_sequence x) (PF.emb UNIV J (Pi\<^sub>E J F')) = emeasure (C 0 (Suc n) ?U) (Pi\<^sub>E {0..<Suc n} F)"
    using x unfolding emb_eq by (rule emeasure_lim_sequence_emb_I0o) (auto intro!: sets_PiM_I_finite)
  also have "C 0 (Suc n) ?U = K x \<bind> (\<lambda>y. C 1 n (case_nat y ?U))"
    using split_C[of ?U 0 "Suc 0" n] step_C[OF x] by simp
  also have "emeasure (K x \<bind> (\<lambda>y. C 1 n (case_nat y ?U))) (Pi\<^sub>E {0..<Suc n} F) =
    (\<integral>\<^sup>+y. C 1 n (case_nat y ?U) (Pi\<^sub>E {0..<Suc n} F) \<partial>K x)"
    using measurable_C[of 1 n, measurable del] x[THEN sets_K] F x
    by (intro emeasure_bind[OF  _ measurable_compose[OF _ measurable_C]])
       (auto cong: measurable_cong_sets intro!: measurable_PiM_single' split: nat.split_asm)
  also have "\<dots> = (\<integral>\<^sup>+y. distr (lim_sequence y) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y) (PF.emb UNIV J (Pi\<^sub>E J F')) \<partial>K x)"
  proof (intro nn_integral_cong)
    fix y assume "y \<in> space (K x)"
    then have y: "y \<in> space M"
      using x by (simp add: space_K)
    then interpret y: Ionescu_Tulcea "K' y" "\<lambda>_. M"
      by (rule IT_K')

    let ?y = "case_nat y"
    have [simp]: "?y ?U \<in> space (Pi\<^sub>M {0} (\<lambda>i. M))"
      using y by (auto simp: space_PiM PiE_iff extensional_def split: nat.split)
    have yM[measurable]: "?y \<in> Pi\<^sub>M {0..<m} (\<lambda>_. M) \<rightarrow>\<^sub>M Pi\<^sub>M {0..<Suc m} (\<lambda>i. M)" for m
      using y by (intro measurable_PiM_single') (auto simp: space_PiM PiE_iff extensional_def split: nat.split)

    have y': "?y ?U \<in> space (Pi\<^sub>M {0..<1} (\<lambda>i. M))"
      by (simp add: space_PiM PiE_def y extensional_def split: nat.split)

    have eq1: "?y -` Pi\<^sub>E {0..<Suc n} F \<inter> space (Pi\<^sub>M {0..<n} (\<lambda>_. M)) =
        (if y \<in> F 0 then Pi\<^sub>E {0..<n} (F\<circ>Suc) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff extensional_def Ball_def split: nat.split nat.split_asm)

    have eq2: "?y -` PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F) \<inter> space (Pi\<^sub>M UNIV (\<lambda>_. M)) =
        (if y \<in> F 0 then PF.emb UNIV {0..<n} (Pi\<^sub>E {0..<n} (F\<circ>Suc)) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff prod_emb_def extensional_def Ball_def split: nat.split nat.split_asm)

    let ?I = "indicator (F 0) y"

    have "C 1 n (?y ?U) = distr (y.C 0 n ?U) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) ?y"
    proof (induction n)
      case (Suc m)

      have "C 1 (Suc m) (?y ?U) = distr (y.C 0 m ?U) (Pi\<^sub>M {0..<Suc m} (\<lambda>i. M)) ?y \<bind> eP (Suc m)"
        using Suc by simp
      also have "\<dots> = y.C 0 m ?U \<bind> (\<lambda>x. eP (Suc m) (?y x))"
        by (intro bind_distr[where K="Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>_. M)"]) (simp_all add: y y.space_C y.sets_C cong: measurable_cong_sets)
      also have "\<dots> = y.C 0 m ?U \<bind> (\<lambda>x. distr (y.eP m x) (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y)"
      proof (intro bind_cong refl)
        fix \<omega>' assume \<omega>': "\<omega>' \<in> space (y.C 0 m ?U)"
        moreover have "K' x (Suc m) (?y \<omega>') = K' y m \<omega>'"
          by (auto simp: K'_def)
        ultimately show "eP (Suc m) (?y \<omega>') = distr (y.eP m \<omega>') (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y"
          unfolding eP_def y.eP_def
          by (subst distr_distr)
             (auto simp: y.space_C y.sets_P split: nat.split cong: measurable_cong_sets
                   intro!: distr_cong measurable_fun_upd[where J="{0..<m}"])
      qed
      also have "\<dots> = distr (y.C 0 m ?U \<bind> y.eP m) (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y"
        by (intro distr_bind[symmetric, OF _ _ yM]) (auto simp: y.space_C y.sets_C cong: measurable_cong_sets)
      finally show ?case
        by simp
    qed (use y in \<open>simp add: PiM_empty distr_return\<close>)
    then have "C 1 n (case_nat y ?U) (Pi\<^sub>E {0..<Suc n} F) =
      (distr (y.C 0 n ?U) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) ?y) (Pi\<^sub>E {0..<Suc n} F)" by simp
    also have "\<dots> = ?I * y.C 0 n ?U (Pi\<^sub>E {0..<n} (F \<circ> Suc))"
      by (subst emeasure_distr) (auto simp: y.sets_C y.space_C eq1 cong: measurable_cong_sets)
    also have "\<dots> = ?I * lim_sequence y (PF.emb UNIV {0..<n} (Pi\<^sub>E {0..<n} (F \<circ> Suc)))"
      using y by (simp add: emeasure_lim_sequence_emb_I0o sets_PiM_I_finite)
    also have "\<dots> = distr (lim_sequence y) (Pi\<^sub>M UNIV (\<lambda>j. M)) ?y (PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F))"
      using y by (subst emeasure_distr) (simp_all add: eq2 space_lim_sequence)
    finally show "emeasure (C 1 n (case_nat y (\<lambda>_. undefined))) (Pi\<^sub>E {0..<Suc n} F) =
        emeasure (distr (lim_sequence y) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y)) (PF.emb UNIV J (Pi\<^sub>E J F'))"
      unfolding emb_eq .
  qed
  also have "\<dots> =
    emeasure (K x \<bind> (\<lambda>y. distr (lim_sequence y) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y))) (PF.emb UNIV J (Pi\<^sub>E J F'))"
    using J
    by (subst emeasure_bind[where N="PiM UNIV (\<lambda>_. M)"])
       (auto simp: sets_K x intro!: measurable_distr2[OF _ measurable_prob_algebraD[OF lim_sequence]] cong: measurable_cong_sets)
  finally show "emeasure (lim_sequence x) (PF.emb UNIV J (Pi\<^sub>E J F')) =
    emeasure (K x \<bind> (\<lambda>y. distr (lim_sequence y) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y)))
            (PF.emb UNIV J (Pi\<^sub>E J F'))" .
qed

lemma AE_lim_sequence:
  assumes x[simp]: "x \<in> space M" and P[measurable]: "Measurable.pred (\<Pi>\<^sub>M i\<in>UNIV. M) P"
  shows "(AE \<omega> in lim_sequence x. P \<omega>) \<longleftrightarrow> (AE y in K x. AE \<omega> in lim_sequence y. P (case_nat y \<omega>))"
  apply (simp add: lim_sequence_eq cong del: AE_cong)
  apply (subst AE_bind)
  apply (rule measurable_prob_algebraD)
  apply measurable
  apply (auto intro!: AE_cong simp add: space_K AE_distr_iff)
  done

definition lim_stream :: "'a \<Rightarrow> 'a stream measure"
where
  "lim_stream x = distr (lim_sequence x) (stream_space M) to_stream"

lemma space_lim_stream: "space (lim_stream x) = streams (space M)"
  unfolding lim_stream_def by (simp add: space_stream_space)

lemma sets_lim_stream[measurable_cong]: "sets (lim_stream x) = sets (stream_space M)"
  unfolding lim_stream_def by simp

lemma lim_stream[measurable]: "lim_stream \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
  unfolding lim_stream_def[abs_def] by (intro measurable_distr_prob_space2[OF lim_sequence]) auto

lemma space_stream_space_M_ne: "x \<in> space M \<Longrightarrow> space (stream_space M) \<noteq> {}"
  using sconst_streams[of x "space M"] by (auto simp: space_stream_space)

lemma prob_space_lim_stream: "x \<in> space M \<Longrightarrow> prob_space (lim_stream x)"
  using measurable_space[OF lim_stream, of x] by (simp add: space_prob_algebra)

lemma lim_stream_eq:
  assumes x: "x \<in> space M"
  shows "lim_stream x = do { y \<leftarrow> K x; \<omega> \<leftarrow> lim_stream y; return (stream_space M) (y ## \<omega>) }"
  unfolding lim_stream_def
  apply (subst lim_sequence_eq[OF x])
  apply (subst distr_bind[OF _ _ measurable_to_stream])
  subgoal
    by (auto simp: sets_K x cong: measurable_cong_sets
             intro!: measurable_prob_algebraD measurable_distr_prob_space2[where M="Pi\<^sub>M UNIV (\<lambda>j. M)"] lim_sequence) []
  subgoal
    using x by (auto simp add: space_K)
  apply (intro bind_cong refl)
  apply (subst distr_distr)
  apply (auto simp: space_K sets_lim_sequence x cong: measurable_cong_sets intro!: distr_cong)
  apply (subst bind_return_distr')
  apply (auto simp: space_stream_space_M_ne)
  apply (subst distr_distr)
  apply (auto simp: space_K sets_lim_sequence x to_stream_nat_case cong: measurable_cong_sets intro!: distr_cong)
  done

lemma AE_lim_stream:
  assumes x[simp]: "x \<in> space M" and P[measurable]: "Measurable.pred (stream_space M) P"
  shows "(AE \<omega> in lim_stream x. P \<omega>) \<longleftrightarrow> (AE y in K x. AE \<omega> in lim_stream y. P (y ## \<omega>))"
  unfolding lim_stream_eq[OF x]
  by (simp_all add: space_K space_lim_stream space_stream_space AE_return AE_bind[OF measurable_prob_algebraD P] cong: AE_cong_simp)

lemma emeasure_lim_stream:
  assumes x[measurable, simp]: "x \<in> space M" and A[measurable, simp]: "A \<in> sets (stream_space M)"
  shows "lim_stream x A = (\<integral>\<^sup>+y. emeasure (lim_stream y) (((##) y) -` A \<inter> space (stream_space M)) \<partial>K x)"
  apply (subst lim_stream_eq, simp)
  apply (subst emeasure_bind[OF _ _ A], simp add: prob_space.not_empty prob_space_K)
   apply (rule measurable_prob_algebraD)
   apply measurable
  apply (intro nn_integral_cong)
  apply (subst bind_return_distr')
    apply (auto intro!: prob_space.not_empty prob_space_lim_stream simp: space_K emeasure_distr)
  apply (simp add: space_lim_stream space_stream_space)
  done

lemma lim_stream_eq_coinduct[case_names in_space step]:
  fixes R :: "'a \<Rightarrow> 'a stream measure \<Rightarrow> bool"
  assumes x: "R x B" "x \<in> space M"
  assumes R: "\<And>x B. R x B \<Longrightarrow> \<exists>B'\<in>M \<rightarrow>\<^sub>M prob_algebra (stream_space M).
    (AE y in K x. R y (B' y) \<or> lim_stream y = B' y) \<and>
    B = do { y \<leftarrow> K x; \<omega> \<leftarrow> B' y; return (stream_space M) (y ## \<omega>) }"
  shows "lim_stream x = B"
  using x
proof (coinduction arbitrary: x B rule: stream_space_coinduct[where M=M, case_names step])
  case (step x B)
  from R[OF \<open>R x B\<close>] obtain B' where B': "B' \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
    and ae: "AE y in K x. R y (B' y) \<or> lim_stream y = B' y"
    and eq: "B = K x \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return (stream_space M) (y ## \<omega>)))"
    by blast
  show ?case
    apply (rule bexI[of _ "K x"], rule bexI[OF _ lim_stream], rule bexI[OF _ B'])
    apply (intro conjI)
    subgoal
      using ae AE_space by eventually_elim (insert \<open>x\<in>space M\<close>, auto simp: space_K)
    subgoal
      by (rule lim_stream_eq) fact
    subgoal
      by (rule eq)
    subgoal
      using K \<open>x \<in> space M\<close> by (rule measurable_space)
    done
qed

lemma prob_space_lim_sequence: "x \<in> space M \<Longrightarrow> prob_space (lim_sequence x)"
  using measurable_space[OF lim_sequence, of x] by (simp add: space_prob_algebra)

end

subsection \<open>Strong Markov Property for Discrete-Time Markov Processes\<close>

text \<open>The filtration adopted to streams, i.e. to the $n$-th projection.\<close>

definition stream_filtration :: "'a measure \<Rightarrow> enat \<Rightarrow> 'a stream measure"
  where "stream_filtration M n = (SUP i\<in>{i::nat. i \<le> n}. vimage_algebra (streams (space M)) (\<lambda>\<omega> . \<omega> !! i) M)"

lemma measurable_stream_filtration1: "enat i \<le> n \<Longrightarrow> (\<lambda>\<omega>. \<omega> !! i) \<in> stream_filtration M n \<rightarrow>\<^sub>M M"
  by (auto intro!: measurable_SUP1 measurable_vimage_algebra1 snth_in simp: stream_filtration_def)

lemma measurable_stream_filtration2:
  "f \<in> space N \<rightarrow> streams (space M) \<Longrightarrow> (\<And>i. enat i \<le> n \<Longrightarrow> (\<lambda>x. f x !! i) \<in> N \<rightarrow>\<^sub>M M) \<Longrightarrow> f \<in> N \<rightarrow>\<^sub>M stream_filtration M n"
  by (auto simp: stream_filtration_def enat_0
           intro!: measurable_SUP2 measurable_vimage_algebra2 elim!: allE[of _ "0::nat"])

lemma space_stream_filtration: "space (stream_filtration M n) = space (stream_space M)"
  by (auto simp add: space_stream_space space_Sup_eq_UN stream_filtration_def enat_0 elim!: allE[of _ 0])

lemma sets_stream_filteration_le_stream_space: "sets (stream_filtration M n) \<subseteq> sets (stream_space M)"
  unfolding sets_stream_space_eq stream_filtration_def
  by (intro SUP_subset_mono le_measureD2) (auto simp: space_Sup_eq_UN enat_0 elim!: allE[of _ 0])

interpretation stream_filtration: filtration "space (stream_space M)" "stream_filtration M"
proof
  show "space (stream_filtration M i) = space (stream_space M)" for i
    by (simp add: space_stream_filtration)
  show "sets (stream_filtration M i) \<subseteq> sets (stream_filtration M j)" if "i \<le> j" for i j
  proof (rule le_measureD2)
    show "stream_filtration M i \<le> stream_filtration M j"
      using \<open>i \<le> j\<close> unfolding stream_filtration_def by (intro SUP_subset_mono) auto
  qed (simp add: space_stream_filtration)
qed

lemma measurable_stopping_time_stream:
  "stopping_time (stream_filtration M) T \<Longrightarrow> T \<in> stream_space M \<rightarrow>\<^sub>M count_space UNIV"
  using sets_stream_filteration_le_stream_space
  by (subst measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric, where 'a=enat]])
     (auto intro!: measurable_stopping_time simp: space_stream_filtration)

lemma measurable_stopping_time_All_eq_0:
  assumes T: "stopping_time (stream_filtration M) T"
  shows "{x\<in>space M. \<forall>\<omega>\<in>streams (space M). T (x ## \<omega>) = 0} \<in> sets M"
proof -
  have "{\<omega>\<in>streams (space M). T \<omega> = 0} \<in> vimage_algebra (streams (space M)) (\<lambda>\<omega>. \<omega> !! 0) M"
    using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
  then obtain A
    where A: "A \<in> sets M"
      and *: "{\<omega> \<in> streams (space M). T \<omega> = 0} = (\<lambda>\<omega>. \<omega> !! 0) -` A \<inter> streams (space M)"
    by (auto simp: sets_vimage_algebra2 streams_shd)
  have "A = {x\<in>space M. \<forall>\<omega>\<in>streams (space M). T (x ## \<omega>) = 0}"
  proof safe
    fix x \<omega> assume "x \<in> A" "\<omega> \<in> streams (space M)"
    then have "x ## \<omega> \<in> {\<omega> \<in> streams (space M). T \<omega> = 0}"
      unfolding * using A[THEN sets.sets_into_space] by auto
    then show "T (x ## \<omega>) = 0" by auto
  next
    fix x assume "x \<in> space M" "\<forall>\<omega>\<in>streams (space M). T (x ## \<omega>) = 0 "
    then have "\<forall>\<omega>\<in>streams (space M). x ## \<omega> \<in> {\<omega> \<in> streams (space M). T \<omega> = 0}"
      by simp
    with \<open>x\<in>space M\<close> show "x \<in> A"
      unfolding * by (auto simp: streams_empty_iff)
  qed (use A[THEN sets.sets_into_space] in auto)
  with \<open>A \<in> sets M\<close> show ?thesis by auto
qed

lemma stopping_time_0:
  assumes T: "stopping_time (stream_filtration M) T"
    and x: "x \<in> space M" and \<omega>: "\<omega> \<in> streams (space M)" "T (x ## \<omega>) > 0"
    and \<omega>': "\<omega>' \<in> streams (space M)"
  shows "T (x ## \<omega>') > 0"
  unfolding zero_less_iff_neq_zero
proof
  assume "T (x ## \<omega>') = 0"
  with x \<omega>' have x': "x ## \<omega>' \<in> {\<omega> \<in> streams (space M). T \<omega> = 0}"
    by auto

  have "{\<omega>\<in>streams (space M). T \<omega> = 0} \<in> vimage_algebra (streams (space M)) (\<lambda>\<omega>. \<omega> !! 0) M"
    using stopping_timeD[OF T, of 0] by (simp add: stream_filtration_def pred_def enat_0_iff)
  then obtain A
    where A: "A \<in> sets M"
      and *: "{\<omega> \<in> streams (space M). T \<omega> = 0} = (\<lambda>\<omega>. \<omega> !! 0) -` A \<inter> streams (space M)"
    by (auto simp: sets_vimage_algebra2 streams_shd)
  with x' have "x \<in> A"
    by auto
  with \<omega> x have "x ## \<omega> \<in> (\<lambda>\<omega>. \<omega> !! 0) -` A \<inter> streams (space M)"
    by auto
  with \<omega> show False
    unfolding *[symmetric] by auto
qed

lemma stopping_time_epred_SCons:
  assumes T: "stopping_time (stream_filtration M) T"
    and x: "x \<in> space M" and \<omega>: "\<omega> \<in> streams (space M)" "T (x ## \<omega>) > 0"
  shows "stopping_time (stream_filtration M) (\<lambda>\<omega>. epred (T (x ## \<omega>)))"
proof (rule stopping_timeI, rule measurable_cong[THEN iffD2])
  show "\<omega> \<in> space (stream_filtration M t) \<Longrightarrow> (epred (T (x ## \<omega>)) \<le> t) = (T (x ## \<omega>) \<le> eSuc t)" for t \<omega>
    by (cases "T (x ## \<omega>)" rule: enat_coexhaust)
       (auto simp add: space_stream_filtration space_stream_space dest!: stopping_time_0[OF T x \<omega>])
  show "Measurable.pred (stream_filtration M t) (\<lambda>w. T (x ## w) \<le> eSuc t)" for t
  proof (rule measurable_compose[of "SCons x"])
    show "(##) x \<in> stream_filtration M t \<rightarrow>\<^sub>M stream_filtration M (eSuc t)"
    proof (intro measurable_stream_filtration2)
      show "enat i \<le> eSuc t \<Longrightarrow> (\<lambda>xa. (x ## xa) !! i) \<in> stream_filtration M t \<rightarrow>\<^sub>M M" for i
        using \<open>x\<in>space M\<close>
        by (cases i) (auto simp: eSuc_enat[symmetric] intro!: measurable_stream_filtration1)
    qed (auto simp: space_stream_filtration space_stream_space \<open>x\<in>space M\<close>)
  qed (rule T[THEN stopping_timeD])
qed

context discrete_Markov_process
begin

lemma lim_stream_strong_Markov:
  assumes x: "x \<in> space M" and T: "stopping_time (stream_filtration M) T"
  shows "lim_stream x =
    lim_stream x \<bind> (\<lambda>\<omega>. case T \<omega> of
      enat i \<Rightarrow> distr (lim_stream (\<omega> !! i)) (stream_space M) (\<lambda>\<omega>'. stake (Suc i) \<omega> @- \<omega>')
    | \<infinity>     \<Rightarrow> return (stream_space M) \<omega>)"
  (is "_ = ?L T x")
  using assms
proof (coinduction arbitrary: x T rule: lim_stream_eq_coinduct)
  case (step x T)
  note T = \<open>stopping_time (stream_filtration M) T\<close>[THEN measurable_stopping_time_stream, measurable]
  define L where "L T x = ?L T x" for T x
  have L[measurable (raw)]:
    "(\<lambda>(x, \<omega>). T x \<omega>) \<in> N \<Otimes>\<^sub>M stream_space M \<rightarrow>\<^sub>M count_space UNIV \<Longrightarrow>
    f \<in> N \<rightarrow>\<^sub>M M \<Longrightarrow> (\<lambda>x. L (T x) (f x)) \<in> N \<rightarrow>\<^sub>M prob_algebra (stream_space M)" for f :: "'a \<Rightarrow> 'a" and N T
    unfolding L_def
    by (intro measurable_bind_prob_space2[OF measurable_compose[OF _ lim_stream]] measurable_case_enat
        measurable_distr_prob_space2[OF measurable_compose[OF _ lim_stream]]
        measurable_return_prob_space measurable_stopping_time_stream)
       auto

  define S where "S x = (if \<forall>\<omega>\<in>streams (space M). T (x##\<omega>) = 0 then lim_stream x else L (\<lambda>\<omega>. epred (T (x ## \<omega>))) x)" for x
  then have S_eq: "\<forall>\<omega>\<in>streams (space M). T (x##\<omega>) = 0 \<Longrightarrow> S x = lim_stream x"
    "\<not> (\<forall>\<omega>\<in>streams (space M). T (x##\<omega>) = 0) \<Longrightarrow> S x = L (\<lambda>\<omega>. epred (T (x ## \<omega>))) x" for x
    by auto
  have [measurable]: "S \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
    unfolding S_def[abs_def]
    by (subst measurable_If_restrict_space_iff, safe intro!: L)
       (auto intro!: measurable_stopping_time_All_eq_0 step measurable_restrict_space1 lim_stream
                     measurable_compose[OF _ measurable_epred] measurable_compose[OF _ T]
                     measurable_Stream measurable_compose[OF measurable_fst]
             simp: measurable_split_conv)

  show ?case
    unfolding L_def[symmetric]
  proof (intro bexI[of _ S] conjI AE_I2)
    fix y assume "y \<in> space (K x)"
    then show "(\<exists>x T. y = x \<and> S y = L T x \<and> x \<in> space M \<and> stopping_time (stream_filtration M) T) \<or>
      lim_stream y = S y"
      using \<open>x\<in>space M\<close>
      by (cases "\<forall>\<omega>\<in>streams (space M). T (y##\<omega>) = 0")
         (auto simp add: S_eq space_K intro!: exI[of _ "\<lambda>\<omega>. epred (T (y ## \<omega>))"] stopping_time_epred_SCons step)
  next
    note \<open>x\<in>space M\<close>[simp]
    have "L T x = K x \<bind>
      (\<lambda>y. lim_stream y \<bind> (\<lambda>\<omega>. case T (y##\<omega>) of
            enat i \<Rightarrow> distr (lim_stream ((y##\<omega>) !! i)) (stream_space M) (\<lambda>\<omega>'. stake (Suc i) (y##\<omega>) @- \<omega>')
          | \<infinity>     \<Rightarrow> return (stream_space M) (y##\<omega>)))" (is "_ = K x \<bind> ?L'")
      unfolding L_def
      apply (subst lim_stream_eq[OF \<open>x\<in>space M\<close>])
      apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
          measurable)
      apply (rule bind_cong[OF refl])
      apply (simp add: space_K)
      apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
          measurable)
      apply (rule bind_cong[OF refl])
      apply (simp add: space_lim_stream)
      apply (subst bind_return[where N="stream_space M", OF measurable_prob_algebraD])
        apply (measurable; fail) []
       apply (simp add: space_stream_space)
      apply rule
      done
    also have "\<dots> = K x \<bind> (\<lambda>y. S y \<bind> (\<lambda>\<omega>. return (stream_space M) (y ## \<omega>)))"
    proof (intro bind_cong[of "K x"] refl)
      fix y assume "y \<in> space (K x)"
      then have [simp]: "y \<in> space M"
        by (simp add: space_K)
      show "?L' y = S y \<bind> (\<lambda>\<omega>. return (stream_space M) (y ## \<omega>))"
      proof cases
        assume "\<forall>\<omega>\<in>streams (space M). T (y##\<omega>) = 0"
        with x show ?thesis
          by (auto simp: S_eq space_lim_stream shift.simps[abs_def] streams_empty_iff
                bind_const'[OF _ prob_space_imp_subprob_space] prob_space_lim_stream prob_space.prob_space_distr
              intro!: bind_return_distr'[symmetric]
              cong: bind_cong_simp)
      next
        assume *: "\<not> (\<forall>\<omega>\<in>streams (space M). T (y##\<omega>) = 0)"
        then have T_pos: "\<omega> \<in> streams (space M) \<Longrightarrow> T (y ## \<omega>) \<noteq> 0" for \<omega>
          using stopping_time_0[OF \<open>stopping_time (stream_filtration M) T\<close>, of y _ \<omega>] by auto
        show ?thesis
          apply (simp add: S_eq(2)[OF *] L_def)
          apply (subst bind_assoc[where N="stream_space M" and R="stream_space M", OF measurable_prob_algebraD measurable_prob_algebraD];
            measurable)
          apply (intro bind_cong refl)
          apply (auto simp: T_pos enat_0 space_lim_stream shift.simps[abs_def] diff_Suc space_stream_space
                      intro!: bind_return[where N="stream_space M", OF measurable_prob_algebraD, symmetric]
                        bind_distr_return[symmetric]
                      split: nat.split enat.split)
          done
      qed
    qed
    finally show "L T x = K x \<bind> (\<lambda>y. S y \<bind> (\<lambda>\<omega>. return (stream_space M) (y ## \<omega>)))" .
  qed fact
qed fact

end

end


(*  Title:      HOL/Nonstandard_Analysis/HyperDef.thy
    Author:     Jacques D. Fleuriot
    Copyright:  1998  University of Cambridge
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>Construction of Hyperreals Using Ultrafilters\<close>

theory HyperDef
  imports Complex_Main HyperNat
begin

type_synonym hypreal = "real star"

abbreviation hypreal_of_real :: "real \<Rightarrow> real star"
  where "hypreal_of_real \<equiv> star_of"

abbreviation hypreal_of_hypnat :: "hypnat \<Rightarrow> hypreal"
  where "hypreal_of_hypnat \<equiv> of_hypnat"

definition omega :: hypreal  ("\<omega>")
  where "\<omega> = star_n (\<lambda>n. real (Suc n))"
    \<comment> \<open>an infinite number \<open>= [<1, 2, 3, \<dots>>]\<close>\<close>

definition epsilon :: hypreal  ("\<epsilon>")
  where "\<epsilon> = star_n (\<lambda>n. inverse (real (Suc n)))"
    \<comment> \<open>an infinitesimal number \<open>= [<1, 1/2, 1/3, \<dots>>]\<close>\<close>

subsection \<open>Real vector class instances\<close>

instantiation star :: (scaleR) scaleR
begin
  definition star_scaleR_def [transfer_unfold]: "scaleR r \<equiv> *f* (scaleR r)"
  instance ..
end

lemma Standard_scaleR [simp]: "x \<in> Standard \<Longrightarrow> scaleR r x \<in> Standard"
  by (simp add: star_scaleR_def)

lemma star_of_scaleR [simp]: "star_of (scaleR r x) = scaleR r (star_of x)"
  by transfer (rule refl)

instance star :: (real_vector) real_vector
proof
  fix a b :: real
  show "\<And>x y::'a star. scaleR a (x + y) = scaleR a x + scaleR a y"
    by transfer (rule scaleR_right_distrib)
  show "\<And>x::'a star. scaleR (a + b) x = scaleR a x + scaleR b x"
    by transfer (rule scaleR_left_distrib)
  show "\<And>x::'a star. scaleR a (scaleR b x) = scaleR (a * b) x"
    by transfer (rule scaleR_scaleR)
  show "\<And>x::'a star. scaleR 1 x = x"
    by transfer (rule scaleR_one)
qed

instance star :: (real_algebra) real_algebra
proof
  fix a :: real
  show "\<And>x y::'a star. scaleR a x * y = scaleR a (x * y)"
    by transfer (rule mult_scaleR_left)
  show "\<And>x y::'a star. x * scaleR a y = scaleR a (x * y)"
    by transfer (rule mult_scaleR_right)
qed

instance star :: (real_algebra_1) real_algebra_1 ..

instance star :: (real_div_algebra) real_div_algebra ..

instance star :: (field_char_0) field_char_0 ..

instance star :: (real_field) real_field ..

lemma star_of_real_def [transfer_unfold]: "of_real r = star_of (of_real r)"
  by (unfold of_real_def, transfer, rule refl)

lemma Standard_of_real [simp]: "of_real r \<in> Standard"
  by (simp add: star_of_real_def)

lemma star_of_of_real [simp]: "star_of (of_real r) = of_real r"
  by transfer (rule refl)

lemma of_real_eq_star_of [simp]: "of_real = star_of"
proof
  show "of_real r = star_of r" for r :: real
    by transfer simp
qed

lemma Reals_eq_Standard: "(\<real> :: hypreal set) = Standard"
  by (simp add: Reals_def Standard_def)

subsection \<open>Injection from \<^typ>\<open>hypreal\<close>\<close>

definition of_hypreal :: "hypreal \<Rightarrow> 'a::real_algebra_1 star"
  where [transfer_unfold]: "of_hypreal = *f* of_real"

lemma Standard_of_hypreal [simp]: "r \<in> Standard \<Longrightarrow> of_hypreal r \<in> Standard"
  by (simp add: of_hypreal_def)

lemma of_hypreal_0 [simp]: "of_hypreal 0 = 0"
  by transfer (rule of_real_0)

lemma of_hypreal_1 [simp]: "of_hypreal 1 = 1"
  by transfer (rule of_real_1)

lemma of_hypreal_add [simp]: "\<And>x y. of_hypreal (x + y) = of_hypreal x + of_hypreal y"
  by transfer (rule of_real_add)

lemma of_hypreal_minus [simp]: "\<And>x. of_hypreal (- x) = - of_hypreal x"
  by transfer (rule of_real_minus)

lemma of_hypreal_diff [simp]: "\<And>x y. of_hypreal (x - y) = of_hypreal x - of_hypreal y"
  by transfer (rule of_real_diff)

lemma of_hypreal_mult [simp]: "\<And>x y. of_hypreal (x * y) = of_hypreal x * of_hypreal y"
  by transfer (rule of_real_mult)

lemma of_hypreal_inverse [simp]:
  "\<And>x. of_hypreal (inverse x) =
    inverse (of_hypreal x :: 'a::{real_div_algebra, division_ring} star)"
  by transfer (rule of_real_inverse)

lemma of_hypreal_divide [simp]:
  "\<And>x y. of_hypreal (x / y) =
    (of_hypreal x / of_hypreal y :: 'a::{real_field, field} star)"
  by transfer (rule of_real_divide)

lemma of_hypreal_eq_iff [simp]: "\<And>x y. (of_hypreal x = of_hypreal y) = (x = y)"
  by transfer (rule of_real_eq_iff)

lemma of_hypreal_eq_0_iff [simp]: "\<And>x. (of_hypreal x = 0) = (x = 0)"
  by transfer (rule of_real_eq_0_iff)

subsection \<open>Properties of \<^term>\<open>starrel\<close>\<close>

lemma lemma_starrel_refl [simp]: "x \<in> starrel `` {x}"
  by (simp add: starrel_def)

lemma starrel_in_hypreal [simp]: "starrel``{x}\<in>star"
  by (simp add: star_def starrel_def quotient_def, blast)

declare Abs_star_inject [simp] Abs_star_inverse [simp]
declare equiv_starrel [THEN eq_equiv_class_iff, simp]

subsection \<open>\<^term>\<open>hypreal_of_real\<close>: the Injection from \<^typ>\<open>real\<close> to \<^typ>\<open>hypreal\<close>\<close>

lemma inj_star_of: "inj star_of"
  by (rule inj_onI) simp

lemma mem_Rep_star_iff: "X \<in> Rep_star x \<longleftrightarrow> x = star_n X"
  by (cases x) (simp add: star_n_def)

lemma Rep_star_star_n_iff [simp]: "X \<in> Rep_star (star_n Y) \<longleftrightarrow> eventually (\<lambda>n. Y n = X n) \<U>"
  by (simp add: star_n_def)

lemma Rep_star_star_n: "X \<in> Rep_star (star_n X)"
  by simp

subsection \<open>Properties of \<^term>\<open>star_n\<close>\<close>

lemma star_n_add: "star_n X + star_n Y = star_n (\<lambda>n. X n + Y n)"
  by (simp only: star_add_def starfun2_star_n)

lemma star_n_minus: "- star_n X = star_n (\<lambda>n. -(X n))"
  by (simp only: star_minus_def starfun_star_n)

lemma star_n_diff: "star_n X - star_n Y = star_n (\<lambda>n. X n - Y n)"
  by (simp only: star_diff_def starfun2_star_n)

lemma star_n_mult: "star_n X * star_n Y = star_n (\<lambda>n. X n * Y n)"
  by (simp only: star_mult_def starfun2_star_n)

lemma star_n_inverse: "inverse (star_n X) = star_n (\<lambda>n. inverse (X n))"
  by (simp only: star_inverse_def starfun_star_n)

lemma star_n_le: "star_n X \<le> star_n Y = eventually (\<lambda>n. X n \<le> Y n) \<U>"
  by (simp only: star_le_def starP2_star_n)

lemma star_n_less: "star_n X < star_n Y = eventually (\<lambda>n. X n < Y n) \<U>"
  by (simp only: star_less_def starP2_star_n)

lemma star_n_zero_num: "0 = star_n (\<lambda>n. 0)"
  by (simp only: star_zero_def star_of_def)

lemma star_n_one_num: "1 = star_n (\<lambda>n. 1)"
  by (simp only: star_one_def star_of_def)

lemma star_n_abs: "\<bar>star_n X\<bar> = star_n (\<lambda>n. \<bar>X n\<bar>)"
  by (simp only: star_abs_def starfun_star_n)

lemma hypreal_omega_gt_zero [simp]: "0 < \<omega>"
  by (simp add: omega_def star_n_zero_num star_n_less)

subsection \<open>Existence of Infinite Hyperreal Number\<close>

text \<open>Existence of infinite number not corresponding to any real number.
  Use assumption that member \<^term>\<open>\<U>\<close> is not finite.\<close>

lemma hypreal_of_real_not_eq_omega: "hypreal_of_real x \<noteq> \<omega>"
proof -
  have False if "\<forall>\<^sub>F n in \<U>. x = 1 + real n" for x
  proof -
    have "finite {n::nat. x = 1 + real n}"
      by (simp add: finite_nat_set_iff_bounded_le) (metis add.commute nat_le_linear nat_le_real_less)
    then show False
      using FreeUltrafilterNat.finite that by blast
  qed
  then show ?thesis
    by (auto simp add: omega_def star_of_def star_n_eq_iff)
qed

text \<open>Existence of infinitesimal number also not corresponding to any real number.\<close>

lemma hypreal_of_real_not_eq_epsilon: "hypreal_of_real x \<noteq> \<epsilon>"
proof -
  have False if "\<forall>\<^sub>F n in \<U>. x = inverse (1 + real n)" for x
  proof -
    have "finite {n::nat. x = inverse (1 + real n)}"
      by (simp add: finite_nat_set_iff_bounded_le) (metis add.commute inverse_inverse_eq linear nat_le_real_less of_nat_Suc)
    then show False
      using FreeUltrafilterNat.finite that by blast
  qed
  then show ?thesis
    by (auto simp: epsilon_def star_of_def star_n_eq_iff)
qed

lemma epsilon_ge_zero [simp]: "0 \<le> \<epsilon>"
  by (simp add: epsilon_def star_n_zero_num star_n_le)

lemma epsilon_not_zero: "\<epsilon> \<noteq> 0"
  using hypreal_of_real_not_eq_epsilon by force

lemma epsilon_inverse_omega: "\<epsilon> = inverse \<omega>"
  by (simp add: epsilon_def omega_def star_n_inverse)

lemma epsilon_gt_zero: "0 < \<epsilon>"
  by (simp add: epsilon_inverse_omega)

subsection \<open>Embedding the Naturals into the Hyperreals\<close>

abbreviation hypreal_of_nat :: "nat \<Rightarrow> hypreal"
  where "hypreal_of_nat \<equiv> of_nat"

lemma SNat_eq: "Nats = {n. \<exists>N. n = hypreal_of_nat N}"
  by (simp add: Nats_def image_def)

text \<open>Naturals embedded in hyperreals: is a hyperreal c.f. NS extension.\<close>

lemma hypreal_of_nat: "hypreal_of_nat m = star_n (\<lambda>n. real m)"
  by (simp add: star_of_def [symmetric])

declaration \<open>
  K (Lin_Arith.add_simps @{thms star_of_zero star_of_one
      star_of_numeral star_of_add
      star_of_minus star_of_diff star_of_mult}
  #> Lin_Arith.add_inj_thms @{thms star_of_le [THEN iffD2]
      star_of_less [THEN iffD2] star_of_eq [THEN iffD2]}
  #> Lin_Arith.add_inj_const (\<^const_name>\<open>StarDef.star_of\<close>, \<^typ>\<open>real \<Rightarrow> hypreal\<close>))
\<close>

simproc_setup fast_arith_hypreal ("(m::hypreal) < n" | "(m::hypreal) \<le> n" | "(m::hypreal) = n") =
  \<open>K Lin_Arith.simproc\<close>

subsection \<open>Exponentials on the Hyperreals\<close>

lemma hpowr_0 [simp]: "r ^ 0 = (1::hypreal)"
  for r :: hypreal
  by (rule power_0)

lemma hpowr_Suc [simp]: "r ^ (Suc n) = r * (r ^ n)"
  for r :: hypreal
  by (rule power_Suc)

lemma hrealpow: "star_n X ^ m = star_n (\<lambda>n. (X n::real) ^ m)"
  by (induct m) (auto simp: star_n_one_num star_n_mult)

lemma hrealpow_sum_square_expand:
  "(x + y) ^ Suc (Suc 0) =
    x ^ Suc (Suc 0) + y ^ Suc (Suc 0) + (hypreal_of_nat (Suc (Suc 0))) * x * y"
  for x y :: hypreal
  by (simp add: distrib_left distrib_right)

lemma power_hypreal_of_real_numeral:
  "(numeral v :: hypreal) ^ n = hypreal_of_real ((numeral v) ^ n)"
  by simp
declare power_hypreal_of_real_numeral [of _ "numeral w", simp] for w

lemma power_hypreal_of_real_neg_numeral:
  "(- numeral v :: hypreal) ^ n = hypreal_of_real ((- numeral v) ^ n)"
  by simp
declare power_hypreal_of_real_neg_numeral [of _ "numeral w", simp] for w

subsection \<open>Powers with Hypernatural Exponents\<close>

text \<open>Hypernatural powers of hyperreals.\<close>
definition pow :: "'a::power star \<Rightarrow> nat star \<Rightarrow> 'a star"  (infixr "pow" 80)
  where hyperpow_def [transfer_unfold]: "R pow N = ( *f2* (^)) R N"

lemma Standard_hyperpow [simp]: "r \<in> Standard \<Longrightarrow> n \<in> Standard \<Longrightarrow> r pow n \<in> Standard"
  by (simp add: hyperpow_def)

lemma hyperpow: "star_n X pow star_n Y = star_n (\<lambda>n. X n ^ Y n)"
  by (simp add: hyperpow_def starfun2_star_n)

lemma hyperpow_zero [simp]: "\<And>n. (0::'a::{power,semiring_0} star) pow (n + (1::hypnat)) = 0"
  by transfer simp

lemma hyperpow_not_zero: "\<And>r n. r \<noteq> (0::'a::{field} star) \<Longrightarrow> r pow n \<noteq> 0"
  by transfer (rule power_not_zero)

lemma hyperpow_inverse: "\<And>r n. r \<noteq> (0::'a::field star) \<Longrightarrow> inverse (r pow n) = (inverse r) pow n"
  by transfer (rule power_inverse [symmetric])

lemma hyperpow_hrabs: "\<And>r n. \<bar>r::'a::{linordered_idom} star\<bar> pow n = \<bar>r pow n\<bar>"
  by transfer (rule power_abs [symmetric])

lemma hyperpow_add: "\<And>r n m. (r::'a::monoid_mult star) pow (n + m) = (r pow n) * (r pow m)"
  by transfer (rule power_add)

lemma hyperpow_one [simp]: "\<And>r. (r::'a::monoid_mult star) pow (1::hypnat) = r"
  by transfer (rule power_one_right)

lemma hyperpow_two: "\<And>r. (r::'a::monoid_mult star) pow (2::hypnat) = r * r"
  by transfer (rule power2_eq_square)

lemma hyperpow_gt_zero: "\<And>r n. (0::'a::{linordered_semidom} star) < r \<Longrightarrow> 0 < r pow n"
  by transfer (rule zero_less_power)

lemma hyperpow_ge_zero: "\<And>r n. (0::'a::{linordered_semidom} star) \<le> r \<Longrightarrow> 0 \<le> r pow n"
  by transfer (rule zero_le_power)

lemma hyperpow_le: "\<And>x y n. (0::'a::{linordered_semidom} star) < x \<Longrightarrow> x \<le> y \<Longrightarrow> x pow n \<le> y pow n"
  by transfer (rule power_mono [OF _ order_less_imp_le])

lemma hyperpow_eq_one [simp]: "\<And>n. 1 pow n = (1::'a::monoid_mult star)"
  by transfer (rule power_one)

lemma hrabs_hyperpow_minus [simp]: "\<And>(a::'a::linordered_idom star) n. \<bar>(-a) pow n\<bar> = \<bar>a pow n\<bar>"
  by transfer (rule abs_power_minus)

lemma hyperpow_mult: "\<And>r s n. (r * s::'a::comm_monoid_mult star) pow n = (r pow n) * (s pow n)"
  by transfer (rule power_mult_distrib)

lemma hyperpow_two_le [simp]: "\<And>r. (0::'a::{monoid_mult,linordered_ring_strict} star) \<le> r pow 2"
  by (auto simp add: hyperpow_two zero_le_mult_iff)

lemma hyperpow_two_hrabs [simp]: "\<bar>x::'a::linordered_idom star\<bar> pow 2 = x pow 2"
  by (simp add: hyperpow_hrabs)

lemma hyperpow_two_gt_one: "\<And>r::'a::linordered_semidom star. 1 < r \<Longrightarrow> 1 < r pow 2"
  by transfer simp

lemma hyperpow_two_ge_one: "\<And>r::'a::linordered_semidom star. 1 \<le> r \<Longrightarrow> 1 \<le> r pow 2"
  by transfer (rule one_le_power)

lemma two_hyperpow_ge_one [simp]: "(1::hypreal) \<le> 2 pow n"
  by (metis hyperpow_eq_one hyperpow_le one_le_numeral zero_less_one)

lemma hyperpow_minus_one2 [simp]: "\<And>n. (- 1) pow (2 * n) = (1::hypreal)"
  by transfer (rule power_minus1_even)

lemma hyperpow_less_le: "\<And>r n N. (0::hypreal) \<le> r \<Longrightarrow> r \<le> 1 \<Longrightarrow> n < N \<Longrightarrow> r pow N \<le> r pow n"
  by transfer (rule power_decreasing [OF order_less_imp_le])

lemma hyperpow_SHNat_le:
  "0 \<le> r \<Longrightarrow> r \<le> (1::hypreal) \<Longrightarrow> N \<in> HNatInfinite \<Longrightarrow> \<forall>n\<in>Nats. r pow N \<le> r pow n"
  by (auto intro!: hyperpow_less_le simp: HNatInfinite_iff)

lemma hyperpow_realpow: "(hypreal_of_real r) pow (hypnat_of_nat n) = hypreal_of_real (r ^ n)"
  by transfer (rule refl)

lemma hyperpow_SReal [simp]: "(hypreal_of_real r) pow (hypnat_of_nat n) \<in> \<real>"
  by (simp add: Reals_eq_Standard)

lemma hyperpow_zero_HNatInfinite [simp]: "N \<in> HNatInfinite \<Longrightarrow> (0::hypreal) pow N = 0"
  by (drule HNatInfinite_is_Suc, auto)

lemma hyperpow_le_le: "(0::hypreal) \<le> r \<Longrightarrow> r \<le> 1 \<Longrightarrow> n \<le> N \<Longrightarrow> r pow N \<le> r pow n"
  by (metis hyperpow_less_le le_less)

lemma hyperpow_Suc_le_self2: "(0::hypreal) \<le> r \<Longrightarrow> r < 1 \<Longrightarrow> r pow (n + (1::hypnat)) \<le> r"
  by (metis hyperpow_less_le hyperpow_one hypnat_add_self_le le_less)

lemma hyperpow_hypnat_of_nat: "\<And>x. x pow hypnat_of_nat n = x ^ n"
  by transfer (rule refl)

lemma of_hypreal_hyperpow:
  "\<And>x n. of_hypreal (x pow n) = (of_hypreal x::'a::{real_algebra_1} star) pow n"
  by transfer (rule of_real_power)

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Hash maps implementation} *}
theory HashMap_Impl
imports
  RBTMapImpl
  ListMapImpl
  "../../Lib/HashCode"
begin

text {*
  We use a red-black tree instead of an indexed array. This
  has the disadvantage of being more complex, however we need not bother
  about a fixed-size array and rehashing if the array becomes too full.

  The entries of the red-black tree are lists of (key,value) pairs.
*}

subsection {* Abstract Hashmap *}
text {*
  We first specify the behavior of our hashmap on the level of maps.
  We will then show that our implementation based on hashcode-map and bucket-map
  is a correct implementation of this specification.
*}
type_synonym
  ('k,'v) abs_hashmap = "hashcode \<rightharpoonup> ('k \<rightharpoonup> 'v)"

  -- "Map entry of map by function"
abbreviation map_entry where "map_entry k f m == m(k := f (m k))"

  -- "Invariant: Buckets only contain entries with the right hashcode and there are no empty buckets"
definition ahm_invar:: "('k::hashable,'v) abs_hashmap \<Rightarrow> bool"
  where "ahm_invar m ==
    (\<forall>hc cm k. m hc = Some cm \<and> k\<in>dom cm \<longrightarrow> hashcode k = hc) \<and>
    (\<forall>hc cm. m hc = Some cm \<longrightarrow> cm \<noteq> Map.empty)"

  -- "Abstract a hashmap to the corresponding map"
definition ahm_\<alpha> where
  "ahm_\<alpha> m k == case m (hashcode k) of
    None \<Rightarrow> None |
    Some cm \<Rightarrow> cm k"

  -- "Lookup an entry"
definition ahm_lookup :: "'k::hashable \<Rightarrow> ('k,'v) abs_hashmap \<Rightarrow> 'v option"
  where "ahm_lookup k m == (ahm_\<alpha> m) k"

  -- "The empty hashmap"
definition ahm_empty :: "('k::hashable,'v) abs_hashmap"
  where "ahm_empty = Map.empty"

  -- "Update/insert an entry"
definition ahm_update where
  "ahm_update k v m ==
    case m (hashcode k) of
      None \<Rightarrow> m (hashcode k \<mapsto> [k \<mapsto> v]) |
      Some cm \<Rightarrow> m (hashcode k \<mapsto> cm (k \<mapsto> v))
  "

  -- "Delete an entry"
definition ahm_delete where
  "ahm_delete k m == map_entry (hashcode k)
    (\<lambda>v. case v of
      None \<Rightarrow> None |
      Some bm \<Rightarrow> (
        if bm |` (- {k}) = Map.empty then
          None
        else
          Some ( bm |` (- {k}))
      )
    ) m
  "

definition ahm_isEmpty where
  "ahm_isEmpty m == m=Map.empty"

text {*
  Now follow correctness lemmas, that relate the hashmap operations to
  operations on the corresponding map. Those lemmas are named op\_correct, where
  op is the operation.
*}

lemma ahm_invarI: "\<lbrakk>
  !!hc cm k. \<lbrakk>m hc = Some cm; k\<in>dom cm\<rbrakk> \<Longrightarrow> hashcode k = hc;
  !!hc cm. \<lbrakk> m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty
  \<rbrakk> \<Longrightarrow> ahm_invar m"
  by (unfold ahm_invar_def) blast

lemma ahm_invarD: "\<lbrakk> ahm_invar m; m hc = Some cm; k\<in>dom cm \<rbrakk> \<Longrightarrow> hashcode k = hc"
  by (unfold ahm_invar_def) blast

lemma ahm_invarDne: "\<lbrakk> ahm_invar m; m hc = Some cm \<rbrakk> \<Longrightarrow> cm \<noteq> Map.empty"
  by (unfold ahm_invar_def) blast

lemma ahm_invar_bucket_not_empty[simp]:
  "ahm_invar m \<Longrightarrow> m hc \<noteq> Some Map.empty"
  by (auto dest: ahm_invarDne)

lemmas ahm_lookup_correct = ahm_lookup_def

lemma ahm_empty_correct:
  "ahm_\<alpha> ahm_empty = Map.empty"
  "ahm_invar ahm_empty"
  apply (rule ext)
  apply (unfold ahm_empty_def)
  apply (auto simp add: ahm_\<alpha>_def intro: ahm_invarI split: option.split)
  done

lemma ahm_update_correct:
  "ahm_\<alpha> (ahm_update k v m) = ahm_\<alpha> m (k \<mapsto> v)"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_update k v m)"
  apply (rule ext)
  apply (unfold ahm_update_def)
  apply (auto simp add: ahm_\<alpha>_def split: option.split)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD ahm_invarDne split: split_if_asm)
  apply (rule ahm_invarI)
  apply (auto dest: ahm_invarD split: split_if_asm)
  apply (drule (1) ahm_invarD)
  apply auto
  done

lemma fun_upd_apply_ne: "x\<noteq>y \<Longrightarrow> (f(x:=v)) y = f y"
  by simp

lemma cancel_one_empty_simp: "m |` (-{k}) = Map.empty \<longleftrightarrow> dom m \<subseteq> {k}"
proof
  assume "m |` (- {k}) = Map.empty"
  hence "{} = dom (m |` (-{k}))" by auto
  also have "\<dots> = dom m - {k}" by auto
  finally show "dom m \<subseteq> {k}" by blast
next
  assume "dom m \<subseteq> {k}"
  hence "dom m - {k} = {}" by auto
  hence "dom (m |` (-{k})) = {}" by auto
  thus "m |` (-{k}) = Map.empty" by (simp only: dom_empty_simp)
qed

lemma ahm_delete_correct:
  "ahm_\<alpha> (ahm_delete k m) = (ahm_\<alpha> m) |` (-{k})"
  "ahm_invar m \<Longrightarrow> ahm_invar (ahm_delete k m)"
  apply (rule ext)
  apply (unfold ahm_delete_def)
  apply (auto simp add: ahm_\<alpha>_def Let_def Map.restrict_map_def
              split: option.split)[1]
  apply (drule_tac x=x in fun_cong)
  apply (auto)[1]
  apply (rule ahm_invarI)
  apply (auto split: split_if_asm option.split_asm dest: ahm_invarD)
  apply (drule (1) ahm_invarD)
  apply (auto simp add: restrict_map_def split: split_if_asm option.split_asm)
  done

lemma ahm_isEmpty_correct: "ahm_invar m \<Longrightarrow> ahm_isEmpty m \<longleftrightarrow> ahm_\<alpha> m = Map.empty"
proof
  assume "ahm_invar m" "ahm_isEmpty m"
  thus "ahm_\<alpha> m = Map.empty"
    by (auto simp add: ahm_isEmpty_def ahm_\<alpha>_def intro: ext)
next
  assume I: "ahm_invar m"
    and E: "ahm_\<alpha> m = Map.empty"

  show "ahm_isEmpty m"
  proof (rule ccontr)
    assume "\<not>ahm_isEmpty m"
    then obtain hc bm where MHC: "m hc = Some bm"
      by (unfold ahm_isEmpty_def)
         (blast elim: nempty_dom dest: domD)
    from ahm_invarDne[OF I, OF MHC] obtain k v where
      BMK: "bm k = Some v"
      by (blast elim: nempty_dom dest: domD)
    from ahm_invarD[OF I, OF MHC] BMK have [simp]: "hashcode k = hc"
      by auto
    hence "ahm_\<alpha> m k = Some v"
      by (simp add: ahm_\<alpha>_def MHC BMK)
    with E show False by simp
  qed
qed

lemmas ahm_correct = ahm_empty_correct ahm_lookup_correct ahm_update_correct
                     ahm_delete_correct ahm_isEmpty_correct

  -- "Bucket entries correspond to map entries"

  -- "Map entries correspond to bucket entries"
lemma ahm_e_is_be: "\<lbrakk>
  ahm_\<alpha> m k = Some v;
  !!bm. \<lbrakk>m (hashcode k) = Some bm; bm k = Some v \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (unfold ahm_\<alpha>_def)
     (auto split: option.split_asm)

subsection {* Concrete Hashmap *}
text {*
  In this section, we define the concrete hashmap that is made from the
  hashcode map and the bucket map.

  We then show the correctness of the operations w.r.t. the abstract hashmap, and
  thus, indirectly, w.r.t. the corresponding map.
*}

type_synonym
  ('k,'v) hm_impl = "(hashcode, ('k,'v) lm) rm"

subsubsection "Operations"

  -- "Auxiliary function: Apply function to value of an entry"
definition rm_map_entry
  :: "hashcode \<Rightarrow> ('v option \<Rightarrow> 'v option) \<Rightarrow> (hashcode, 'v) rm \<Rightarrow> (hashcode,'v) rm"
  where
  "rm_map_entry k f m ==
      case rm.lookup k m of
        None \<Rightarrow> (
          case f None of
            None \<Rightarrow> m |
            Some v \<Rightarrow> rm.update k v m
        ) |
        Some v \<Rightarrow> (
          case f (Some v) of
            None \<Rightarrow> rm.delete k m |
            Some v' \<Rightarrow> rm.update k v' m
        )
    "

  -- "Empty hashmap"
definition empty :: "unit \<Rightarrow> ('k :: hashable, 'v) hm_impl" where "empty == rm.empty"

  -- "Update/insert entry"
definition update :: "'k::hashable \<Rightarrow> 'v \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl"
  where
  "update k v m ==
   let hc = hashcode k in
     case rm.lookup hc m of
       None \<Rightarrow> rm.update hc (lm.update k v (lm.empty ())) m |
       Some bm \<Rightarrow> rm.update hc (lm.update k v bm) m"

  -- "Lookup value by key"
definition lookup :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> 'v option" where
  "lookup k m ==
   case rm.lookup (hashcode k) m of
     None \<Rightarrow> None |
     Some lm \<Rightarrow> lm.lookup k lm"

  -- "Delete entry by key"
definition delete :: "'k::hashable \<Rightarrow> ('k,'v) hm_impl \<Rightarrow> ('k,'v) hm_impl" where
  "delete k m ==
   rm_map_entry (hashcode k)
     (\<lambda>v. case v of
       None \<Rightarrow> None |
       Some lm \<Rightarrow> (
         let lm' = lm.delete k lm
         in  if lm.isEmpty lm' then None else Some lm'
       )
     ) m"

  -- "Emptiness check"
definition "isEmpty == rm.isEmpty"

  -- "Interruptible iterator"
definition "iteratei m c f \<sigma>0 ==
  rm.iteratei m c (\<lambda>(hc, lm) \<sigma>.
    lm.iteratei lm c f \<sigma>
  ) \<sigma>0"

lemma iteratei_alt_def :
  "iteratei m = set_iterator_image snd (
     set_iterator_product (rm.iteratei m) (\<lambda>hclm. lm.iteratei (snd hclm)))"
proof -
  have aux: "\<And>c f. (\<lambda>(hc, lm). lm.iteratei lm c f) = (\<lambda>m. lm.iteratei (snd m) c f)"
    by auto
  show ?thesis
    unfolding set_iterator_product_def set_iterator_image_alt_def
      iteratei_def[abs_def] aux
    by (simp add: split_beta)
qed

subsubsection "Correctness w.r.t. Abstract HashMap"
text {*
  The following lemmas establish the correctness of the operations w.r.t. the
  abstract hashmap.

  They have the naming scheme op\_correct', where op is the name of the
  operation.
*}

  -- "Abstract concrete hashmap to abstract hashmap"
definition hm_\<alpha>' where "hm_\<alpha>' m == \<lambda>hc. case rm.\<alpha> m hc of
  None \<Rightarrow> None |
  Some lm \<Rightarrow> Some (lm.\<alpha> lm)"

  -- "Invariant for concrete hashmap:
    The hashcode-map and bucket-maps satisfy their invariants and
    the invariant of the corresponding abstract hashmap is satisfied.
  "

definition "invar m == ahm_invar (hm_\<alpha>' m)"

lemma rm_map_entry_correct:
  "rm.\<alpha> (rm_map_entry k f m) = (rm.\<alpha> m)(k := f (rm.\<alpha> m k))"
  apply (auto
    simp add: rm_map_entry_def rm.delete_correct rm.lookup_correct rm.update_correct
    split: option.split)
  apply (auto simp add: Map.restrict_map_def fun_upd_def intro: ext)
  done

lemma empty_correct':
  "hm_\<alpha>' (empty ()) = ahm_empty"
  "invar (empty ())"
  by (simp_all add: hm_\<alpha>'_def empty_def ahm_empty_def rm.correct invar_def ahm_invar_def)

lemma lookup_correct':
  "invar m \<Longrightarrow> lookup k m = ahm_lookup k (hm_\<alpha>' m)"
  apply (unfold lookup_def invar_def)
  apply (auto split: option.split
              simp add: ahm_lookup_def ahm_\<alpha>_def hm_\<alpha>'_def
                        rm.correct lm.correct)
  done

lemma update_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (update k v m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (update k v m) = ahm_update k v (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: update_def ahm_update_def hm_\<alpha>'_def Let_def
                          rm.correct lm.correct
                split: option.split)
    done
  thus "invar m \<Longrightarrow> invar (update k v m)"
    by (simp add: invar_def ahm_update_correct)
qed

lemma delete_correct':
  "invar m \<Longrightarrow> hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
  "invar m \<Longrightarrow> invar (delete k m)"
proof -
  assume "invar m"
  thus "hm_\<alpha>' (delete k m) = ahm_delete k (hm_\<alpha>' m)"
    apply (unfold invar_def)
    apply (rule ext)
    apply (auto simp add: delete_def ahm_delete_def hm_\<alpha>'_def
                          rm_map_entry_correct
                          rm.correct lm.correct Let_def
                split: option.split option.split_asm)
    done
  thus "invar (delete k m)" using `invar m`
    by (simp add: ahm_delete_correct invar_def)
qed

lemma isEmpty_correct':
  "invar hm \<Longrightarrow> isEmpty hm \<longleftrightarrow> ahm_\<alpha> (hm_\<alpha>' hm) = Map.empty"
apply (simp add: isEmpty_def rm.isEmpty_correct invar_def
                 ahm_isEmpty_correct[unfolded ahm_isEmpty_def, symmetric])
by (auto simp add: hm_\<alpha>'_def ahm_\<alpha>_def fun_eq_iff split: option.split_asm)

(*
lemma sel_correct':
  assumes "invar hm"
  shows "\<lbrakk> sel hm f = Some r; \<And>u v. \<lbrakk> ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  and "\<lbrakk> sel hm f = None; ahm_\<alpha> (hm_\<alpha>' hm) u = Some v \<rbrakk> \<Longrightarrow> f (u, v) = None"
proof -
  assume sel: "sel hm f = Some r"
    and P: "\<And>u v. \<lbrakk>ahm_\<alpha> (hm_\<alpha>' hm) u = Some v; f (u, v) = Some r\<rbrakk> \<Longrightarrow> P"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from TrueI sel obtain hc lm where "rm_\<alpha> hm hc = Some lm"
    and "lm_sel lm f = Some r"
    unfolding sel_def by (rule rm.sel_someE) simp
  from TrueI `lm_sel lm f = Some r`
  obtain k v where "lm_\<alpha> lm k = Some v" "f (k, v) = Some r"
    by(rule lm.sel_someE)
  from `rm_\<alpha> hm hc = Some lm` have "hm_\<alpha>' hm hc = Some (lm_\<alpha> lm)"
    by(simp add: hm_\<alpha>'_def)
  with IA have "ahm_\<alpha> (hm_\<alpha>' hm) k = Some v" using `lm_\<alpha> lm k = Some v`
    by(rule ahm_be_is_e)
  thus P using `f (k, v) = Some r` by(rule P)
next
  assume sel: "sel hm f = None"
    and \<alpha>: "ahm_\<alpha> (hm_\<alpha>' hm) u = Some v"
  from `invar hm` have IA: "ahm_invar (hm_\<alpha>' hm)" by(simp add: invar_def)
  from \<alpha> obtain lm where \<alpha>_u: "hm_\<alpha>' hm (hashcode u) = Some lm"
    and "lm u = Some v" by (rule ahm_e_is_be)
  from \<alpha>_u obtain lmc where "rm_\<alpha> hm (hashcode u) = Some lmc" "lm = lm_\<alpha> lmc"
    by(auto simp add: hm_\<alpha>'_def split: option.split_asm)
  with `lm u = Some v` have "lm_\<alpha> lmc u = Some v" by simp
  from sel rm.sel_noneD [OF TrueI _ `rm_\<alpha> hm (hashcode u) = Some lmc`,
         of "(\<lambda>(hc, lm). lm_sel lm f)"]
  have "lm_sel lmc f = None" unfolding sel_def by simp
  with TrueI show "f (u, v) = None" using `lm_\<alpha> lmc u = Some v` by(rule lm.sel_noneD)
qed
*)

lemma iteratei_correct':
  assumes invar: "invar hm"
  shows "map_iterator (iteratei hm) (ahm_\<alpha> (hm_\<alpha>' hm))"
proof -
  from rm.iteratei_correct
  have it_rm: "map_iterator (rm.iteratei hm) (rm.\<alpha> hm)" by simp

  from lm.iteratei_correct
  have it_lm: "\<And>lm. map_iterator (lm.iteratei lm) (lm.\<alpha> lm)" by simp

  from set_iterator_product_correct
    [OF it_rm, of "\<lambda>hclm. lm.iteratei (snd hclm)"
     "\<lambda>hclm. map_to_set (lm.\<alpha> (snd hclm))", OF it_lm]
  have it_prod: "set_iterator
         (set_iterator_product (rm.iteratei hm) (\<lambda>hclm. lm.iteratei (snd hclm)))
         (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
    by simp

  show ?thesis unfolding iteratei_alt_def
  proof (rule set_iterator_image_correct[OF it_prod])
    from invar
    show "inj_on snd
       (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def split: option.splits)
      apply (metis domI option.inject)
    done
  next
    from invar
    show "map_to_set (ahm_\<alpha> (hm_\<alpha>' hm)) =
          snd ` (SIGMA hclm:map_to_set (rm.\<alpha> hm). map_to_set (lm.\<alpha> (snd hclm)))"
      apply (simp add: inj_on_def invar_def ahm_invar_def hm_\<alpha>'_def Ball_def
                       map_to_set_def set_eq_iff image_iff split: option.splits)
      apply (auto simp add: dom_def ahm_\<alpha>_def split: option.splits)
    done
  qed
qed

lemmas hm_correct' = empty_correct' lookup_correct' update_correct'
                     delete_correct' isEmpty_correct'
                     iteratei_correct'
lemmas hm_invars = empty_correct'(2) update_correct'(2)
                   delete_correct'(2)

hide_const (open) empty invar lookup update delete isEmpty iteratei

end