header {*Real-Valued Random Variables*}

theory RealRandVar
imports Measure "~~/src/HOL/Library/Countable"
begin

text {*While most of the above material was modeled after Hurd's work
  (but still proved independently),
  the original content basically starts here\footnote{There are two
  main reasons why the above has not been imported using Sebastian
Skalberg's import tool \cite{Skalberg}. Firstly, there are
  inconveniences caused by different conventions in HOL, meaning
  predicates instead of sets foremost, that make the consistent use of
  such basic definitions impractical. What is more, the import tool
  simply was not available at the time these theories were
  written.}. From now
  on, we will specialize in functions that map into
  the real numbers and are measurable with respect to the canonical sigma
  algebra on the reals, the Borel sigma algebra. These functions will
  be called real-valued random variables. The terminology is slightly
  imprecise, as random variables hint at a probability space, which
  usually requires @{text "measure M UNIV = 1"}. Notwithstanding, as we regard
  only finite measures (cf. \ref{sec:measure-spaces}), this condition can
  easily be achieved by normalization. After all, the other standard
  name, ``measurable functions'', is even less precise.

  A lot of the theory in this and the preceding section has also been
  formalized within the Mizar project \cite{mesfunc1,mesfunc2}. The
  abstract of the second source hints that it was also planned as a
  stepping stone for Lebesgue integration, though further results in
  this line could not be found. The main difference lies in the use of
  extended real numbers --- the reals together with @{text "\<plusminus>\<infinity>"} --- in
  those documents. It is established practice in measure theory
  to allow infinite values, but ``($\ldots$) we felt that the complications
  that this generated ($\ldots$) more than canceled out the gain in
  uniformity ($\ldots$), and that a simpler theory resulted from sticking to
  the standard real numbers.'' \cite[p.~32f]{hurd2002}. Hurd also advocates
  going directly to the hyper-reals, should the need for infinite
  measures arise. I agree, nevertheless sticking to his example for the reasons
  mentioned in the prologue.  *}

(*First of all, for the definition of a real valued random variable,
we need the Borel-\<sigma>-Algebra on the Reals*)
(*The smallest \<sigma>-Algebra containing {..u} for all rational u is
  sufficient, but we use all real u for simplicity!*)

definition
  Borelsets:: "real set set" ("\<bool>") where
  "\<bool> = sigma {S. \<exists>u. S={..u}}"

definition
(*We use Joe Hurd's formalism of a measure space (which assumes that
  the universe is always the whole type universe)*)
  rv:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> ('a \<Rightarrow> real) set" where
  "rv M = {f. measure_space M \<and> f \<in> measurable (measurable_sets M) \<bool>}"

text {* As explained in the first paragraph, the preceding
  definitions\footnote{The notation $@{text"{..u}"}$ signifies the
  interval from negative infinity to $u$ included.}
  determine the rest of this section. There are many ways to define
  the Borel sets. For example, taking into account only rationals for
  $u$ would also have worked out above, but we can take the reals to
  simplify things. The smallest sigma algebra containing all the open
  (or closed) sets is another alternative; the multitude of
  possibilities testifies to the relevance of the concept.

  The latter path leads the way to the fact that any continuous function is
  measurable. Generalization for $@{text \<real>}^n$ brings another unified way to
  prove all the measurability theorems in this theory plus, for instance,
  measurability of the trigonometric and exponential functions. This approach is detailed in another influential textbook
  by Billingsley \cite{Billingsley86}. It requires some concepts of
  topologic spaces, which made the following elementary
  course, based on Bauer's excellent book \cite{Bauer}, seem more feasible.

  Two more definitions go next. The image measure, law, or
  distribution --- the last term being specific to probability --- of a
  measure with respect to a measurable function is calculated as the measure of the
  inverse image of a set. Characteristic functions will
  be frequently needed in the rest of the development.
  *}
(*Perhaps one day we will need distributions, this might be the right
time to define them*)

definition
  distribution::
  "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> (real set \<Rightarrow> real)" ("law") where
  "f \<in> rv M \<Longrightarrow> law M f \<equiv> (measure M) \<circ> (vimage f)"

definition
  characteristic_function:: "'a set \<Rightarrow> ('a \<Rightarrow> real)" ("\<chi> _"(*<*)[1000](*>*)) where
  "\<chi> A x \<equiv> if x \<in> A then 1 else 0"

lemma char_empty: "\<chi> {} = (\<lambda>t. 0)"
proof (rule ext)
  fix t
  show "\<chi> {} t = 0" by (simp add: characteristic_function_def)
qed

text {* Now that random variables are defined, we aim to show that a
  broad class of functions belongs to them. For a constant function
  this is easy, as there are only two possible preimages. *}
  (*measurability lemmata*)

lemma assumes sigma: "sigma_algebra S"
  shows const_measurable: "(\<lambda>x. (c::real)) \<in> measurable S X"
proof (unfold measurable_def, rule, rule)
  fix g
  show "(\<lambda>x. c) -` g \<in> S"
  proof (cases "c \<in> g")
    case True
    hence "(\<lambda>x::'a. c) -` g = UNIV"
      by blast
    moreover from sigma have "UNIV \<in> S"
      by (rule sigma_algebra_UNIV)
    ultimately show ?thesis by simp
  next
    case False
    hence "(\<lambda>x::'a. c) -` g = {}"
      by blast
    moreover from sigma have "{} \<in> S"
      by (simp only: sigma_algebra_def)
    ultimately show ?thesis by simp
    txt{*\nopagebreak*}
  qed
qed

theorem assumes ms: "measure_space M"
  shows const_rv: "(\<lambda>x. c) \<in> rv M" using ms
  by (auto simp only: measure_space_def const_measurable rv_def)

text{*Characteristic functions produce four cases already, so the
  details are glossed over.*}

lemma assumes a: "a \<in> S" and sigma: "sigma_algebra S" shows
char_measurable : "\<chi> a \<in> measurable S x"
(*<*)proof -
  {fix g
    have "\<chi> a -` g \<in> S"
    proof (cases "1 \<in> g")
      case True
      show ?thesis
      proof (cases "0 \<in> g")
        case True
        with `1 \<in> g` have "\<chi> a -` g = UNIV" by (auto simp add: vimage_def characteristic_function_def)
        with sigma show ?thesis by (auto simp add: sigma_algebra_UNIV)
      next
        case False
        with `1 \<in> g` have "\<chi> a -` g = a"
          by (auto simp add: vimage_def characteristic_function_def)
        with a show ?thesis by simp
      qed

    next
      case False
      show ?thesis
      proof (cases "0 \<in> g")
        case True
        with `1 \<notin> g` have "\<chi> a -` g = -a"
          by (auto simp add: vimage_def characteristic_function_def)
        with a sigma show ?thesis by (simp add: sigma_algebra_def)
      next
        case False
        with `1 \<notin> g` have "\<chi> a -` g = {}" by (auto simp add: vimage_def characteristic_function_def)
        moreover from sigma have "{} \<in> S" by  (simp only: sigma_algebra_def)
        ultimately show ?thesis by simp
      qed
    qed}
  thus ?thesis by (unfold measurable_def) blast
qed(*>*)

theorem assumes ms: "measure_space M" and A: "A \<in> measurable_sets M"
  shows char_rv: "\<chi> A \<in> rv M" using ms A
  by (auto simp only: measure_space_def char_measurable rv_def)

text {*For more intricate functions, the following application of the
  measurability lifting theorem from \ref{sec:measure-spaces} gives a
  useful characterization.*}

theorem assumes ms: "measure_space M" shows
  rv_le_iff: "(f \<in> rv M) = (\<forall>a. {w. f w \<le> a} \<in> measurable_sets M)"
proof -

  have "f \<in> rv M \<Longrightarrow> \<forall>a. {w. f w \<le> a} \<in> measurable_sets M"
  proof
    { fix a
      assume "f \<in> measurable (measurable_sets M) \<bool>"
      hence "\<forall>b\<in>\<bool>. f -` b \<in> measurable_sets M"
        by (unfold measurable_def) blast
      also have "{..a} \<in> \<bool>"
        by (simp only: Borelsets_def) (rule sigma.basic, blast)
      ultimately have "{w. f w \<le> a} \<in> measurable_sets M"
        by (auto simp add: vimage_def)
    }
    thus "\<And>a. f \<in> rv M \<Longrightarrow> {w. f w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_def)
  qed

  also have "\<forall>a. {w. f w \<le> a} \<in> measurable_sets M \<Longrightarrow> f \<in> rv M"
  proof -
    assume "\<forall>a. {w. f w \<le> a} \<in> measurable_sets M"
    hence "f \<in> measurable (measurable_sets M){S. \<exists>u. S={..u}}"
      by (auto simp add: measurable_def vimage_def)
    with ms have "f \<in> measurable (measurable_sets M) \<bool>"
      by (simp only: Borelsets_def measure_space_def measurable_lift)
    with ms show ?thesis
      by (auto simp add: rv_def)
   txt{*\nopagebreak*}
  qed
  ultimately show ?thesis by rule
qed

text {*The next four lemmata allow for a ring deduction that helps establish
  this fact for all of the signs @{text "<"}, @{text ">"} and @{text "\<ge>"} as well.*}

lemma assumes sigma: "sigma_algebra A" and le: "\<forall>a. {w. f w \<le> a} \<in> A"
  shows le_less: "\<forall>a. {w. f w < (a::real)} \<in> A"
proof
  fix a::real
  from le sigma have "(\<Union>n::nat. {w. f w \<le> a - inverse (real (Suc n))}) \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "(\<Union>n::nat. {w. f w \<le> a - inverse (real (Suc n))}) = {w. f w < a}"
  proof -
    {
      fix w n
      have "0 < inverse (real (Suc (n::nat)))"
        by simp
      hence "f w \<le> a - inverse (real (Suc n)) \<Longrightarrow> f w < a"
        by arith
    }
    also
    { fix w
      have "(\<lambda>n. inverse (real (Suc n))) ----> 0"
        by (rule LIMSEQ_inverse_real_of_nat)

      also assume "f w < a"
      hence "0 < a - f w" by simp

      ultimately have
        "\<exists>n0. \<forall>n. n0 \<le> n \<longrightarrow> abs (inverse (real (Suc n))) < a - f w"
        by (auto simp add: LIMSEQ_def dist_real_def)
      then obtain n where  "abs (inverse (real (Suc n))) < a - f w"
        by blast
      hence "f w \<le> a - inverse (real (Suc n))"
        by arith
      hence "\<exists>n. f w \<le> a - inverse (real (Suc n))" ..
    }
    ultimately show ?thesis by auto
  qed
  finally show "{w. f w < a} \<in> A" .
qed

lemma assumes sigma: "sigma_algebra A" and less: "\<forall>a. {w. f w < a} \<in> A"
  shows less_ge: "\<forall>a. {w. (a::real) \<le> f w} \<in> A"
proof
  fix a::real
  from less sigma have "-{w. f w < a} \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "-{w. f w < a} = {w. a \<le> f w}"
    by auto

  finally show "{w. a \<le> f w} \<in> A" .
qed

lemma assumes sigma: "sigma_algebra A" and ge: "\<forall>a. {w. a \<le> f w} \<in> A"
  shows ge_gr: "\<forall>a. {w. (a::real) < f w} \<in> A"
(*<*)proof
  fix a::real
  from ge sigma have "(\<Union>n::nat. {w. a + inverse (real (Suc n)) \<le> f w}) \<in> A"
    by (simp add: sigma_algebra_def)
  also
  have "(\<Union>n::nat. {w. a + inverse (real (Suc n)) \<le> f w}) = {w. a < f w}"
  proof -
    {
      fix w n
      have "0 < inverse (real (Suc (n::nat)))" by simp
      hence "a + inverse (real (Suc n)) \<le> f w \<Longrightarrow> a < f w" by arith
    }
    also
    { fix w
      have "(\<lambda>n. inverse (real (Suc n))) ----> 0" by (rule LIMSEQ_inverse_real_of_nat)

      also assume "a < f w"
      hence "0 < f w - a" by simp

      ultimately have "\<exists>n0. \<forall>n. n0 \<le> n \<longrightarrow> abs (inverse (real (Suc n))) < f w - a"
        by (auto simp add: LIMSEQ_def dist_real_def)
      then obtain n where  "abs (inverse (real (Suc n))) < f w - a" by blast
      hence "a + inverse (real (Suc n)) \<le> f w" by arith
      hence "\<exists>n. a + inverse (real (Suc n)) \<le> f w" ..
    }
    ultimately show ?thesis by auto
  qed

  finally show "{w. a < f w} \<in> A" .
qed(*>*)

lemma assumes sigma: "sigma_algebra A" and gr: "\<forall>a. {w. a < f w} \<in> A"
  shows gr_le: "\<forall>a. {w. f w \<le> (a::real)} \<in> A"
(*<*)proof
  fix a::real
  from gr sigma have "-{w. a < f w} \<in> A" by (simp add: sigma_algebra_def)
  also
  have "-{w. a < f w} = {w. f w \<le> a}" by auto

  finally show "{w. f w \<le> a} \<in> A" .
qed(*>*)

theorem assumes ms: "measure_space M" shows
  rv_ge_iff: "(f \<in> rv M) = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)"
proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w. f w \<le> a} \<in> measurable_sets M)"
    by (rule rv_le_iff)
  also have "\<dots> = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)"
      by (simp only: measure_space_def)
    also note less_ge le_less
    ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also
    from sigma gr_le ge_gr have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately
    show ?thesis ..
  qed
  finally show ?thesis .
qed

theorem assumes ms: "measure_space M" shows
  rv_gr_iff: "(f \<in> rv M) = (\<forall>a. {w. a < f w} \<in> measurable_sets M)"
(*<*)proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w.  a \<le> f w} \<in> measurable_sets M)" by (rule rv_ge_iff)
  also have "\<dots> = (\<forall>a. {w.  a < f w} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)" by (simp only: measure_space_def)
    also note ge_gr ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also from sigma less_ge le_less gr_le have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately show ?thesis ..
  qed
  finally show ?thesis .
qed(*>*)

theorem assumes ms: "measure_space M" shows
  rv_less_iff: "(f \<in> rv M) = (\<forall>a. {w. f w < a} \<in> measurable_sets M)"
(*<*)proof -
  from ms have "(f \<in> rv M) = (\<forall>a. {w. a \<le> f w} \<in> measurable_sets M)" by (rule rv_ge_iff)
  also have "\<dots> = (\<forall>a. {w. f w < a} \<in> measurable_sets M)" (is "?lhs = ?rhs")
  proof -
    from ms have sigma: "sigma_algebra (measurable_sets M)" by (simp only: measure_space_def)
    also note le_less gr_le ge_gr ultimately have "?lhs \<Longrightarrow> ?rhs" by blast
    also from sigma less_ge have "?rhs \<Longrightarrow> ?lhs" by blast
    ultimately show ?thesis ..
  qed
  finally show ?thesis .
qed(*>*)

text {*As a first application we show that addition and multiplication
  with constants preserve measurability. This is a precursor to the
  more general addition and multiplication theorems later on. You can see that
  quite a few properties of the real numbers are employed.*}

lemma assumes g: "g \<in> rv M"
  shows affine_rv: "(\<lambda>x. (a::real) + (g x) * b) \<in> rv M"
proof (cases "b=0")
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  case True
  hence "(\<lambda>x. a + (g x) * b) = (\<lambda>x. a)"
    by simp
  also
  from g have "(\<lambda>x. a) \<in> rv M"
    by (simp add: const_measurable rv_def measure_space_def)
  ultimately show ?thesis by simp

next
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  case False
  have calc: "\<And>x c. (a + g x * b \<le> c) = (g x * b  \<le> c - a)"
    by arith
  have "\<forall>c. {w.  a + g w * b \<le> c} \<in> measurable_sets M"
  proof (cases "b<0")
    case False
    with `b \<noteq> 0` have "0<b" by arith
    hence "\<And>x c.  (g x * b  \<le> c - a) = (g x \<le> (c - a) / b)"
      by (rule pos_le_divide_eq [THEN sym])
    with calc have "\<And>c. {w.  a + g w * b \<le> c} = {w. g w \<le> (c - a) / b}"
      by simp

    also from ms g  have "\<forall>a. {w. g w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_le_iff)

    ultimately show ?thesis by simp

  next
    case True
    hence "\<And>x c. (g x * b \<le> c-a) = ((c-a)/b \<le> g x)"
      by (rule neg_divide_le_eq [THEN sym])
    with calc have "\<And>c. {w.  a + g w * b \<le> c} = {w. (c-a)/b \<le> g w}"
      by simp

    also from ms g have "\<forall>a. {w. a \<le> g w } \<in> measurable_sets M"
      by (simp add: rv_ge_iff)

    ultimately show ?thesis by simp
  qed

  with ms show ?thesis
    by (simp only: rv_le_iff [THEN sym])
qed

text {*For the general case of addition, we need one more set to be
  measurable, namely @{text "{w. f w \<le> g w}"}. This follows from a
  like statement for $<$. A dense and countable
  subset of the reals is needed to establish it.

  Of course, the rationals come to
  mind. They were not available in Isabelle/HOL\footnote{At least not
  as a subset of the reals, to the definition of which a type of
  positive rational numbers contributed \cite{Fleuriot:2000:MNR}.}, so
  I built a theory with the necessary properties on my own. [Meanwhile
  Isabelle has proper rationals and SR's development of the rationals has been
  moved to and merged with Isabelle's rationals.*}

(*For this theorem, we need some properties of the rational numbers
(or any other dense and countable set in the reals - so why not use
the rationals?).*)

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_less_rv_measurable: "{w. f w < g w} \<in> measurable_sets M"
proof -
  let "?I i" = "let s::real = of_rat(nat_to_rat_surj i) in {w. f w < s} \<inter> {w. s < g w}"
  from g have ms: "measure_space M" by (simp add: rv_def)
  have "{w. f w < g w} = (\<Union>i. ?I i)"
  proof
    { fix w assume "w \<in> {w. f w < g w}"
      hence "f w < g w" ..
      hence "\<exists>s\<in>\<rat>. f w < s \<and> s < g w" by (rule Rats_dense_in_real)
      hence "\<exists>s\<in>\<rat>. w \<in> {w. f w < s} \<inter> {w. s < g w}" by simp
      hence "\<exists>i. w \<in> ?I i"
        by(simp add:Let_def)(metis surj_of_rat_nat_to_rat_surj)
      hence "w \<in> (\<Union>i. ?I i)" by simp
    }
    thus "{w. f w < g w} \<subseteq> (\<Union>i. ?I i)" ..

    show "(\<Union>i. ?I i) \<subseteq> {w. f w < g w}" by (force simp add: Let_def)
  qed
  moreover have "(\<Union>i. ?I i) \<in> measurable_sets M"
  proof -
    from ms have sig: "sigma_algebra (measurable_sets M)"
      by (simp only: measure_space_def)
    { fix s
      note sig
      also from ms f have "{w. f w < s} \<in> measurable_sets M" (is "?a\<in>?M")
        by (simp add: rv_less_iff)
      moreover from ms g have "{w. s < g w} \<in> ?M" (is "?b \<in> ?M")
        by (simp add: rv_gr_iff)
      ultimately have "?a \<inter> ?b \<in> ?M" by (rule sigma_algebra_inter)
    }
    hence "\<forall>i. ?I i \<in> measurable_sets M" by (simp add: Let_def)
    with sig show ?thesis by (auto simp only: sigma_algebra_def Let_def)
  qed
  ultimately show ?thesis by simp
qed

(*The preceding theorem took me about 1 month to establish through its deep dependencies*)
lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_le_rv_measurable: "{w. f w \<le> g w} \<in> measurable_sets M" (is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M"
    by (simp add: rv_def)
  from g f have "{w. g w < f w} \<in> ?M"
    by (rule rv_less_rv_measurable)
  also from ms have "sigma_algebra ?M"
    by (simp only: measure_space_def)

  ultimately have "-{w. g w < f w} \<in> ?M"
    by (simp only: sigma_algebra_def)
  also have "-{w. g w < f w} = ?a"
    by auto
txt{*\nopagebreak*}
  finally show ?thesis .
qed

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows f_eq_g_measurable: "{w. f w = g w} \<in> measurable_sets M" (*<*)(is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  hence "sigma_algebra ?M" by (simp only: measure_space_def)
  also from f g ms have "{w. f w \<le> g w} \<in> ?M" and "{w. g w \<le> f w} \<in> ?M"
    by (auto simp only: rv_le_rv_measurable)

  ultimately have "{w. f w \<le> g w} \<inter> {w. g w \<le> f w} \<in> ?M" (is "?b \<in> ?M")
    by (rule sigma_algebra_inter)
  also have "?b = ?a" by auto

  finally show ?thesis .
qed(*>*)

lemma assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows f_noteq_g_measurable: "{w. f w \<noteq> g w} \<in> measurable_sets M" (*<*)(is "?a \<in> ?M")
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  hence "sigma_algebra ?M" by (simp only: measure_space_def)
  also from f g have "{w. f w = g w} \<in> ?M" by (rule f_eq_g_measurable)

  ultimately have "-{w. f w = g w} \<in> ?M" by (simp only: sigma_algebra_def)
  also have "-{w. f w = g w} = ?a" by auto

  finally show ?thesis .
qed(*>*)

text {* With these tools, a short proof for the addition theorem is
  possible. *}

theorem assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_plus_rv: "(\<lambda>w. f w + g w) \<in> rv M"
proof -
  from g have ms: "measure_space M" by (simp add: rv_def)
  { fix a
    have "{w. a \<le> f w + g w} = {w. a + (g w)*(-1) \<le> f w}"
      by auto
    moreover from g have "(\<lambda>w. a + (g w)*(-1)) \<in> rv M"
      by (rule affine_rv)
    with f have "{w. a + (g w)*(-1) \<le> f w} \<in> measurable_sets M"
      by (simp add: rv_le_rv_measurable)
    ultimately have "{w. a \<le> f w + g w} \<in> measurable_sets M" by simp
  }
  with ms show ?thesis
    by (simp add: rv_ge_iff)
  thm rv_ge_iff
qed

text {*To show preservation of measurability by multiplication, it is
  expressed by addition and squaring. This requires a few technical
  lemmata including the one stating measurability for squares, the proof of which is skipped.*}

(*This lemma should probably be in the RealPow Theory or a special Sqroot-Theory*)
lemma pow2_le_abs: "(a\<^sup>2 \<le> b\<^sup>2) = (\<bar>a\<bar> \<le> \<bar>b::real\<bar>)"
(*<*)proof -
  have "(a\<^sup>2 \<le> b\<^sup>2) = (\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2)" by (simp add: numeral_2_eq_2)
  also have "\<dots> = (\<bar>a\<bar> \<le> \<bar>b\<bar>)"
  proof
    assume "\<bar>a\<bar> \<le> \<bar>b\<bar>"
    thus "\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2"
      by (rule power_mono) simp
  next
    assume "\<bar>a\<bar>\<^sup>2 \<le> \<bar>b\<bar>\<^sup>2" hence "\<bar>a\<bar>^(Suc 1) \<le> \<bar>b\<bar>^(Suc 1)" by (simp add: numeral_2_eq_2)
    moreover have "0 \<le> \<bar>b\<bar>" by auto
    ultimately show "\<bar>a\<bar> \<le> \<bar>b\<bar>" by (rule power_le_imp_le_base)
  qed
  finally show ?thesis .
qed(*>*)

lemma assumes f: "f \<in> rv M"
  shows rv_square: "(\<lambda>w. (f w)\<^sup>2) \<in> rv M"
(*<*)proof -
  from f have ms: "measure_space M" by (simp add: rv_def)
  hence "?thesis = (\<forall>a. {w. (f w)\<^sup>2 \<le> a} \<in> measurable_sets M)" (is "_ = (\<forall>a. ?F a \<in> ?M)") by (rule rv_le_iff)
  also {
    fix a
    from ms have sig: "sigma_algebra ?M" by (simp only: measure_space_def)
    have "?F a \<in> ?M"
    proof (cases "a < 0")

      case True
      { fix w
        note True
        also have "0 \<le> (f w)\<^sup>2" by simp
        finally have "((f w)\<^sup>2 \<le> a) = False" by simp
      } hence "?F a = {}" by simp
      thus ?thesis using sig by (simp only: sigma_algebra_def)

    next
      case False
      show ?thesis
      proof (cases "a = 0")

        case True also
        { fix w
          have "0 \<le> (f w)\<^sup>2" by simp
          hence "((f w)\<^sup>2 \<le> 0) \<Longrightarrow> ((f w)\<^sup>2 = 0)" by (simp only: order_antisym)
          hence "((f w)\<^sup>2 \<le> 0) = ((f w)\<^sup>2 = 0)" by (force simp add: numeral_2_eq_2)
          also have "\<dots> = (f w = 0)" by simp
          finally have "((f w)\<^sup>2 \<le> 0) = \<dots>" .
        }

        ultimately have "?F a = {w. f w = 0}" by simp
        moreover have "\<dots> = {w. f w \<le> 0} \<inter> {w. 0 \<le> f w}" by auto
        moreover have "\<dots> \<in> ?M"
        proof -
          from ms f have "{w. f w \<le> 0} \<in> ?M" by (simp only: rv_le_iff)
          also from ms f have "{w. 0 \<le> f w} \<in> ?M" by (simp only: rv_ge_iff)
          ultimately show ?thesis using sig by (simp only: sigma_algebra_inter)
        qed

        ultimately show ?thesis by simp

      next
        case False
        with `\<not> a < 0` have "0<a" by (simp add: order_less_le)
        then have "\<exists> sqra. 0<sqra \<and> sqra\<^sup>2 = a" by (simp only: realpow_pos_nth2 numeral_2_eq_2)
        then have "\<And>w. \<exists> sqra. ?F a = {w. -sqra \<le> f w} \<inter> {w. f w \<le> sqra}"
          by (auto simp only: pow2_le_abs abs_le_interval_iff)
        then obtain sqra where "?F a = {w. -sqra \<le> f w} \<inter> {w. f w \<le> sqra}" by fast
        moreover have "\<dots> \<in> ?M"
        proof -
          from ms f have "{w. f w \<le> sqra} \<in> ?M" by (simp only: rv_le_iff)
          also from ms f have "{w. -sqra \<le> f w} \<in> ?M" by (simp only: rv_ge_iff)
          ultimately show ?thesis using sig by (simp only: sigma_algebra_inter)
        qed

        ultimately show ?thesis by simp

      qed
    qed
  }

  ultimately show ?thesis by simp

qed(*>*)

lemma realpow_two_binomial_iff: "(f+g::real)\<^sup>2 = f\<^sup>2 + 2*(f*g) + g\<^sup>2"
  (*<*)
  by (simp add: power2_eq_square distrib_right distrib_left)(*>*)

lemma times_iff_sum_squares: "f*g = (f+g)\<^sup>2/4 - (f-g)\<^sup>2/(4::real)"
  by (simp add: power2_eq_square field_simps)

theorem assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows rv_times_rv: "(\<lambda>w. f w * g w) \<in> rv M"
proof -
  have "(\<lambda>w. f w * g w) = (\<lambda>w. (f w + g w)\<^sup>2/4 - (f w - g w)\<^sup>2/4)"
    by (simp only: times_iff_sum_squares)
  also have "\<dots> = (\<lambda>w. (f w + g w)\<^sup>2*inverse 4 - (f w + - g w)\<^sup>2*inverse 4)"
    by simp
  also from f g have "\<dots> \<in> rv M"
  proof -
    from f g have "(\<lambda>w. (f w + g w)\<^sup>2)  \<in> rv M"
      by (simp add: rv_plus_rv rv_square)
    hence "(\<lambda>w. 0+(f w + g w)\<^sup>2*inverse 4) \<in> rv M"
      by (rule affine_rv)
    also from g have "(\<lambda>w. 0 + (g w)*-1 ) \<in> rv M"
      by (rule affine_rv)
    with f have "(\<lambda>w. (f w - g w)\<^sup>2)  \<in> rv M"
      by (simp add: rv_plus_rv rv_square diff_conv_add_uminus del: add_uminus_conv_diff)
    hence "(\<lambda>w. 0+(f w - g w)\<^sup>2*-inverse 4) \<in> rv M"
      by (rule affine_rv)
    ultimately show ?thesis
      by (simp add: rv_plus_rv diff_conv_add_uminus del: add_uminus_conv_diff)
  qed txt{*\nopagebreak*}
  ultimately show ?thesis by simp
qed

text{*The case of substraction is an easy consequence of @{text rv_plus_rv} and
  @{text rv_times_rv}.*}

theorem rv_minus_rv:
  assumes f: "f \<in> rv M" and g: "g \<in> rv M"
  shows "(\<lambda>t. f t - g t) \<in> rv M"
(*<*)proof -
  from f have ms: "measure_space M" by (simp add: rv_def)
  hence "(\<lambda>t. -1) \<in> rv M" by (simp add: const_rv)
  from this g have "(\<lambda>t. -1*g t) \<in> rv M" by (rule rv_times_rv)
  hence "(\<lambda>t. -g t) \<in> rv M" by simp
  with f have "(\<lambda>t. f t +-g t) \<in> rv M" by (rule rv_plus_rv)
  thus ?thesis by simp
qed(*>*)
text{*Measurability for limit functions of
    monotone convergent series is also surprisingly straightforward.*}

theorem assumes u: "\<And>n. u n \<in> rv M" and mon_conv: "u\<up>f"
  shows mon_conv_rv: "f \<in> rv M"
proof -
  from u have ms: "measure_space M"
    by (simp add: rv_def)

  {
    fix a
    {
      fix w
      from mon_conv have up: "(\<lambda>n. u n w)\<up>f w"
        by (simp only: realfun_mon_conv_iff)
      {
        fix i
        from up have "u i w \<le> f w"
          by (rule real_mon_conv_le)
        also assume "f w \<le> a"
        finally have  "u i w \<le> a" .
      }

      also
      { assume "\<And>i. u i w \<le> a"
        also from up have "(\<lambda>n. u n w) ----> f w"
          by (simp only: real_mon_conv)
        ultimately have "f w \<le> a"
          by (simp add: LIMSEQ_le_const2)
      }
      ultimately have "(f w \<le> a) = (\<forall>i. u i w \<le> a)" by fast
    }
    hence "{w. f w \<le> a} = (\<Inter>i. {w. u i w \<le> a})" by fast
    moreover
    from ms u have "\<And>i. {w. u i w \<le> a} \<in> sigma(measurable_sets M)"
      by (simp add: rv_le_iff sigma.intros)
    hence "(\<Inter>i. {w. u i w \<le> a}) \<in> sigma(measurable_sets M)"
      by (rule sigma_Inter)
    with ms have "(\<Inter>i. {w. u i w \<le> a}) \<in> measurable_sets M"
      by (simp only: measure_space_def sigma_sigma_algebra)
    ultimately have "{w. f w \<le> a} \<in> measurable_sets M" by simp
  }
  with ms show ?thesis
    by (simp add: rv_le_iff)
qed

text {* Before we end this chapter to start the formalization of the
  integral proper, there is one more concept missing: The
  positive and negative part of a function. Their definition is quite intuitive,
  and some useful properties are given right away, including the fact
  that they are random variables, provided that their argument
  functions are measurable. *}

definition
  nonnegative:: "('a \<Rightarrow> ('b::{ord,zero})) \<Rightarrow> bool" where
  "nonnegative f \<longleftrightarrow> (\<forall>x. 0 \<le> f x)"

definition
  positive_part:: "('a \<Rightarrow> ('b::{ord,zero})) \<Rightarrow> ('a \<Rightarrow> 'b)" ("pp") where
  "pp f x = (if 0\<le>f(x) then f x else 0)"

definition
  negative_part:: "('a \<Rightarrow> ('b::{ord,zero,uminus,minus})) \<Rightarrow> ('a \<Rightarrow> 'b)" ("np") where
  "np f x = (if 0\<le>f(x) then 0 else -f(x))"
  (*useful lemmata about positive and negative parts*)
lemma f_plus_minus: "((f x)::real) = pp f x - np f x"
  by (simp add:positive_part_def negative_part_def)

lemma f_plus_minus2: "(f::'a \<Rightarrow> real) = (\<lambda>t. pp f t - np f t)"
  using f_plus_minus
  by (rule ext)

lemma f_abs_plus_minus: "(\<bar>f x\<bar>::real) = pp f x + np f x"
  by  (auto simp add:positive_part_def negative_part_def)

lemma nn_pp_np: assumes "nonnegative f"
  shows "pp f = f" and "np f = (\<lambda>t. 0)" using assms
  by (auto simp add: positive_part_def negative_part_def nonnegative_def ext)

lemma pos_pp_np_help: "\<And>x. 0\<le>f x \<Longrightarrow> pp f x = f x \<and> np f x = 0"
  by (simp add: positive_part_def negative_part_def)

lemma real_neg_pp_np_help: "\<And>x. f x \<le> (0::real) \<Longrightarrow> np f x = -f x \<and> pp f x = 0"
(*<*)proof -
  fix x
  assume le: "f x \<le> 0"
  hence "pp f x = 0 "
    by (cases "f x < 0") (auto simp add: positive_part_def)
  also from le have "np f x = -f x"
    by (cases "f x < 0") (auto simp add: negative_part_def)
  ultimately show "np f x = -f x \<and> pp f x = 0" by fast
qed(*>*)

lemma real_neg_pp_np: assumes "f \<le> (\<lambda>t. (0::real))"
 shows "np f = (\<lambda>t. -f t)" and "pp f = (\<lambda>t. 0)" using assms
  by (auto simp add: real_neg_pp_np_help ext le_fun_def)

lemma assumes a: "0\<le>(a::real)"
  shows real_pp_np_pos_times:
  "pp (\<lambda>t. a*f t) = (\<lambda>t. a*pp f t) \<and>  np (\<lambda>t. a*f t) = (\<lambda>t. a*np f t)"
(*<*)proof -
  { fix t
    have "pp (\<lambda>t. a*f t) t = a*pp f t \<and> np (\<lambda>t. a*f t) t = a*np f t"
    proof (cases "0 \<le> f t")
      case True
      from a this a order_refl[of 0] have le: "0*0\<le>a*f t"
        by (rule mult_mono)
      hence "pp (\<lambda>t. a*f t) t = a*f t" by (simp add: positive_part_def)
      also from True have "\<dots> = a*pp f t" by (simp add: positive_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = a*pp f t" .

      from le have "np (\<lambda>t. a*f t) t = 0" by (simp add: negative_part_def)
      also from True have "\<dots> = a*np f t" by (simp add: negative_part_def)
      finally show ?thesis using 1 by fast
    next
      case False
      hence "f t \<le> 0" by simp
      from this a have "(f t)*a \<le> 0*a" by (rule mult_right_mono)
      hence le: "a*f t \<le> 0" by (simp add: mult.commute)
      hence "pp (\<lambda>t. a*f t) t = 0"
        by (cases "a*f t<0") (auto simp add: positive_part_def order_le_less )
      also from False have "\<dots> = a*pp f t" by (simp add: positive_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = a*pp f t" .

      from le have "np (\<lambda>t. a*f t) t = -a*f t"
        by (cases "a*f t=0") (auto simp add: negative_part_def order_le_less)
      also from False have "\<dots> = a*np f t" by (simp add: negative_part_def)
      finally show ?thesis using 1 by fast
    qed
  } thus ?thesis by (simp add: ext)
qed(*>*)

lemma assumes a: "(a::real)\<le>0"
  shows real_pp_np_neg_times:
  "pp (\<lambda>t. a*f t) = (\<lambda>t. -a*np f t) \<and>  np (\<lambda>t. a*f t) = (\<lambda>t. -a*pp f t)"
(*<*)proof -
  { fix t
    have "pp (\<lambda>t. a*f t) t = -a*np f t \<and> np (\<lambda>t. a*f t) t = -a*pp f t"
    proof (cases "0 \<le> f t")
      case True
      with a have le: "a*f t\<le>0*f t"
        by (rule mult_right_mono)
      hence "pp (\<lambda>t. a*f t) t = 0" by (simp add: real_neg_pp_np_help)
      also from True have "\<dots> = -a*np f t" by (simp add: negative_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = -a*np f t" .

      from le have "np (\<lambda>t. a*f t) t = -a*f t" by (simp add: real_neg_pp_np_help)
      also from True have "\<dots> = -a*pp f t" by (simp add: positive_part_def)
      finally show ?thesis using 1 by fast
    next
      case False
      hence "f t \<le> 0" by simp
      with a have le: "0\<le>a*(f t)" by (simp add: zero_le_mult_iff)
      hence "pp (\<lambda>t. a*f t) t = a*f t" by (simp add: positive_part_def)
      also from False have "\<dots> = -a*np f t" by (simp add: negative_part_def)
      finally have 1: "pp (\<lambda>t. a*f t) t = -a*np f t" .

      from le have "np (\<lambda>t. a*f t) t = 0" by (simp add: negative_part_def)
      also from False have "\<dots> = -a*pp f t" by (simp add: positive_part_def)
      finally show ?thesis using 1 by fast
    qed
  } thus ?thesis by (simp add: ext)
qed(*>*)

lemma pp_np_rv:
  assumes f: "f \<in> rv M"
  shows "pp f \<in> rv M" and "np f \<in> rv M"
proof -
  from f have ms: "measure_space M" by (simp add: rv_def)

  { fix a
    from ms f have fm: "{w. f w \<le> a} \<in> measurable_sets M"
      by (simp add: rv_le_iff)
    have
      "{w. pp f w \<le> a} \<in> measurable_sets M \<and>
      {w. np f w \<le> a} \<in> measurable_sets M"
    proof (cases "0\<le>a")
      case True
      hence "{w. pp f w \<le> a} = {w. f w \<le> a}"
        by (auto simp add: positive_part_def)
      moreover note fm moreover
      from True have "{w. np f w \<le> a} = {w. -a \<le> f w}"
        by (auto simp add: negative_part_def)
      moreover from ms f have "\<dots> \<in> measurable_sets M"
        by (simp add: rv_ge_iff)
      ultimately show ?thesis by simp
    next
      case False
      hence "{w. pp f w \<le> a} = {}"
        by (auto simp add: positive_part_def)
      also from False have "{w. np f w \<le> a} = {}"
        by (auto simp add: negative_part_def)
      moreover from ms have "{} \<in> measurable_sets M"
        by (simp add: measure_space_def sigma_algebra_def)
      ultimately show ?thesis by simp
    qed
  } with ms show "pp f \<in> rv M" and "np f \<in> rv M"
    by (auto simp add: rv_le_iff)
qed

theorem pp_np_rv_iff: "(f::'a \<Rightarrow> real) \<in> rv M = (pp f \<in> rv M \<and> np f \<in> rv M)"
(*<*)proof -
  { assume "pp f \<in> rv M" and "np f \<in> rv M"
    hence "(\<lambda>t. pp f t - np f t) \<in> rv M" by (rule rv_minus_rv)
    also have "f = (\<lambda>t. pp f t - np f t)" by (rule f_plus_minus2)
    ultimately have "f \<in> rv M" by simp
  } also
  have "f \<in> rv M \<Longrightarrow> (pp f \<in> rv M \<and> np f \<in> rv M)" by (simp add: pp_np_rv)
  ultimately show ?thesis by fast
qed(*>*)

text{*This completes the chapter about measurable functions. As we
  will see in the next one, measurability is the prime condition on
  Lebesgue integrable functions; and the theorems and lemmata
  established here suffice --- at least in principle --- to show it holds for any
  function that is to be integrated there.*}

end


theory ModelIso
imports SSL
begin
lift_definition model_iso :: "model \<Rightarrow> model \<Rightarrow> bool" (infix "\<cong>" 60) is
  "\<lambda>(s,h) (s',h'). (\<exists>f::loc \<Rightarrow> loc.
    bij_betw f (locs h \<union> ran s) (locs h' \<union> ran s') \<and>
    bij_betw f (-(locs h \<union> ran s)) (-(locs h' \<union> ran s')) \<and>
    (\<forall>x. s' x = map_option f (s x)) \<and>
    (Map.graph h' = {(f l, f l') | l l'. h l = Some l'}))" .

abbreviation iso_fun :: "(loc \<Rightarrow> loc) \<Rightarrow> model \<Rightarrow> model \<Rightarrow> bool" where
  "iso_fun f m1 m2 \<equiv> bij_betw f (locs (heap m1) \<union> ran (stack m1)) (locs (heap m2) \<union> ran (stack m2)) \<and>
  bij_betw f (-(locs (heap m1) \<union> ran (stack m1))) (-(locs (heap m2) \<union> ran (stack m2))) \<and>
  bij f \<and>
  (\<forall>x. stack m2 x = map_option f (stack m1 x)) \<and>
  (Map.graph (heap m2) = {(f l, f l') | l l'. heap m1 l = Some l'})"

fun iso_fun' :: "(loc \<Rightarrow> loc) \<Rightarrow> (stack\<times>heap) \<Rightarrow> (stack\<times>heap) \<Rightarrow> bool" where
  "iso_fun' f (s,h) (s',h') = (bij_betw f (locs h \<union> ran s) (locs h' \<union> ran s') \<and>
  bij_betw f (-(locs h \<union> ran s)) (-(locs h' \<union> ran s')) \<and>
  bij f \<and> (\<forall>x. s' x = map_option f (s x)) \<and> (Map.graph h' = (\<lambda>(l,r). (f l, f r))`Map.graph h))"

lemma iso_fun_s_bij: "iso_fun f m1 m2 \<Longrightarrow> bij_betw f (ran (stack m1)) (ran (stack m2))"
  by (auto simp: ran_def bij_betw_def) (meson inj_on_Un)

lemma heap_union_graph: "heap_union h1 s h2 = Some h3 \<Longrightarrow> Map.graph h3 = Map.graph h1 \<union> Map.graph h2"
  apply (auto simp: heap_union_def weak_heap_union_def Map.graph_def)
  apply (metis (no_types, lifting) map_add_SomeD option.discI option.inject weak_heap_union_def)
  apply (metis domIff map_add_comm map_add_dom_app_simps(1) option.distinct(1) option.sel weak_heap_union_def)
  by (metis map_add_find_right option.distinct(1) option.sel weak_heap_union_def)

lemma graph_dom_ran: "Map.graph h = (\<lambda>(l, r). (f l, f r)) ` Map.graph h' \<Longrightarrow> dom h = f`dom h' \<and> ran h = f`ran h'"
  by (auto simp: fst_graph_eq_dom[symmetric] snd_graph_ran[symmetric] intro: fst_eqD rev_image_eqI)

lemma iso_heap_union:
assumes "Map.graph h1 = (\<lambda>(l,r). (f l, f r))`Map.graph h2" "bij f"
  "Map.graph h3 = (\<lambda>(l,r). (f l, f r))`Map.graph h4" "ran s' = f`ran s" "heap_union h2 s h4 = Some h5"
shows "\<exists>h6. heap_union h1 s' h3 = Some h6 \<and> Map.graph h6 = (\<lambda>(l,r). (f l, f r))`Map.graph h5"
proof -
  from assms(5)[unfolded heap_union_def weak_heap_union_def] have 1:
    "dom h2 \<inter> dom h4 = {} \<and> h5=h2++h4 \<and> (dom h2 \<inter> ran h4) \<union> (dom h4 \<inter> ran h2) \<subseteq> ran s"
    by (metis option.distinct(1) option.sel)
  from graph_dom_ran[OF assms(1)] graph_dom_ran[OF assms(3)] have "dom h1 = f`dom h2"
    "ran h1 = f`ran h2" "dom h3 = f`dom h4" "ran h3 = f`ran h4" by auto
  with 1 assms(2,4) have "dom h1 \<inter> dom h3 = {} \<and> (dom h1 \<inter> ran h3) \<union> (dom h3 \<inter> ran h1) \<subseteq> ran s'"
  apply auto
  apply (metis UNIV_I bij_betw_inv_into_left disjoint_iff domI)
  apply (metis Int_iff UNIV_I bij_betw_inv_into_left domI rev_image_eqI subset_iff)
  by (metis Int_iff UNIV_I bij_betw_inv_into_left domI imageI subset_eq)
  then have "h1 \<uplus>\<^sup>s' h3 \<noteq> None" by (auto simp: heap_union_def weak_heap_union_def)
  then obtain h6 where "h1 \<uplus>\<^sup>s' h3 = Some h6" by auto
  moreover from heap_union_graph[OF this] heap_union_graph[OF assms(5)] assms(1,3)
    have "Map.graph h6 = (\<lambda>(l,r). (f l, f r))`Map.graph h5" by auto
  ultimately show ?thesis by simp
qed

lemma model_isoE: "m1 \<cong> m2 \<Longrightarrow> \<exists>f. bij_betw f (locs (heap m1) \<union> ran (stack m1)) (locs (heap m2) \<union> ran (stack m2)) \<and>
  bij_betw f (-(locs (heap m1) \<union> ran (stack m1))) (-(locs (heap m2) \<union> ran (stack m2))) \<and>
  (\<forall>x. stack m2 x = map_option f (stack m1 x)) \<and>
  (Map.graph (heap m2) = {(f l, f l') | l l'. heap m1 l = Some l'})"
  by transfer' auto

lemma model_isoE': "m1 \<cong> m2 \<Longrightarrow> \<exists>f. iso_fun f m1 m2"
proof -
  assume "m1 \<cong> m2"
  from model_isoE[OF this] obtain f where f:
    "bij_betw f (locs (heap m1) \<union> ran (stack m1)) (locs (heap m2) \<union> ran (stack m2)) \<and>
    bij_betw f (-(locs (heap m1) \<union> ran (stack m1))) (-(locs (heap m2) \<union> ran (stack m2))) \<and>
    (\<forall>x. stack m2 x = map_option f (stack m1 x)) \<and>
    (Map.graph (heap m2) = {(f l, f l') | l l'. heap m1 l = Some l'})" by blast
  then have bij_f: "bij f" by auto (metis (no_types, lifting) Compl_disjoint bij_betw_combine
    boolean_algebra.de_Morgan_disj boolean_algebra.disj_cancel_right)
  with f show ?thesis by blast
qed

lemma iso_sym: "m1 \<cong> m2 \<Longrightarrow> m2 \<cong> m1"
proof -
  assume "m1 \<cong> m2"
  from model_isoE'[OF this] obtain f where f: "iso_fun f m1 m2" by blast
  define g where g: "g = inv f"
  have "bij_betw g (locs (heap m2) \<union> ran (stack m2)) (locs (heap m1) \<union> ran (stack m1))"
    unfolding g using f by auto (metis (no_types, lifting) bij_betw_def boolean_algebra.disj_cancel_right
      image_f_inv_f inj_imp_surj_inv inj_on_Un inv_inv_eq surj_imp_inj_inv)
  moreover have "bij_betw g (-(locs (heap m2) \<union> ran (stack m2))) (-(locs (heap m1) \<union> ran (stack m1)))"
    unfolding g using f by auto (metis (no_types, opaque_lifting) bij_betw_def bij_betw_inv_into_subset g top_greatest)
  moreover have "\<forall>x. stack m1 x = map_option g (stack m2 x)" unfolding g using f
    by (smt (verit, ccfv_threshold) bij_betw_imp_inj_on inj_imp_surj_inv inv_inv_eq
      map_option_cong option.map_id option.simps(9) surj_f_inv_f)
  moreover {
    from f have "Map.graph (heap m2) = (\<lambda>(l,l'). (f l, f l')) ` Map.graph (heap m1)"
      unfolding Map.graph_def image_def by auto
    moreover have "heap m2 l = Some l' \<longleftrightarrow> (l,l') \<in> Map.graph (heap m2)" for l l'
      by (auto intro: Map.in_graphI Map.in_graphD)
    ultimately have "Map.graph (heap m1) = {(g l, g l') | l l'. heap m2 l = Some l'}"
    unfolding g using f apply auto using bij_inv_eq_iff in_graphD mem_Collect_eq apply fastforce
      by (metis bij_inv_eq_iff)
  }
  ultimately show ?thesis apply transfer' by auto
qed

lemma iso_stack_dom: "m1 \<cong> m2 \<Longrightarrow> dom (stack m1) = dom (stack m2)"
proof -
  assume assm: "m1 \<cong> m2"
  from model_isoE[OF this] show ?thesis by auto
qed

lemma iso_heap: "m1 \<cong> m2 \<Longrightarrow> card (dom (heap m1)) = card (dom (heap m2))
  \<and> card (ran (heap m1)) = card (ran (heap m2))"
proof -
  assume assm: "m1 \<cong> m2"
  from model_isoE'[OF this] obtain f where f: "iso_fun f m1 m2" by blast
  then have m_graph: "Map.graph (heap m2) = (\<lambda>(l,r). (f l, f r)) ` Map.graph (heap m1)"
    unfolding Map.graph_def by auto
  then have "fst ` Map.graph (heap m2) = f ` (fst ` Map.graph (heap m1))" by force
  from this[unfolded fst_graph_eq_dom] have "card (dom (heap m1)) = card (dom (heap m2))"
    by (smt (verit, del_insts) UnI1 bij_betw_iff_bijections card_image f inj_on_def locs_def)
  moreover {
    from m_graph have "snd ` Map.graph (heap m2) = f ` (snd ` Map.graph (heap m1))" by force
    moreover have "inj_on f (ran (heap m1))" using f apply auto
      using bij_betw_imp_inj_on inj_on_def locs_def by fastforce
    ultimately have "card (ran (heap m1)) = card (ran (heap m2))"
      unfolding snd_graph_ran using card_image by metis
   }
  ultimately show ?thesis by simp
qed

lemma iso_heap_emp: "m1 \<cong> m2 \<Longrightarrow> (heap m1 = Map.empty) \<longleftrightarrow> (heap m2 = Map.empty)"
proof -
  assume "m1 \<cong> m2"
  from iso_heap[OF this] have "card (dom (heap m1)) = card (dom (heap m2))" by simp
  then have "card (dom (heap m1)) = 0 \<longleftrightarrow> card (dom (heap m2)) = 0" by simp
  moreover {
    fix x :: heap
    assume "finite (dom x)"
    then have "card (dom x) = 0 \<longleftrightarrow> x = Map.empty" by auto
    }
  moreover have "finite (dom (heap x))" for x by transfer auto
  ultimately show ?thesis by simp
qed

lemma list_segment_iso:
  "\<lbrakk>list_segment n h1 l1 l2; iso_fun' f (s,h1) (s',h2)\<rbrakk> \<Longrightarrow> list_segment n h2 (f l1) (f l2)"
proof (induction n h1 l1 l2 arbitrary: h2 rule: list_segment.induct)
  case (1 uu uv uw)
  then show ?case by auto
next
  case (2 h1 l1 l2)
  then have h1: "h1 = [l1\<mapsto>l2]" by auto
  from 2(2) have "Map.graph h2 = (\<lambda>(l,r). (f l,f r))`Map.graph h1" by simp
  from graph_dom_ran[OF this] have "dom h2 = f`dom h1" "ran h2 = f`ran h1" by simp_all
  with h1 have "h2 = [f l1 \<mapsto> f l2]" apply auto
    by (metis dom_eq_singleton_conv insertCI ran_map_upd singleton_iff)
  then show ?case by auto
next
  case (3 n h1 l1 l2)
  then obtain h' l1' where h': "h1=h'++[l1\<mapsto>l1']" "list_segment (Suc n) h' l1' l2" "l1 \<notin> dom h'" by auto
  define h'' where h'': "h'' = h2(f l1 := None)"
  with h'(3) have doms: "dom h'' \<inter> dom [f l1 \<mapsto> f l1'] = {}" "dom h' \<inter> dom [l1 \<mapsto>l1'] = {}" by auto
  from h'(1) have "h1 l1 = Some l1'" by simp
  with 3(3) have "h2 (f l1) = Some ( f l1')"
    by (auto simp: Map.graph_def)
  with h'' have h2: "h2=h''++[f l1 \<mapsto> f l1']" by auto
  from 3(3)[simplified, unfolded this h'(1)] have "Map.graph h'' \<union> {(f l1,f l1')} = (\<lambda>(l,r). (f l,f r))`(Map.graph h' \<union> {(l1,l1')})"
    unfolding graph_map_add[OF doms(1)] graph_map_add[OF doms(2)] by auto
  with doms have h'_h''_graph: "Map.graph h'' = (\<lambda>(l,r). (f l,f r))`Map.graph h'"
    apply auto apply (metis in_graphD insert_iff option.distinct(1))
    by (metis (mono_tags, lifting) UNIV_I 3(3)[simplified, unfolded h2 h'(1)]
      bij_betw_inv_into_left domI domIff fst_eqD in_graphD insert_iff pair_imageI)
  from 3(3) have "ran s' = f`ran s" by (auto simp: ran_def)
  with 3(3) have s_bij: "bij_betw f (ran s) (ran s')" by (auto simp: bij_betw_def inj_on_def)
  with 3(3) have h_bij: "bij_betw f (locs h1) (locs h2)" apply auto
    by (simp add: bij_betw_def graph_dom_ran image_Un inj_on_Un locs_def)
  from h'(1,3) h'' h2 have "locs h' \<union> {l1,l1'} = locs h1" "locs h'' \<union> {f l1,f l1'} = locs h2"
    apply (auto simp: locs_def)
    apply (metis \<open>h2 (f l1) = Some (f l1')\<close> ranI)
    apply (metis UnI2 doms(1) h2 inf_commute map_add_comm ran_map_add)
    by (metis fun_upd_idem_iff insert_iff ran_map_upd)
  with h_bij have union_bij: "bij_betw f (locs h' \<union> {l1,l1'}) (locs h'' \<union> {f l1, f l1'})" by simp
  with 3(3) graph_dom_ran[OF h'_h''_graph] have "bij_betw f (dom h') (dom h'')" "bij_betw f (ran h') (ran h'')"
    by (auto simp: bij_betw_def inj_on_def)
  then have "bij_betw f (locs h') (locs h'')" apply (auto simp: locs_def)
    by (metis union_bij bij_betw_def image_Un inj_on_Un locs_def)
  with s_bij have "bij_betw f (locs h' \<union> ran s) (locs h'' \<union> ran s')" apply (auto simp: bij_betw_def)
    by (metis 3(3)[simplified, unfolded h2 h'(1)] bij_is_inj injD inj_onI)
  moreover with 3(3)[simplified, unfolded h2 h'(1)] have "bij_betw f (-(locs h' \<union> ran s)) (-(locs h'' \<union> ran s'))"
    by auto (metis bij_betw_def bij_image_Compl_eq boolean_algebra.de_Morgan_disj boolean_algebra.disj_one_right inj_on_Un)
  ultimately have "bij_betw f (locs h' \<union> ran s) (locs h'' \<union> ran s') \<and>
    bij_betw f (-(locs h' \<union> ran s)) (-(locs h'' \<union> ran s')) \<and>
    bij f \<and> (\<forall>x. s' x = map_option f (s x)) \<and> (Map.graph h'' = (\<lambda>(l,r). (f l, f r))`Map.graph h')"
    using 3(3) h'_h''_graph by auto
  then have "iso_fun' f (s,h') (s',h'')" by simp
  from doms 3(1)[OF h'(2) this] have "list_segment (Suc (Suc n)) h2 (f l1) (f l2)"
    by (auto simp: h2)
  then show ?case .
qed

lemma iso_split: "\<lbrakk>m1\<cong>m2; heap m1=h; stack m1 = s; stack m2 = s'; heap m2=h'; h1 \<uplus>\<^sup>s h2=Some h\<rbrakk> \<Longrightarrow>
  \<exists>h1' h2'. heap_union h1' s' h2'=Some h' \<and> Abs_model (s,h1) \<cong> Abs_model (s',h1') \<and> Abs_model (s,h2) \<cong> Abs_model (s',h2')"
proof -
  assume assms: "m1\<cong>m2" "heap m1=h" "stack m1 = s" "stack m2 = s'" "heap m2=h'" "h1 \<uplus>\<^sup>s h2=Some h"
  from model_isoE'[OF this(1)] assms obtain f where f:
    "bij_betw f (locs h \<union> ran s) (locs h' \<union> ran s') \<and>  bij_betw f (-(locs h \<union> ran s)) (-(locs h' \<union> ran s')) \<and>
    bij f \<and> (\<forall>x. s' x = map_option f (s x)) \<and>
    (Map.graph h' = {(f l, f l') | l l'. h l = Some l'})" by blast
  define h1' h2' where h12': "h1' = h' |` (f ` dom h1)" "h2' = h' |` (f ` dom h2)"
  from f have m_graph: "Map.graph h' = (\<lambda>(l,r). (f l, f r)) ` Map.graph h"
    unfolding Map.graph_def by auto
  then have "fst ` Map.graph h' = f ` (fst ` Map.graph h)" by force
  then have "dom h' = f`dom h" using assms by (simp add: fst_graph_eq_dom)
  with assms have "dom h' = f`(dom h1 \<union> dom h2)"
    apply (auto simp: heap_union_def weak_heap_union_def)
    apply (metis domI dom_map_add imageI not_Some_eq option.inject sup.commute weak_heap_union_def)
    apply (metis UnCI domI dom_map_add imageI option.distinct(1) option.inject weak_heap_union_def)
    by (metis Un_iff domI dom_map_add option.discI option.inject rev_image_eqI weak_heap_union_def)
  then have dom_h': "dom h' = (f`dom h1) \<union> (f`dom h2)" by auto
  from assms f have inter_emp: "f`dom h1 \<inter> f`dom h2 = {}" apply (auto simp: heap_union_def weak_heap_union_def)
    by (smt (verit, ccfv_SIG) ComplD Compl_Un Compl_disjoint Compl_partition2 IntI UNIV_I bij_betw_inv_into_left
      boolean_algebra_class.boolean_algebra.double_compl domI not_None_eq weak_heap_union_def)
  then have inter_emp': "dom (h' |` (f ` dom h1)) \<inter> dom (h' |` (f ` dom h2)) = {}" by auto
  from dom_h' have "Map.graph (h' |` (f`dom h1)) \<union> Map.graph (h' |` (f`dom h2)) = Map.graph h'"
    apply (auto intro: graph_restrictD in_graphI)
    by (metis UnE fst_conv graph_domD in_graphD in_graphI restrict_in)
  with graph_map_add[OF inter_emp'] have "Map.graph (h'|`(f`dom h1)++h'|`(f`dom h2)) = Map.graph h'"
    by simp
  moreover have "Map.graph x = Map.graph y \<Longrightarrow> x = y" for x y :: heap
    by (metis (no_types, opaque_lifting) ext in_graphD in_graphI option.collapse)
  ultimately have h'_plus: "(h'|`(f`dom h1)++h'|`(f`dom h2)) = h'" by simp
  with h12' inter_emp' have h_w_union: "Some h' = h1' ++ h2'" by (auto simp: weak_heap_union_def)
  from f have "ran s' = {y | x y. map_option f (s x) = Some y}" by (auto simp: ran_def)
  then have ran_s': "ran s' = f`(ran s)" by (auto simp: ran_def)
  from assms(6) have union: "(dom h1 \<inter> ran h2) \<union> (dom h2 \<inter> ran h1) \<subseteq> ran s" apply (auto simp: heap_union_def)
    by (metis IntI domIff option.distinct(1) subset_iff)+
  from h12' dom_h' have dom': "dom h1'= (f`dom h1)" "dom h2' = (f`dom h2)" by auto
  from m_graph have "h l = Some l' \<longleftrightarrow> h' (f l) = Some (f l')" for l l'
    by (auto simp: Map.graph_def) (smt (verit, del_insts) bij_betw_imp_inj_on f graph_def
    inj_imp_surj_inv inv_inv_eq mem_Collect_eq prod.simps(1) surj_f_inv_f)
  moreover from m_graph have "h l = None \<longleftrightarrow> h' (f l) = None" for l apply (auto simp: Map.graph_def)
    apply (smt (verit) \<open>fst ` Map.graph h' = f ` fst ` Map.graph h\<close> bij_betw_imp_inj_on domIff f fst_graph_eq_dom imageE inj_imp_surj_inv inv_inv_eq surj_f_inv_f)
    by (metis \<open>dom h' = f ` dom h\<close> domIff rev_image_eqI)
  ultimately have "h' (f l) = map_option f (h l)" for l
    by (metis (mono_tags, opaque_lifting) None_eq_map_option_iff option.exhaust_sel option.simps(9))
  then have "h' (f l) = map_option f (if l \<in> dom h1 then h1 l else h2 l)" for l
    using assms(6) apply (auto simp: heap_union_def weak_heap_union_def)
    apply (smt (verit, del_insts) map_add_comm map_add_find_right option.distinct(1) option.inject weak_heap_union_def)
    by (smt (verit, ccfv_SIG) map_add_SomeD map_add_find_right option.collapse option.inject option.simps(3) weak_heap_union_def)
  with h12' have maps: "h1' (f l) = map_option f (h1 l)" "h2' (f l) = map_option f (h2 l)" for l apply auto
    apply (metis (full_types, opaque_lifting) None_eq_map_option_iff dom' disjoint_iff domIff imageI inter_emp restrict_in)
    by (metis (full_types) disjoint_iff domIff imageI inter_emp option.map_disc_iff restrict_in restrict_out)
  then have "ran h1' = f`ran h1" "ran h2' = f`ran h2" apply (auto simp: ran_map_option[symmetric])
    by (smt (verit, ccfv_SIG) bij_inv_eq_iff f mem_Collect_eq ran_def)+
  with dom' ran_s' union have "(dom h1' \<inter> ran h2') \<union> (dom h2' \<inter> ran h1') \<subseteq> ran s'"
    by auto (smt (verit, ccfv_SIG) Int_iff bij_betw_imp_inj_on domIff f image_eqI inj_imp_surj_inv
    inv_inv_eq option.distinct(1) subset_iff surj_f_inv_f)+
  with h_w_union have heap_union: "Some h' = heap_union h1' s' h2'" by (auto simp: heap_union_def)
  note abs = heap_union_model[OF assms(2,3) assms(6)[symmetric]] heap_union_model[OF assms(5,4) heap_union]
    heap_union_model[OF assms(2,3) assms(6)[symmetric, THEN heap_union_sym_impl]]
    heap_union_model[OF assms(5,4) heap_union[THEN heap_union_sym_impl]]
  {
    from f have "bij_betw f (locs h1 \<union> ran s) (locs h1' \<union> ran s')" apply auto
      by (metis (no_types, lifting) Un_commute \<open>ran h1' = f ` ran h1\<close> bij_betw_def bij_betw_imp_inj_on boolean_algebra.disj_cancel_left dom'(1) image_Un inj_on_Un locs_def ran_s')
    moreover from this f have "bij_betw f (- locs h1 \<inter> - ran s) (- locs h1' \<inter> - ran s')"
      by auto (metis (no_types, lifting) bij_betw_def bij_image_Compl_eq boolean_algebra.de_Morgan_disj boolean_algebra.disj_one_right inj_on_Un)
    moreover from f have "\<forall>x. s' x = map_option f (s x)" by simp
    moreover from maps have "Map.graph h1' = {(f l, f l') |l l'. h1 l = Some l'}"
      by (auto simp: in_graphI) (metis dom'(1) fst_conv graph_domD image_iff in_graphD map_option_eq_Some)
    ultimately have "Abs_model (s, h1) \<cong> Abs_model (s', h1')"
      by (auto simp: model_iso.rep_eq Abs_model_inverse[OF abs(1)] Abs_model_inverse[OF abs(2)])
  }
  moreover {
    from f have "bij_betw f (locs h2 \<union> ran s) (locs h2' \<union> ran s')" apply auto
      by (metis (no_types, lifting) Un_commute \<open>ran h2' = f ` ran h2\<close> bij_betw_def bij_betw_imp_inj_on boolean_algebra.disj_cancel_left dom'(2) image_Un inj_on_Un locs_def ran_s')
    moreover from this f have "bij_betw f (- locs h2 \<inter> - ran s) (- locs h2' \<inter> - ran s')"
      by auto (metis (no_types, lifting) bij_betw_def bij_image_Compl_eq boolean_algebra.de_Morgan_disj boolean_algebra.disj_one_right inj_on_Un)
    moreover from f have "\<forall>x. s' x = map_option f (s x)" by simp
    moreover from maps have "Map.graph h2' = {(f l, f l') |l l'. h2 l = Some l'}" apply (auto simp: in_graphI)
      by (smt (verit) Pair_inject dom'(2) fst_conv graph_def graph_domD image_iff map_option_eq_Some mem_Collect_eq)
    ultimately have "Abs_model (s, h2) \<cong> Abs_model (s', h2')"
      by (auto simp: model_iso.rep_eq Abs_model_inverse[OF abs(3)] Abs_model_inverse[OF abs(4)])
  }
  ultimately show ?thesis using heap_union by auto
qed

theorem iso_equivalent: "m1 \<cong> m2 \<Longrightarrow> m1 \<Turnstile> P \<Longrightarrow> m2 \<Turnstile> P"
proof (induction P arbitrary: m1 m2)
  case Emp
  with iso_heap_emp[OF this(1)] this(2) show ?case by transfer' auto
next
  case (PointsTo x y)
  then obtain x' y' where h1: "stack m1 x = Some x' \<and> stack m1 y = Some y' \<and> heap m1 = [x'\<mapsto>y']"
    by transfer' auto
  from model_isoE'[OF PointsTo(1)] obtain f where f: "iso_fun f m1 m2" by blast
  with h1 have "Map.graph (heap m2) = {(f x', f y')}" by auto
  then have "heap m2 = [f x' \<mapsto> f y']" by (metis (full_types) dom_eq_singleton_conv fst_graph_eq_dom
    fun_upd_idem graph_empty graph_map_upd in_graphD insertI1)
  moreover have "stack m2 x = Some (f x') \<and> stack m2 y = Some (f y')" using f apply auto
    using h1 by blast+
  ultimately show ?case by transfer auto
next
  case (LS x)
  obtain y z where x: "x=(y,z)" by force
  obtain s h s' h' where m1: "heap m1 = h" "stack m1 = s" and m2: "heap m2 = h'" "stack m2 = s'"
    by auto
  then have m12: "Rep_model m1 = (s,h)" "Rep_model m2 = (s',h')" by (transfer, auto)+
  with x LS(2) have "satisfies (s,h) (LS (y,z))" by transfer' auto
  then obtain ly lz where ls_sat: "s y = Some ly" "s z = Some lz"
    "((dom h = {} \<and> ly=lz) \<or> (\<exists>n. list_segment n h ly lz))" (is "?emp_ls \<or> ?seg") by auto
  from model_isoE'[OF LS(1)] obtain f where f: "iso_fun f m1 m2" by blast
  with ls_sat m1 m2 have s'_y_z: "s' y = Some (f ly)" "s' z = Some (f lz)" by auto
  {
    from f iso_heap_emp[OF LS.prems(1)] m1 m2 have "?emp_ls \<Longrightarrow> dom h' = {} \<and> f ly = f lz" by auto
    with s'_y_z have "?emp_ls \<Longrightarrow> satisfies (s',h') (LS (y,z))" by auto
    with m12(2) x have "?emp_ls \<Longrightarrow> m2 \<Turnstile> LS x" by (auto simp: satisfies_model.rep_eq)
  }
  moreover {
    assume ?seg
    then obtain n where n: "list_segment n h ly lz" by blast
    from f m1 m2 have "iso_fun' f (s,h) (s',h')" by (auto simp: Map.graph_def)
    from list_segment_iso[OF n this] have "(dom h' = {} \<and> f ly=f lz) \<or> (\<exists>n. list_segment n h' (f ly) (f lz))"
      by auto
    with s'_y_z have "satisfies (s',h') (LS (y,z))" by auto
    with m12(2) x have "m2 \<Turnstile> LS x" by (auto simp: satisfies_model.rep_eq)
  }
  ultimately show ?case using ls_sat(3) by auto
next
  case (Eq x1 x2)
  with iso_heap_emp[OF this(1)] show ?case by transfer auto
next
  case (NEq x1 x2)
  with iso_heap_emp[OF this(1)] model_isoE'[OF this(1)] show ?case
    by transfer (auto, metis bij_inv_eq_iff)
next
  case (SepConj P1 P2)
  obtain s h s' h' where m1: "heap m1 = h" "stack m1 = s" and m2: "heap m2 = h'" "stack m2 = s'"
    by auto
  with SepConj(4) obtain h1 h2 where h12: "h1 \<uplus>\<^sup>s h2 = Some h" "Abs_model (s,h1) \<Turnstile> P1"
    "Abs_model (s,h2) \<Turnstile> P2" apply transfer apply auto by (smt (verit, ccfv_threshold) Abs_model_inverse
      UnI1 UnI2 domD dom_map_add finite_Un heap_union_def mem_Collect_eq option.distinct(1) option.inject
      satisfies_model.rep_eq weak_heap_union_def)
  from model_isoE'[OF SepConj(3)] obtain f where f: "iso_fun f m1 m2" by blast
  from iso_split[OF SepConj(3) m1 m2(2,1) h12(1)] obtain h1' h2' where h12': "Some h'= h1' \<uplus>\<^sup>s' h2'"
     "Abs_model (s, h1) \<cong> Abs_model (s', h1')" "Abs_model (s, h2) \<cong> Abs_model (s', h2')" by force
  note abs = heap_union_model[OF m2 h12'(1)] heap_union_model[OF m2 h12'(1)[THEN heap_union_sym_impl]]
  from m2 have "Rep_model m2 = (s',h')" by transfer auto
  with SepConj(1)[OF h12'(2) h12(2)] SepConj(2)[OF h12'(3) h12(3)] h12'(1) have "m2 \<Turnstile> P1 \<^emph> P2"
    by (auto simp: satisfies_model.rep_eq Abs_model_inverse[OF abs(1)] Abs_model_inverse[OF abs(2)])
  then show ?case .
next
  case (Septraction P1 P2)
  obtain s h s' h' where m1: "heap m1 = h" "stack m1 = s" and m2: "heap m2 = h'" "stack m2 = s'"
    by auto
  then have m12: "Rep_model m1 = (s,h)" "Rep_model m2 = (s',h')" by (transfer, auto)+
  with Septraction(4) have "satisfies (s,h) (P1 -\<otimes> P2)" by transfer auto
  \<comment> \<open>Obtain the h0\<close>
  with m12 obtain h0 h1 l where h12: "h \<uplus>\<^sup>s h0 = Some h1" "satisfies (s,h0) P1" "satisfies (s,h1) P2"
    "finite (dom h0)" "s Nil = Some l" "l \<notin> dom h0"
    by auto
  with m12 have "(s,h0) \<in> {(s, h) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s var.Nil = Some l \<and> l \<notin> dom h)}"
    by transfer auto
  note abs = heap_union_model'[OF m1 h12(5) h12(1)[symmetric] h12(6,4)] this
  from model_isoE'[OF Septraction(3)] obtain f where f: "iso_fun f m1 m2" by blast
  then have f_bij: "bij f" by simp
  from f have h_h'_graph: "Map.graph h' = (\<lambda>(l,r). (f l, f r))`Map.graph h" by (auto simp: Map.graph_def m1 m2)
  from f have s_s'_ran: "ran s' = f`ran s" by (auto simp: ran_def m1 m2)
  from h12(5) f m1 m2 have s'_nil: "s' Nil = Some (f l)" by simp
  \<comment> \<open>Define the isomorphic heap h0' to h0.\<close>
  define h0' where "h0' \<equiv> \<lambda>l. map_option f (h0 (inv f l))"
  with f_bij have h0'_graph: "Map.graph h0' = {(f l, f l') | l l'. h0 l = Some l'}"
    apply (auto simp: Map.graph_def bij_betw_inv_into_left)
    by (metis bij_inv_eq_iff)
  with h0'_def have h0'_dom_ran: "dom h0' = f`dom h0" "ran h0' = f`ran h0" apply (auto simp: Map.graph_def ran_def)
    apply fastforce+ by (metis bij_inv_eq_iff f_bij)
  with h12(4,5,6) have h0'_heap: "finite (dom h0')" "f l \<notin> dom h0'"
    by auto (metis bij_inv_eq_iff f_bij option.simps(3))
  with m2 s'_nil have abs_h0': "(s',h0') \<in> {(s, h) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s var.Nil = Some l \<and> l \<notin> dom h)}"
    by transfer auto
  from h0'_dom_ran f_bij have h0_h0'_bij: "bij_betw f (locs h0) (locs h0')"
    by (auto simp: locs_def bij_betw_def inj_on_def)
  with iso_fun_s_bij[OF f] m1 m2 have "bij_betw f (locs h0 \<union> ran s) (locs h0' \<union> ran s')"
    by auto (metis h0_h0'_bij bij_betw_def boolean_algebra.disj_one_left f_bij image_Un inj_on_Un m2(2))
  moreover with f_bij have "bij_betw f (-(locs h0 \<union> ran s)) (-(locs h0' \<union> ran s'))"
    by (metis Compl_partition2 bij_betw_def bij_image_Compl_eq inj_on_Un)
  ultimately have "bij_betw f (locs h0 \<union> ran s) (locs h0' \<union> ran s') \<and>
    bij_betw f (- locs h0 \<inter> - ran s) (- locs h0' \<inter> - ran s') \<and>
    (\<forall>x. s' x = map_option f (s x)) \<and> Map.graph h0' = {(f l, f l') |l l'. h0 l = Some l'}"
    using f[unfolded m1 m2] h0'_graph by auto
  then have h0_iso_h0': "Abs_model (s,h0) \<cong> Abs_model (s',h0')"
    by (auto simp: model_iso.rep_eq Abs_model_inverse[OF abs_h0'] Abs_model_inverse[OF abs(2)])
  from h0'_graph have "Map.graph h0' = (\<lambda>(l,r). (f l, f r))`Map.graph h0" by (auto simp: Map.graph_def)
  from iso_heap_union[OF this f_bij h_h'_graph s_s'_ran h12(1)[symmetric, THEN heap_union_sym_impl, symmetric]]
  \<comment> \<open>Obtain the isomorphic heap h3 for h1\<close>
  obtain h3 where h3: "h0' \<uplus>\<^sup>s' h' = Some h3" "Map.graph h3 = (\<lambda>(l, r). (f l, f r)) ` Map.graph h1"
    by blast
  with h0'_heap m12 s'_nil have h3_heap: "finite (dom h3) \<and> f l \<notin> dom h3" apply transfer apply auto
    apply (metis finite_UnI finite_graph_iff_finite_dom heap_union_graph)
    by (metis UnE domIff fst_graph_eq_dom heap_union_graph image_Un option.distinct(1))
  with m2 s'_nil have abs_h3: "(s',h3) \<in> {(s, h) |s h. finite (dom s) \<and> finite (dom h) \<and> (\<exists>l. s var.Nil = Some l \<and> l \<notin> dom h)}"
    by transfer auto
  from graph_dom_ran[OF h3(2)] f_bij have "bij_betw f (locs h1) (locs h3)"
    by (auto simp: locs_def bij_betw_def inj_on_def)
  with iso_fun_s_bij[OF f] m1 m2 have "bij_betw f (locs h1 \<union> ran s) (locs h3 \<union> ran s')"
    by auto (metis bij_betw_def boolean_algebra.disj_one_left f_bij image_Un inj_on_Un m2(2))
  moreover with f_bij have "bij_betw f (-(locs h1 \<union> ran s)) (-(locs h3 \<union> ran s'))"
    by (metis Compl_partition2 bij_betw_def bij_image_Compl_eq inj_on_Un)
  ultimately have "bij_betw f (locs h1 \<union> ran s) (locs h3 \<union> ran s') \<and>
    bij_betw f (- locs h1 \<inter> - ran s) (- locs h3 \<inter> - ran s') \<and>
    (\<forall>x. s' x = map_option f (s x)) \<and> Map.graph h3 = {(f l, f l') |l l'. h1 l = Some l'}"
    using f[unfolded m1 m2] h3(2) by (auto simp: Map.graph_def)
  then have h1_iso_h3: "Abs_model (s,h1) \<cong> Abs_model (s',h3)"
    by (auto simp: model_iso.rep_eq Abs_model_inverse[OF abs_h3] Abs_model_inverse[OF abs(1)])
  \<comment> \<open>Apply the induction hypothesis.\<close>
  from h12(2,3) have "Abs_model (s,h0) \<Turnstile> P1" "Abs_model (s,h1) \<Turnstile> P2"
    by (auto simp: satisfies_model.rep_eq Abs_model_inverse[OF abs(1)] Abs_model_inverse[OF abs(2)])
  from Septraction(1)[OF h0_iso_h0' this(1)] Septraction(2)[OF h1_iso_h3 this(2)] s'_nil h0'_heap h3(1) have
    "finite (dom h0') \<and> s' Nil = Some (f l) \<and> f l \<notin> dom h0' \<and> satisfies (s', h0') P1 \<and> h' \<uplus>\<^sup>s' h0' = Some h3 \<and> satisfies (s', h3) P2"
    by (auto simp: satisfies_model.rep_eq Abs_model_inverse[OF abs_h3] m12 Abs_model_inverse[OF abs_h0']
      heap_union_sym)
    then show ?case by (auto simp: satisfies_model.rep_eq Abs_model_inverse[OF abs_h3] m12 Abs_model_inverse[OF abs_h0'])
next
  case (Conj P1 P2)
  then have "m1 \<Turnstile> P1" "m1 \<Turnstile> P2" by (transfer',auto)+
  from Conj(1)[OF Conj(3) this(1)] Conj(2)[OF Conj(3) this(2)] show ?case
    by transfer auto
next
  case (Disj P1 P2)
  then have "m1 \<Turnstile> P1 \<or> m1 \<Turnstile> P2" by transfer' auto
  with Disj(1)[OF Disj(3)] Disj(2)[OF Disj(3)] show ?case
    by transfer' auto
next
  case (Neg P)
  then have "\<not> (m1 \<Turnstile> P)" by transfer auto
  with Neg(1)[OF iso_sym[OF Neg(2)]] show ?case by transfer' auto
qed
end


subsection "Examples"
theory SepLog_Examples
imports SepLog_Hoare
begin

subsubsection \<open>nice example\<close>

lemmas strongAssign = Assign''''[OF _ strengthen_post, OF _ Frame_R, OF _ Assign''']

lemma myrule: assumes "case s of (s, n) \<Rightarrow> ($ (2 * x) \<and>* ''x'' \<hookrightarrow> int x) (s, n) \<and> lmaps_to_axpr' (Less (N 0) (V ''x'')) True s"
    and "symevalb ($ (2 * x) ** ''x'' \<hookrightarrow> int x) (Less (N 0) (V ''x'')) v"
    shows "(\<up>(v=True) ** $ (2 * x) ** ''x'' \<hookrightarrow> int x) s"
      using assms unfolding symevalb_def lmaps_to_axpr'_def by auto

fun sum :: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'')
  DO (
      ''x'' ::= Plus (V ''x'') (N (- 1)))"

lemma E4_R: "\<turnstile>\<^sub>3 {\<up>(v>0) ** $(2*v) ** pointsto ''x'' (int v) }
            ''x'' ::= Plus (V ''x'') (N (- 1))
           {\<up>(v>0) ** $(2*v-1) ** pointsto ''x'' (int v-1) }"
      apply(rule pureI)
  apply(rule strongAssign)
    apply(rule symeval | frame_inference)+
     by (simp add:  sep_reorder_dollar )

lemma prod_0:
  shows "(\<lambda>(s::char list \<Rightarrow> int option, c::nat). s = Map.empty \<and> c = 0) h \<Longrightarrow> h = 0" by (auto simp: zero_prod_def zero_fun_def)

lemma example2: "\<turnstile>\<^sub>3 { (pointsto ''x'' n) ** (pointsto ''y'' n) ** $1 } ''x'' ::= Plus (V ''x'') (N (- 1)) { (pointsto ''x'' (n-1)) ** (pointsto ''y'' n) }"
  apply(rule conseq)
  apply(rule Frame[where F="(pointsto ''y'' n)" and P="lmaps_to_expr_x ''x'' ( Plus (V ''x'') (N (- 1))) (n-1) ** $1"])
    apply (rule Assign)
   apply (simp add: sep_conj_assoc)  apply (rule sep_conj_impl)
     apply auto[1]
    subgoal for s h unfolding pointsto_def apply auto
      by (meson option.distinct(1))
     apply (simp add: sep_conj_commute)
    apply simp apply (rule sep_conj_impl)
      apply auto[1]
     apply auto
      unfolding sep_conj_def
      using prod_0 by fastforce

end


theory nat_pow_pow
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun mult :: "Nat => Nat => Nat" where
"mult (Z) y = Z"
| "mult (S n) y = plus y (mult n y)"

fun pow :: "Nat => Nat => Nat" where
"pow x (Z) = S Z"
| "pow x (S m) = mult x (pow x m)"

(*hipster plus mult pow *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (pow x (mult y z)) = (pow (pow x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end