(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2019 Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open> Uniform spaces \<close>

theory UniformSpace_ZF imports Topology_ZF_2 Topology_ZF_4a
begin

text\<open> This theory defines uniform spaces and proves their basic properties. \<close>

subsection\<open> Definition and motivation \<close>

text\<open> Just like a topological space constitutes the minimal setting
  in which one can speak of continuous functions, the notion of uniform spaces
  (commonly attributed to André Weil) captures the minimal setting in which one can speak
  of uniformly continuous functions.
  In some sense this is a generalization of the notion of metric (or metrizable)
  spaces and topological groups. \<close>

text\<open> There are several definitions of uniform spaces.
  The fact that these definitions are equivalent is far from obvious
  (some people call such phenomenon cryptomorphism).
  We will use the definition of the uniform structure (or ''uniformity'')
  based on entourages. This was the original definition by Weil and it seems
  to be the most commonly used.
  A uniformity consists of entourages that are binary relations between points of space $X$
  that satisfy a certain collection of conditions, specified below. \<close>

definition
  IsUniformity ("_ {is a uniformity on} _" 90) where
    "\<Phi> {is a uniformity on} X \<equiv>(\<Phi> {is a filter on} (X\<times>X))
    \<and> (\<forall>U\<in>\<Phi>. id(X) \<subseteq> U \<and> (\<exists>V\<in>\<Phi>. V O V \<subseteq> U) \<and> converse(U) \<in> \<Phi>)"

text\<open> If $\Phi$ is a uniformity on $X$, then the every element $V$ of $\Phi$
  is a certain relation on $X$ (a subset of $X\times X$) and is called
  an ''entourage''. For an $x\in X$ we call $V\{ x\}$ a neighborhood of $x$.
  The first useful fact we will show is that neighborhoods are non-empty. \<close>

lemma neigh_not_empty:
  assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>" and "x\<in>X"
  shows "W``{x} \<noteq> 0" and "x \<in> W``{x}"
proof -
  from assms(1,2) have "id(X) \<subseteq> W"
    unfolding IsUniformity_def IsFilter_def by auto
  with \<open>x\<in>X\<close> show" x\<in>W``{x}" and "W``{x} \<noteq> 0" by auto
qed

text\<open>The filter part of the definition of uniformity for easier reference:\<close>

lemma unif_filter: assumes "\<Phi> {is a uniformity on} X"
  shows "\<Phi> {is a filter on} (X\<times>X)"
  using assms unfolding IsUniformity_def by simp

text\<open>The second part of the definition of uniformity for easy reference:\<close>

lemma entourage_props:
  assumes "\<Phi> {is a uniformity on} X" and "A\<in>\<Phi>"
  shows
    "A \<subseteq> X\<times>X"
    "id(X) \<subseteq> A"
    "\<exists>V\<in>\<Phi>. V O V \<subseteq> A"
    "converse(A) \<in> \<Phi>"
proof -
  from assms show "id(X) \<subseteq> A" "\<exists>V\<in>\<Phi>. V O V \<subseteq> A" "converse(A) \<in> \<Phi>"
    unfolding IsUniformity_def by auto
  from assms show "A \<subseteq> X\<times>X"
    using unif_filter unfolding IsFilter_def by blast
qed

text\<open>The definition of uniformity states (among other things) that for every member $U$
  of uniformity $\Phi$ there is another one, say $V$ such that $V\circ V\subseteq U$. Sometimes such $V$
  is said to be half the size of $U$. The next lemma states that $V$ can be taken to be symmetric. \<close>

lemma half_size_symm: assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>"
  shows "\<exists>V\<in>\<Phi>. V O V \<subseteq> W \<and> V=converse(V)"
proof -
  from assms obtain U where "U\<in>\<Phi>" and "U O U \<subseteq> W"
    unfolding IsUniformity_def by auto
  let ?V = "U \<inter> converse(U)"
  from assms(1) \<open>U\<in>\<Phi>\<close> have "?V \<in> \<Phi>" and "?V = converse(?V)"
    unfolding IsUniformity_def IsFilter_def by auto
  moreover from \<open>U O U \<subseteq> W\<close> have "?V O ?V \<subseteq> W" by auto
  ultimately show ?thesis by blast
qed

text\<open>Inside every member $W$ of the uniformity $\Phi$ we can find one that is symmetric and
  smaller than a third of size $W$. Compare with the Metamath's theorem with the same name.\<close>

lemma ustex3sym: assumes "\<Phi> {is a uniformity on} X" "A\<in>\<Phi>"
  shows "\<exists>B\<in>\<Phi>. B O (B O B) \<subseteq> A \<and> B=converse(B)"
proof -
  from assms obtain C where "C\<in>\<Phi>" and "C O C \<subseteq> A"
    unfolding IsUniformity_def by auto
  from assms(1) \<open>C\<in>\<Phi>\<close> obtain B where
    "B\<in>\<Phi>" "B O B \<subseteq> C" and "B=converse(B)"
    using half_size_symm by blast
  with \<open>C O C \<subseteq> A\<close> have "(B O B) O (B O B) \<subseteq> A" by blast
  with assms(1) \<open>B\<in>\<Phi>\<close> have "B O (B O B) \<subseteq> A"
    using entourage_props(1,2) by blast
  with \<open>B\<in>\<Phi>\<close> \<open>B=converse(B)\<close> show ?thesis by blast
qed

text\<open>If $\Phi$ is a uniformity on $X$ then every element of $\Phi$ is a subset of $X\times X$
  whose domain is $X$. \<close>

lemma uni_domain:
  assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>"
  shows "W \<subseteq> X\<times>X" and "domain(W) = X"
proof -
  from assms show "W \<subseteq> X\<times>X" unfolding IsUniformity_def IsFilter_def
    by blast
  show "domain(W) = X"
  proof
    from assms show "domain(W) \<subseteq> X" unfolding IsUniformity_def IsFilter_def
      by auto
    from assms show "X \<subseteq> domain(W)" unfolding IsUniformity_def by blast
  qed
qed

text\<open>If $\Phi$ is a uniformity on $X$ and $W\in \Phi$ the for every $x\in X$
  the image of the singleton $\{ x\}$ by $W$ is contained in $X$. Compare
  the Metamath's theorem with the same name. \<close>

lemma ustimasn:
  assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>" and "x\<in>X"
  shows "W``{x} \<subseteq> X"
  using assms uni_domain(1) by auto

text\<open> Uniformity \<open>\<Phi>\<close>  defines a natural topology on its space $X$ via the neighborhood system
  that assigns the collection $\{V(\{x\}):V\in \Phi\}$ to every point $x\in X$.
  In the next lemma we show that if we define a function
  this way the values of that function are what they should be. This is only a technical
  fact which is useful to shorten the remaining proofs, usually treated as obvious in standard
  mathematics. \<close>

lemma neigh_filt_fun:
  assumes "\<Phi> {is a uniformity on} X"
  defines "\<M> \<equiv> {\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>.x\<in>X}"
  shows "\<M>:X\<rightarrow>Pow(Pow(X))" and "\<forall>x\<in>X. \<M>`(x) = {V``{x}.V\<in>\<Phi>}"
proof -
  from assms have "\<forall>x\<in>X. {V``{x}.V\<in>\<Phi>} \<in> Pow(Pow(X))"
    using IsUniformity_def IsFilter_def image_subset by auto
  with assms show "\<M>:X\<rightarrow>Pow(Pow(X))" using ZF_fun_from_total by simp
  with assms show "\<forall>x\<in>X. \<M>`(x) = {V``{x}.V\<in>\<Phi>}" using ZF_fun_from_tot_val
    by simp
qed

text\<open> In the next lemma we show that the collection defined in lemma \<open>neigh_filt_fun\<close> is a filter on $X$.
   The proof is kind of long, but it just checks that all filter conditions hold.\<close>

lemma filter_from_uniformity:
  assumes "\<Phi> {is a uniformity on} X" and "x\<in>X"
  defines "\<M> \<equiv> {\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>.x\<in>X}"
  shows "\<M>`(x) {is a filter on} X"
proof -
  from assms have PhiFilter: "\<Phi> {is a filter on} (X\<times>X)" and
    "\<M>:X\<rightarrow>Pow(Pow(X))" and "\<M>`(x) = {V``{x}.V\<in>\<Phi>}"
    using IsUniformity_def neigh_filt_fun by auto
  have "0 \<notin> \<M>`(x)"
  proof -
    from assms \<open>x\<in>X\<close> have "0 \<notin> {V``{x}.V\<in>\<Phi>}" using neigh_not_empty by blast
    with \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close> show "0 \<notin> \<M>`(x)" by simp
  qed
  moreover have "X \<in> \<M>`(x)"
  proof -
    note \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close>
    moreover from assms have "X\<times>X \<in> \<Phi>" unfolding IsUniformity_def IsFilter_def
      by blast
    hence "(X\<times>X)``{x} \<in> {V``{x}.V\<in>\<Phi>}" by auto
    moreover from \<open>x\<in>X\<close> have "(X\<times>X)``{x} = X" by auto
    ultimately show "X \<in> \<M>`(x)" by simp
  qed
  moreover from \<open>\<M>:X\<rightarrow>Pow(Pow(X))\<close> \<open>x\<in>X\<close> have "\<M>`(x) \<subseteq> Pow(X)" using apply_funtype
    by blast
  moreover have LargerIn: "\<forall>B \<in> \<M>`(x). \<forall>C \<in> Pow(X). B\<subseteq>C \<longrightarrow> C \<in> \<M>`(x)"
  proof -
  { fix B assume "B \<in> \<M>`(x)"
    fix C assume "C \<in> Pow(X)" and "B\<subseteq>C"
    from \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close> \<open>B \<in> \<M>`(x)\<close> obtain U where
         "U\<in>\<Phi>" and "B = U``{x}" by auto
    let ?V = "U \<union> C\<times>C"
    from assms \<open>U\<in>\<Phi>\<close> \<open>C \<in> Pow(X)\<close> have "?V \<in> Pow(X\<times>X)" and "U\<subseteq>?V"
      using IsUniformity_def IsFilter_def by auto
    with \<open>U\<in>\<Phi>\<close> PhiFilter have "?V\<in>\<Phi>" using IsFilter_def by simp
    moreover from assms \<open>U\<in>\<Phi>\<close> \<open>x\<in>X\<close> \<open>B = U``{x}\<close> \<open>B\<subseteq>C\<close> have "C = ?V``{x}"
      using neigh_not_empty image_greater_rel by simp
    ultimately have "C \<in> {V``{x}.V\<in>\<Phi>}" by auto
    with \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close> have "C \<in> \<M>`(x)" by simp
  } thus ?thesis by blast
  qed
  moreover have "\<forall>A \<in> \<M>`(x).\<forall>B \<in> \<M>`(x). A\<inter>B \<in> \<M>`(x)"
  proof -
  { fix A B assume "A \<in> \<M>`(x)" and "B \<in> \<M>`(x)"
    with \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close> obtain V\<^sub>A V\<^sub>B where
      "A = V\<^sub>A``{x}" "B = V\<^sub>B``{x}" and  "V\<^sub>A \<in> \<Phi>" "V\<^sub>B \<in> \<Phi>"
      by auto
    let ?C = "V\<^sub>A``{x} \<inter> V\<^sub>B``{x}"
    from assms \<open>V\<^sub>A \<in> \<Phi>\<close> \<open>V\<^sub>B \<in> \<Phi>\<close> have "V\<^sub>A\<inter>V\<^sub>B \<in> \<Phi>" using IsUniformity_def IsFilter_def
      by simp
    with \<open>\<M>`(x) = {V``{x}.V\<in>\<Phi>}\<close> have "(V\<^sub>A\<inter>V\<^sub>B)``{x} \<in> \<M>`(x)" by auto
    moreover from PhiFilter \<open>V\<^sub>A \<in> \<Phi>\<close> \<open>V\<^sub>B \<in> \<Phi>\<close> have "?C \<in> Pow(X)" unfolding IsFilter_def
            by auto
    moreover have "(V\<^sub>A\<inter>V\<^sub>B)``{x} \<subseteq> ?C" using image_Int_subset_left by simp
    moreover note LargerIn
    ultimately have "?C \<in> \<M>`(x)" by simp
    with \<open>A = V\<^sub>A``{x}\<close> \<open>B = V\<^sub>B``{x}\<close> have "A\<inter>B \<in> \<M>`(x)" by blast
  } thus ?thesis by simp
  qed
  ultimately show ?thesis unfolding IsFilter_def by simp
qed

text\<open>A rephrasing of \<open>filter_from_uniformity\<close>: if $\Phi$ is a uniformity on $X$,
  then $\{V(\{ x\}) | V\in \Phi\}$ is a filter on $X$ for every $x\in X$.\<close>

lemma unif_filter_at_point:
  assumes "\<Phi> {is a uniformity on} X" and "x\<in>X"
  shows "{V``{x}.V\<in>\<Phi>} {is a filter on} X"
  using assms filter_from_uniformity ZF_fun_from_tot_val1
  by simp

text\<open>A frequently used property of filters is that they are "upward closed" i.e.  supersets
  of a filter element are also in the filter. The next lemma makes this explicit
  for easy reference as applied to the natural filter created from a uniformity.\<close>

corollary unif_filter_up_closed:
  assumes "\<Phi> {is a uniformity on} X" "x\<in>X" "U \<in> {V``{x}. V\<in>\<Phi>}" "W\<subseteq>X" "U\<subseteq>W"
  shows "W \<in> {V``{x}.V\<in>\<Phi>}"
  using assms filter_from_uniformity ZF_fun_from_tot_val1
  unfolding IsFilter_def by auto

text\<open> The function defined in the premises of lemma \<open>neigh_filt_fun\<close>
  (or \<open>filter_from_uniformity\<close>) is a neighborhood system. The proof uses the existence
  of the "half-the-size" neighborhood condition (\<open>\<exists>V\<in>\<Phi>. V O V \<subseteq> U\<close>) of the uniformity definition,
  but not the \<open>converse(U) \<in> \<Phi>\<close> part. \<close>

theorem neigh_from_uniformity:
  assumes "\<Phi> {is a uniformity on} X"
  shows "{\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>.x\<in>X} {is a neighborhood system on} X"
proof -
  let ?\<M> = "{\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>.x\<in>X}"
  from assms have "?\<M>:X\<rightarrow>Pow(Pow(X))" and Mval: "\<forall>x\<in>X. ?\<M>`(x) = {V``{x}.V\<in>\<Phi>}"
    using IsUniformity_def neigh_filt_fun by auto
  moreover from assms have "\<forall>x\<in>X. (?\<M>`(x) {is a filter on} X)" using filter_from_uniformity
    by simp
  moreover
  { fix x assume "x\<in>X"
    have "\<forall>N\<in>?\<M>`(x). x\<in>N \<and> (\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N\<in>?\<M>`(y)))"
    proof -
      { fix N assume "N\<in>?\<M>`(x)"
        have "x\<in>N" and "\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N \<in> ?\<M>`(y))"
        proof -
          from \<open>?\<M>:X\<rightarrow>Pow(Pow(X))\<close> Mval \<open>x\<in>X\<close> \<open>N\<in>?\<M>`(x)\<close>
          obtain U where "U\<in>\<Phi>" and "N = U``{x}" by auto
          with assms \<open>x\<in>X\<close> show "x\<in>N" using neigh_not_empty by simp
          from assms \<open>U\<in>\<Phi>\<close> obtain V where "V\<in>\<Phi>"  and  "V O V \<subseteq> U"
            unfolding IsUniformity_def by auto
          let ?W = "V``{x}"
          from \<open>V\<in>\<Phi>\<close> Mval \<open>x\<in>X\<close> have "?W \<in> ?\<M>`(x)" by auto
          moreover have "\<forall>y\<in>?W. N \<in> ?\<M>`(y)"
          proof -
            { fix y assume "y\<in>?W"
              with \<open>?\<M>:X\<rightarrow>Pow(Pow(X))\<close> \<open>x\<in>X\<close> \<open>?W \<in> ?\<M>`(x)\<close> have "y\<in>X"
                using apply_funtype by blast
              with assms have "?\<M>`(y) {is a filter on} X" using filter_from_uniformity
                by simp
              moreover from assms \<open>y\<in>X\<close> \<open>V\<in>\<Phi>\<close> have "V``{y} \<in> ?\<M>`(y)"
                using neigh_filt_fun by auto
              moreover from \<open>?\<M>:X\<rightarrow>Pow(Pow(X))\<close> \<open>x\<in>X\<close> \<open>N \<in> ?\<M>`(x)\<close> have "N \<in> Pow(X)"
                using apply_funtype by blast
              moreover from \<open>V O V \<subseteq> U\<close> \<open>y\<in>?W\<close> have
                "V``{y} \<subseteq> (V O V)``{x}" and "(V O V)``{x} \<subseteq> U``{x}"
                by auto
              with \<open>N = U``{x}\<close>  have "V``{y} \<subseteq> N" by blast
              ultimately have "N \<in> ?\<M>`(y)" unfolding IsFilter_def by simp
            } thus ?thesis by simp
          qed
          ultimately show "\<exists>U\<in>?\<M>`(x).\<forall>y\<in>U.(N \<in> ?\<M>`(y))" by auto
        qed
      } thus ?thesis by simp
    qed
  }
  ultimately show ?thesis unfolding IsNeighSystem_def by simp
qed

text\<open> When we have a uniformity $\Phi$ on $X$ we can define a topology on $X$ in a (relatively)
  natural way. We will call that topology the \<open> UniformTopology(\<Phi>)\<close>.
  We could probably reformulate the definition to skip
  the $X$ parameter because if $\Phi$ is a uniformity on $X$ then $X$ can be recovered
  from (is determined by) $\Phi$. \<close>

definition
  "UniformTopology(\<Phi>,X) \<equiv> {U\<in>Pow(X). \<forall>x\<in>U. U\<in>{V``{x}. V\<in>\<Phi>}}"

text\<open>An identity showing how the definition of uniform topology is constructed.
  Here, the $M = \{\langle t,\{ V\{ t\} : V\in \Phi\}\rangle : t\in X\}$ is the neighborhood system
  (a function on $X$) created from uniformity $\Phi$.
  Then for each $x\in X$, $M(x) = \{ V\{ t\} : V\in \Phi\}$ is the set of neighborhoods of $x$. \<close>

lemma uniftop_def_alt:
  shows "UniformTopology(\<Phi>,X) = {U \<in> Pow(X). \<forall>x\<in>U. U \<in> {\<langle>t,{V``{t}.V\<in>\<Phi>}\<rangle>.t\<in>X}`(x)}"
proof -
  let ?\<M> = "{\<langle>x,{V``{x}. V\<in>\<Phi>}\<rangle>. x\<in>X}"
  have "\<forall>U\<in>Pow(X).\<forall>x\<in>U. ?\<M>`(x) = {V``{x}. V\<in>\<Phi>}"
    using ZF_fun_from_tot_val1 by auto
  then show ?thesis unfolding UniformTopology_def by auto
qed

text\<open> The collection of sets constructed in the \<open> UniformTopology \<close> definition
  is indeed a topology on $X$. \<close>

theorem uniform_top_is_top:
  assumes "\<Phi> {is a uniformity on} X"
  shows
  "UniformTopology(\<Phi>,X) {is a topology}" and "\<Union> UniformTopology(\<Phi>,X) = X"
  using assms neigh_from_uniformity uniftop_def_alt topology_from_neighs
  by auto

text\<open>If we have a uniformity $\Phi$ we can create a neighborhood system from it in two ways.
  We can create a a neighborhood system directly from $\Phi$ using the formula
  $X \ni x \mapsto \{V\{x\} | x\in X\}$ (see theorem \<open>neigh_from_uniformity\<close>).
  Alternatively we can construct a topology from $\Phi$ as in theorem
  \<open>uniform_top_is_top\<close> and then create a neighborhood system from this topology
  as in theorem \<open>neigh_from_topology\<close>. The next theorem states that these two ways give the same
  result. \<close>

theorem neigh_unif_same: assumes "\<Phi> {is a uniformity on} X"
  shows
    "{\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>. x\<in>X} = {neighborhood system of} UniformTopology(\<Phi>,X)"
  using assms neigh_from_uniformity nei_top_nei_round_trip uniftop_def_alt
  by simp

text\<open>Another form of the definition of topology generated from a uniformity.\<close>

lemma uniftop_def_alt1: assumes "\<Phi> {is a uniformity on} X"
  shows "UniformTopology(\<Phi>,X) = {U\<in>Pow(X).  \<forall>x\<in>U. \<exists>W\<in>\<Phi>. W``{x} \<subseteq> U}"
proof
  let ?T = "UniformTopology(\<Phi>,X)"
  show "?T \<subseteq> {U\<in>Pow(X).  \<forall>x\<in>U. \<exists>W\<in>\<Phi>. W``{x} \<subseteq> U}"
    unfolding UniformTopology_def by auto
  { fix U assume "U\<in>{U\<in>Pow(X).  \<forall>x\<in>U. \<exists>W\<in>\<Phi>. W``{x} \<subseteq> U}"
    then have "U\<in>Pow(X)" and I: "\<forall>x\<in>U. \<exists>W\<in>\<Phi>. W``{x} \<subseteq> U" by auto
    { fix x assume "x\<in>U"
      with I obtain W where "W\<in>\<Phi>" and "W``{x} \<subseteq> U"
        by auto
      let ?\<FF> = "{V``{x}.V\<in>\<Phi>}"
      from assms(1) \<open>U\<in>Pow(X)\<close> \<open>x\<in>U\<close> \<open>W\<in>\<Phi>\<close> have
        "?\<FF> {is a filter on} X" and "W``{x} \<in> ?\<FF>"
        using unif_filter_at_point by auto
      with \<open>U\<in>Pow(X)\<close> \<open>W``{x} \<subseteq> U\<close> have "U\<in>?\<FF>"
        using is_filter_def_split(5) by blast
    } hence "\<forall>x\<in>U. U \<in> {V``{x}.V\<in>\<Phi>}" by simp
    with \<open>U\<in>Pow(X)\<close> have "U\<in>?T"
      unfolding UniformTopology_def by simp
  } thus "{U\<in>Pow(X).  \<forall>x\<in>U. \<exists>W\<in>\<Phi>. W``{x} \<subseteq> U} \<subseteq> ?T"
    by blast
qed

text\<open>Images of singletons by entourages are neighborhoods of those singletons.\<close>

lemma image_singleton_ent_nei:
  assumes "\<Phi> {is a uniformity on} X" "V\<in>\<Phi>" "x\<in>X"
  defines "\<M> \<equiv> {neighborhood system of} UniformTopology(\<Phi>,X)"
  shows "V``{x} \<in> \<M>`(x)"
proof -
  from assms(1,4) have "\<M> = {\<langle>x,{V``{x}.V\<in>\<Phi>}\<rangle>. x\<in>X}"
    using neigh_unif_same by simp
  with assms(2,3) show ?thesis
    using ZF_fun_from_tot_val1 by auto
qed

text\<open>The set neighborhoods of a singleton $\{ x\}$ where $x\in X$ consist
  of images of the singleton by the entourages $W\in \Phi$.
  See also the Metamath's theorem with the same name. \<close>

lemma utopsnneip: assumes "\<Phi> {is a uniformity on} X" "x\<in>X"
  defines "\<S> \<equiv> {set neighborhood system of} UniformTopology(\<Phi>,X)"
  shows "\<S>`{x} = {W``{x}. W\<in>\<Phi>}"
proof -
  let ?T = "UniformTopology(\<Phi>,X)"
  let ?\<M> = "{neighborhood system of} ?T"
  from assms(1,2) have "x \<in> \<Union>?T"
    using uniform_top_is_top(2) by simp
  with assms(3) have "?\<M>`(x) = \<S>`{x}"
    using neigh_from_nei by simp
  moreover
  from assms(1) have "?\<M> = {\<langle>x,{W``{x}.W\<in>\<Phi>}\<rangle>. x\<in>X}"
    using neigh_unif_same by simp
  with assms(2) have "?\<M>`(x) =  {W``{x}.W\<in>\<Phi>}"
    using ZF_fun_from_tot_val1 by simp
  ultimately show ?thesis by simp
qed

text\<open>Images of singletons by entourages are set neighborhoods of those singletons.
  See also the Metamath theorem with the same name.\<close>

corollary utopsnnei: assumes "\<Phi> {is a uniformity on} X" "W\<in>\<Phi>" "x\<in>X"
  defines "\<S> \<equiv> {set neighborhood system of} UniformTopology(\<Phi>,X)"
  shows "W``{x} \<in> \<S>`{x}" using assms utopsnneip by auto

text\<open>If $\Phi$ is a uniformity on $X$ that generates a topology $T$, $R$ is any relation
  on $X$ (i.e. $R\subseteq X\times X$), $W$ is a symmetric entourage (i.e. $W\in \Phi$,
  and $W$ is symmetric (i.e. equal to its converse), then the closure of $R$ in the product topology
  is contained the the composition $V\circ (M \circ V)$.
  Metamath has a similar theorem with the same name.  \<close>

lemma utop3cls:
  assumes "\<Phi> {is a uniformity on} X" "R\<subseteq>X\<times>X" "W\<in>\<Phi>" "W=converse(W)"
  defines "J \<equiv> UniformTopology(\<Phi>,X)"
  shows "Closure(R,J\<times>\<^sub>tJ) \<subseteq> W O (R O W)"
proof
  let ?M = "{set neighborhood system of} (J\<times>\<^sub>tJ)"
  fix z assume zMem: "z \<in> Closure(R,J\<times>\<^sub>tJ)"
  from assms(1,5) have Jtop: "J {is a topology}" and "\<Union>J = X"
    using uniform_top_is_top by auto
  then have JJtop: "(J\<times>\<^sub>tJ) {is a topology}" and JxJ: "\<Union>(J\<times>\<^sub>tJ) = X\<times>X"
    using Top_1_4_T1(1,3) by auto
  with assms(2) have "topology0(J\<times>\<^sub>tJ)" and "R \<subseteq> \<Union>(J\<times>\<^sub>tJ)"
    unfolding topology0_def by auto
  then have "Closure(R,J\<times>\<^sub>tJ) \<subseteq> \<Union>(J\<times>\<^sub>tJ)"
    using topology0.Top_3_L11(1) by simp
  with \<open>z \<in> Closure(R,J\<times>\<^sub>tJ)\<close> JxJ have "z\<in>X\<times>X" by auto
  let ?x = "fst(z)"
  let ?y = "snd(z)"
  from \<open>z\<in>X\<times>X\<close> have "?x\<in>X" "?y\<in>X" "z = \<langle>?x,?y\<rangle>" by auto
  with assms(1,3,5) Jtop have "(W``{?x})\<times>(W``{?y}) \<in> ?M`({?x}\<times>{?y})"
    using utopsnnei neitx by simp
  moreover from \<open>z = \<langle>?x,?y\<rangle>\<close> have "{?x}\<times>{?y} = {z}"
    by (rule pair_prod)
  ultimately have "(W``{?x})\<times>(W``{?y}) \<in> ?M`{z}" by simp
  with zMem JJtop \<open>R \<subseteq> \<Union>(J\<times>\<^sub>tJ)\<close> have "(W``{?x})\<times>(W``{?y}) \<inter> R \<noteq> 0"
    using neindisj by blast
  with assms(4) have "\<langle>?x,?y\<rangle> \<in> W O (R O W)"
    using sym_rel_comp by simp
  with \<open>z = \<langle>?x,?y\<rangle>\<close> show "z \<in> W O (R O W)"
    by simp
qed

text\<open>Uniform spaces are regular ($T_3$). \<close>

theorem utopreg:
  assumes "\<Phi> {is a uniformity on} X"
  shows "UniformTopology(\<Phi>,X) {is regular}"
proof -
  let ?J = "UniformTopology(\<Phi>,X)"
  let ?\<S> = "{set neighborhood system of} ?J"
  from assms have "\<Union>?J = X"
    and Jtop: "?J {is a topology}" and cntx: "topology0(?J)"
    using uniform_top_is_top unfolding topology0_def by auto
  have "\<forall>U\<in>?J. \<forall>x\<in>U. \<exists>V\<in>?J. x\<in>V \<and> Closure(V,?J)\<subseteq>U"
  proof -
    { fix U x assume "U\<in>?J" "x\<in>U"
      then have "U \<in> ?\<S>`{x}" using open_nei_singl by simp
      from \<open>U\<in>?J\<close> have "U\<subseteq>\<Union>?J" by auto
      with \<open>x\<in>U\<close> \<open>\<Union>?J = X\<close> have "x\<in>X" by auto
      from assms(1) \<open>x\<in>X\<close> \<open>U \<in> ?\<S>`{x}\<close> obtain A
        where "U=A``{x}" and "A\<in>\<Phi>"
        using utopsnneip by auto
      from assms(1) \<open>A\<in>\<Phi>\<close> obtain W where
        "W\<in>\<Phi>" "W O (W O W) \<subseteq> A" and Wsymm: "W=converse(W)"
        using ustex3sym by blast
      with assms(1) \<open>x\<in>X\<close> have "W``{x} \<in> ?\<S>`{x}" and "W``{x} \<subseteq> X"
        using utopsnnei ustimasn by auto
      from \<open>W``{x} \<in> ?\<S>`{x}\<close> have "\<exists>V\<in>?J. {x}\<subseteq>V \<and> V\<subseteq>W``{x}"
        by (rule neii2)
      then obtain V where "V\<in>?J" "x\<in>V" "V\<subseteq>W``{x}"
        by blast
      have "Closure(V,?J) \<subseteq> U"
      proof -
        from assms(1) \<open>W\<in>\<Phi>\<close> \<open>\<Union>?J = X\<close> have "W \<subseteq> X\<times>X"
          using entourage_props(1) by simp
        from cntx \<open>W``{x} \<subseteq> X\<close> \<open>\<Union>?J = X\<close> \<open>V\<subseteq>W``{x}\<close>
          have "Closure(V,?J) \<subseteq> Closure(W``{x},?J)"
            using topology0.top_closure_mono by simp
        also have "Closure(W``{x},?J) \<subseteq> Closure(W,?J\<times>\<^sub>t?J)``{x}"
        proof -
          from \<open>W\<subseteq>X\<times>X\<close> \<open>x\<in>X\<close> \<open>\<Union>?J = X\<close>
            have "W\<subseteq>(\<Union>?J)\<times>(\<Union>?J)" "x\<in>\<Union>?J" by auto
          with \<open>?J {is a topology}\<close> show ?thesis
            using imasncls by simp
        qed
        also from assms(1) \<open>W\<subseteq>X\<times>X\<close> \<open>W\<in>\<Phi>\<close> Wsymm \<open>W O (W O W) \<subseteq> A\<close>
          have "Closure(W,?J\<times>\<^sub>t?J)``{x} \<subseteq> A``{x}"
            using utop3cls by blast
        finally have "Closure(V,?J) \<subseteq> A``{x}"
          by simp
        with \<open>U=A``{x}\<close> show ?thesis by auto
      qed
      with \<open>V\<in>?J\<close> \<open>x\<in>V\<close> have "\<exists>V\<in>?J. x\<in>V \<and> Closure(V,?J)\<subseteq>U"
        by blast
    } thus ?thesis by simp
  qed
  with Jtop show "?J {is regular}" using is_regular_def_alt
    by simp
qed

end


section\<open>Preservation results for $\kappa$-closed forcing notions\<close>

theory Kappa_Closed_Notions
  imports
    Not_CH
begin

definition
  lerel :: "i\<Rightarrow>i" where
  "lerel(\<alpha>) \<equiv> Memrel(\<alpha>) \<union> id(\<alpha>)"

lemma lerelI[intro!]: "x\<le>y \<Longrightarrow> y\<in>\<alpha> \<Longrightarrow> Ord(\<alpha>) \<Longrightarrow> \<langle>x,y\<rangle> \<in> lerel(\<alpha>)"
  using Ord_trans[of x y \<alpha>] ltD unfolding lerel_def by auto

lemma lerelD[dest]: "\<langle>x,y\<rangle> \<in> lerel(\<alpha>) \<Longrightarrow> Ord(\<alpha>) \<Longrightarrow> x\<le>y"
  using ltI[THEN leI] Ord_in_Ord unfolding lerel_def by auto

definition
  mono_seqspace :: "[i,i,i] \<Rightarrow> i" (\<open>_ \<^sub><\<rightarrow> '(_,_')\<close> [61] 60) where
  "\<alpha> \<^sub><\<rightarrow> (P,leq) \<equiv> mono_map(\<alpha>,Memrel(\<alpha>),P,leq)"

relativize functional "mono_seqspace" "mono_seqspace_rel"
relationalize "mono_seqspace_rel" "is_mono_seqspace"
synthesize "is_mono_seqspace" from_definition assuming "nonempty"

context M_ZF_library
begin

rel_closed for "mono_seqspace"
  unfolding mono_seqspace_rel_def mono_map_rel_def
  using separation_closed separation_ball separation_imp separation_in
    lam_replacement_fst lam_replacement_snd lam_replacement_hcomp lam_replacement_constant
    lam_replacement_product
    lam_replacement_apply2[THEN[5] lam_replacement_hcomp2]
  by simp_all

end \<comment> \<open>\<^locale>\<open>M_ZF_library\<close>\<close>

abbreviation
  mono_seqspace_r (\<open>_ \<^sub><\<rightarrow>\<^bsup>_\<^esup> '(_,_')\<close> [61] 60) where
  "\<alpha> \<^sub><\<rightarrow>\<^bsup>M\<^esup> (P,leq) \<equiv> mono_seqspace_rel(M,\<alpha>,P,leq)"

abbreviation
  mono_seqspace_r_set (\<open>_ \<^sub><\<rightarrow>\<^bsup>_\<^esup> '(_,_')\<close> [61] 60) where
  "\<alpha> \<^sub><\<rightarrow>\<^bsup>M\<^esup> (P,leq) \<equiv> mono_seqspace_rel(##M,\<alpha>,P,leq)"

lemma mono_seqspaceI[intro!]:
  includes mono_map_rules
  assumes "f: A\<rightarrow>P" "\<And>x y. x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> x<y \<Longrightarrow> \<langle>f`x, f`y\<rangle> \<in> leq" "Ord(A)"
  shows  "f: A \<^sub><\<rightarrow> (P,leq)"
  using ltI[OF _ Ord_in_Ord[of A], THEN [3] assms(2)] assms(1,3)
  unfolding mono_seqspace_def by auto

lemma (in M_ZF_library) mono_seqspace_rel_char:
  assumes "M(A)" "M(P)" "M(leq)"
  shows "A \<^sub><\<rightarrow>\<^bsup>M\<^esup> (P,leq) = {f\<in>A \<^sub><\<rightarrow> (P,leq). M(f)}"
  using assms mono_map_rel_char
  unfolding mono_seqspace_def mono_seqspace_rel_def by simp

lemma (in M_ZF_library) mono_seqspace_relI[intro!]:
  assumes "f: A\<rightarrow>\<^bsup>M\<^esup> P" "\<And>x y. x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> x<y \<Longrightarrow> \<langle>f`x, f`y\<rangle> \<in> leq"
    "Ord(A)" "M(A)" "M(P)" "M(leq)"
  shows  "f: A \<^sub><\<rightarrow>\<^bsup>M\<^esup> (P,leq)"
  using mono_seqspace_rel_char function_space_rel_char assms by auto

lemma mono_seqspace_is_fun[dest]:
  includes mono_map_rules
  shows "j: A \<^sub><\<rightarrow> (P,leq) \<Longrightarrow> j: A\<rightarrow> P"
  unfolding mono_seqspace_def by auto

lemma mono_map_lt_le_is_mono[dest]:
  includes mono_map_rules
  assumes "j: A \<^sub><\<rightarrow> (P,leq)" "a\<in>A" "c\<in>A" "a\<le>c" "Ord(A)" "refl(P,leq)"
  shows "\<langle>j`a,j`c\<rangle> \<in> leq"
  using assms mono_map_increasing unfolding mono_seqspace_def refl_def
  by (cases "a=c") (auto dest:ltD)

lemma (in M_ZF_library) mem_mono_seqspace_abs[absolut]:
  assumes "M(f)" "M(A)" "M(P)" "M(leq)"
  shows  "f:A \<^sub><\<rightarrow>\<^bsup>M\<^esup> (P,leq) \<longleftrightarrow>  f: A \<^sub><\<rightarrow> (P,leq)"
  using assms mono_map_rel_char unfolding mono_seqspace_def mono_seqspace_rel_def
  by (simp)

definition
  mono_map_lt_le :: "[i,i] \<Rightarrow> i" (infixr \<open>\<^sub><\<rightarrow>\<^sub>\<le>\<close> 60) where
  "\<alpha> \<^sub><\<rightarrow>\<^sub>\<le> \<beta> \<equiv> \<alpha> \<^sub><\<rightarrow> (\<beta>,lerel(\<beta>))"

lemma mono_map_lt_leI[intro!]:
  includes mono_map_rules
  assumes "f: A\<rightarrow>B" "\<And>x y. x\<in>A \<Longrightarrow> y\<in>A \<Longrightarrow> x<y \<Longrightarrow> f`x \<le> f`y" "Ord(A)" "Ord(B)"
  shows  "f: A \<^sub><\<rightarrow>\<^sub>\<le> B"
  using assms
  unfolding mono_map_lt_le_def by auto

\<comment> \<open>Kunen IV.7.13, with “$\kappa$” in place of “$\lambda$”\<close>
definition
  kappa_closed :: "[i,i,i] \<Rightarrow> o" (\<open>_-closed'(_,_')\<close>) where
  "\<kappa>-closed(P,leq) \<equiv> \<forall>\<delta>. \<delta><\<kappa> \<longrightarrow> (\<forall>f\<in>\<delta> \<^sub><\<rightarrow> (P,converse(leq)). \<exists>q\<in>P. \<forall>\<alpha>\<in>\<delta>. \<langle>q,f`\<alpha>\<rangle>\<in>leq)"

relativize functional "kappa_closed" "kappa_closed_rel"
relationalize "kappa_closed_rel" "is_kappa_closed"
synthesize "is_kappa_closed" from_definition assuming "nonempty"

abbreviation
  kappa_closed_r (\<open>_-closed\<^bsup>_\<^esup>'(_,_')\<close> [61] 60) where
  "\<kappa>-closed\<^bsup>M\<^esup>(P,leq) \<equiv> kappa_closed_rel(M,\<kappa>,P,leq)"

abbreviation
  kappa_closed_r_set (\<open>_-closed\<^bsup>_\<^esup>'(_,_')\<close> [61] 60) where
  "\<kappa>-closed\<^bsup>M\<^esup>(P,leq) \<equiv> kappa_closed_rel(##M,\<kappa>,P,leq)"

lemma (in forcing_data3) forcing_a_value:
  assumes "p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, A\<^sup>v, B\<^sup>v]" "a \<in> A"
    "q \<preceq> p" "q \<in> \<bbbP>" "p\<in>\<bbbP>" "f_dot \<in> M" "A\<in>M" "B\<in>M"
  shows "\<exists>d\<in>\<bbbP>. \<exists>b\<in>B. d \<preceq> q \<and> d \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v]"
    (* \<comment> \<open>Old neater version, but harder to use
    (without the assumptions on \<^term>\<open>q\<close>):\<close>
    "dense_below({q \<in> \<bbbP>. \<exists>b\<in>B. q \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, b\<^sup>v]}, p)" *)
proof -
  from assms
  have "q \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, A\<^sup>v, B\<^sup>v]"
    using strengthening_lemma[of p "\<cdot>0:1\<rightarrow>2\<cdot>" q "[f_dot, A\<^sup>v, B\<^sup>v]"]
      typed_function_type arity_typed_function_fm
    by (auto simp: union_abs2 union_abs1)
  from \<open>a\<in>A\<close> \<open>A\<in>M\<close>
  have "a\<in>M" by (auto dest:transitivity)
  from \<open>q\<in>\<bbbP>\<close>
  text\<open>Here we're using countability (via the existence of generic filters)
    of \<^term>\<open>M\<close> as a shortcut, to avoid a further density argument.\<close>
  obtain G where "M_generic(G)" "q\<in>G"
    using generic_filter_existence by blast
  then
  interpret G_generic3_AC _ _ _ _ _ G by unfold_locales
  include G_generic1_lemmas
  note \<open>q\<in>G\<close>
  moreover
  note \<open>q \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, A\<^sup>v, B\<^sup>v]\<close> \<open>M_generic(G)\<close>
  moreover
  note \<open>q\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close> \<open>B\<in>M\<close> \<open>A\<in>M\<close>
  moreover from this
  have "map(val( G), [f_dot, A\<^sup>v, B\<^sup>v]) \<in> list(M[G])" by simp
  moreover from calculation
  have "val(G,f_dot) : A \<rightarrow>\<^bsup>M[G]\<^esup> B"
    using truth_lemma[of "\<cdot>0:1\<rightarrow>2\<cdot>" "[f_dot, A\<^sup>v, B\<^sup>v]", THEN iffD1]
      typed_function_type arity_typed_function_fm val_check[OF one_in_G one_in_P]
    by (auto simp: union_abs2 union_abs1 ext.mem_function_space_rel_abs)
  moreover
  note \<open>a \<in> M\<close>
  moreover from calculation and \<open>a\<in>A\<close>
  have "val(G,f_dot) ` a \<in> B" (is "?b \<in> B")
    by (simp add: ext.mem_function_space_rel_abs)
  moreover from calculation
  have "?b \<in> M" by (auto dest:transitivity)
  moreover from calculation
  have "M[G], map(val(G), [f_dot, a\<^sup>v, ?b\<^sup>v]) \<Turnstile> \<cdot>0`1 is 2\<cdot>"
    by simp
  ultimately
  obtain r where "r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, ?b\<^sup>v]" "r\<in>G" "r\<in>\<bbbP>"
    using truth_lemma[of "\<cdot>0`1 is 2\<cdot>" "[f_dot, a\<^sup>v, ?b\<^sup>v]", THEN iffD2]
      fun_apply_type arity_fun_apply_fm val_check[OF one_in_G one_in_P]
      G_subset_P
    by (auto simp: union_abs2 union_abs1 ext.mem_function_space_rel_abs)
  moreover from this and \<open>q\<in>G\<close>
  obtain d where "d\<preceq>q" "d\<preceq>r" "d\<in>\<bbbP>" by force
  moreover
  note \<open>f_dot\<in>M\<close> \<open>a\<in>M\<close> \<open>?b\<in>B\<close> \<open>B\<in>M\<close>
  moreover from calculation
  have "d \<preceq> q \<and> d \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, a\<^sup>v, ?b\<^sup>v]"
    using fun_apply_type arity_fun_apply_fm
      strengthening_lemma[of r "\<cdot>0`1 is 2\<cdot>" d "[f_dot, a\<^sup>v, ?b\<^sup>v]"]
    by (auto dest:transitivity simp add: union_abs2 union_abs1)
  ultimately
  show ?thesis by auto
qed

locale M_master_CH = M_master + M_library_DC

sublocale M_ZFC2_ground_CH_trans \<subseteq> M_master_CH "##M"
  using replacement_dcwit_repl_body
  by unfold_locales (simp_all add:sep_instances del:setclass_iff
      add: transrec_replacement_def wfrec_replacement_def dcwit_repl_body_def)

context G_generic3_AC_CH begin

context
  includes G_generic1_lemmas
begin

lemma separation_check_snd_aux:
  assumes "f_dot\<in>M" "\<tau>\<in>M" "\<chi>\<in>formula" "arity(\<chi>) \<le> 7"
  shows "separation(##M, \<lambda>r. M, [fst(r), \<bbbP>, leq, \<one>, f_dot, \<tau>, snd(r)\<^sup>v] \<Turnstile> \<chi>)"
proof -
  let ?f_fm="fst_fm(1,0)"
  let ?g_fm="hcomp_fm(check_fm(6),snd_fm,2,0)"
  note assms
  moreover
  have "?f_fm \<in> formula" "arity(?f_fm) \<le> 7" "?g_fm \<in> formula" "arity(?g_fm) \<le> 8"
    using ord_simp_union
    unfolding hcomp_fm_def
    by (simp_all add:arity)
  ultimately
  show ?thesis
    using separation_sat_after_function
    using fst_abs snd_abs sats_snd_fm sats_check_fm check_abs
    unfolding hcomp_fm_def
    by simp
qed

lemma separation_check_fst_snd_aux :
  assumes "f_dot\<in>M" "r\<in>M" "\<chi>\<in>formula" "arity(\<chi>) \<le> 7"
  shows "separation(##M, \<lambda>p. M, [r, \<bbbP>, leq, \<one>, f_dot, fst(p)\<^sup>v, snd(p)\<^sup>v] \<Turnstile> \<chi>)"
proof -
  let ?\<rho>="\<lambda>z. [r, \<bbbP>, leq, \<one>, f_dot, fst(z)\<^sup>v, snd(z)\<^sup>v]"
  let ?\<rho>'="\<lambda>z. [fst(z)\<^sup>v, \<bbbP>, leq, \<one>, f_dot, r, snd(z)\<^sup>v]"
  let ?\<phi>=" (\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>(\<cdot>\<exists>\<cdot>\<cdot>0 = 11\<cdot> \<and> \<cdot>\<cdot>1 = 7\<cdot> \<and> \<cdot>\<cdot>2 = 8\<cdot> \<and> \<cdot>\<cdot>3 = 9\<cdot> \<and> \<cdot>\<cdot>4 = 10\<cdot> \<and> \<cdot>\<cdot>5 = 6\<cdot> \<and>
    (\<lambda>p. incr_bv(p)`6)^6 (\<chi>) \<cdot>\<cdot>\<cdot>\<cdot>\<cdot>\<cdot>\<cdot>)\<cdot>)\<cdot>)\<cdot>)\<cdot>)\<cdot>)"
  let ?f_fm="hcomp_fm(check_fm(5),fst_fm,1,0)"
  let ?g_fm="hcomp_fm(check_fm(6),snd_fm,2,0)"
  note assms
  moreover
  have "?f_fm \<in> formula" "arity(?f_fm) \<le> 7" "?g_fm \<in> formula" "arity(?g_fm) \<le> 8"
    using ord_simp_union
    unfolding hcomp_fm_def
    by (simp_all add:arity)
  moreover from assms
  have fm:"?\<phi>\<in>formula" by simp
  moreover from \<open>\<chi> \<in> formula\<close> \<open>arity(\<chi>) \<le> 7\<close>
  have "arity(\<chi>) = 0 \<or> arity(\<chi>) = 1 \<or> arity(\<chi>) = 2 \<or> arity(\<chi>) = 3
    \<or> arity(\<chi>) = 4 \<or> arity(\<chi>) = 5 \<or> arity(\<chi>) = 6 \<or> arity(\<chi>) = 7"
    unfolding lt_def by auto
  with calculation and \<open>\<chi> \<in> formula\<close>
  have ar:"arity(?\<phi>) \<le> 7"
    using arity_incr_bv_lemma by safe (simp_all add: arity ord_simp_union)
  moreover from calculation
  have sep:"separation(##M,\<lambda>z. M,?\<rho>'(z)\<Turnstile>?\<phi>)"
    using separation_sat_after_function sats_check_fm check_abs
      fst_abs snd_abs
    unfolding hcomp_fm_def
    by simp
  moreover from assms
  have "?\<rho>(z) \<in> list(M)" if "(##M)(z)" for z
    using that by simp
  moreover from calculation and \<open>r \<in> M\<close> \<open>\<chi> \<in> formula\<close>
  have "(M,?\<rho>(z) \<Turnstile> \<chi>) \<longleftrightarrow> (M,?\<rho>'(z)\<Turnstile>?\<phi>)" if "(##M)(z)" for z
    using that sats_incr_bv_iff[of _ _ M _ "[_,_,_,_,_,_]"]
    by simp
  ultimately
  show ?thesis
    using separation_cong[THEN iffD1,OF _ sep]
    by simp
qed

lemma separation_leq_and_forces_apply_aux:
  assumes "f_dot\<in>M" "B\<in>M"
  shows "\<forall>n\<in>M. separation(##M, \<lambda>x. snd(x) \<preceq> fst(x) \<and>
          (\<exists>b\<in>B. M, [snd(x), \<bbbP>, leq, \<one>, f_dot, (\<Union>(n))\<^sup>v, b\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> )))"
proof -
  have pred_nat_closed: "pred(n)\<in>M" if "n\<in>M" for n
    using nat_case_closed that
    unfolding pred_def
    by auto
  have "separation(##M, \<lambda>z. M, [snd(fst(z)), \<bbbP>, leq, \<one>, f_dot, \<tau>, snd(z)\<^sup>v] \<Turnstile> \<chi>)"
    if "\<chi>\<in>formula" "arity(\<chi>) \<le> 7" "\<tau>\<in>M" for \<chi> \<tau>
  proof -
    let ?f_fm="hcomp_fm(snd_fm,fst_fm,1,0)"
    let ?g_fm="hcomp_fm(check_fm(6),snd_fm,2,0)"
    note assms
    moreover
    have "?f_fm \<in> formula" "arity(?f_fm) \<le> 7" "?g_fm \<in> formula" "arity(?g_fm) \<le> 8"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function sats_check_fm check_abs fst_abs snd_abs that
      unfolding hcomp_fm_def
      by simp
  qed
  with assms
  show ?thesis
    using separation_in lam_replacement_constant lam_replacement_snd lam_replacement_fst
      lam_replacement_product pred_nat_closed
      arity_forces[of " \<cdot>0`1 is 2\<cdot>"] arity_fun_apply_fm[of 0 1 2] ord_simp_union
    by(clarify,rule_tac separation_conj,simp_all,rule_tac separation_bex,simp_all)
qed

lemma separation_leq_and_forces_apply_aux':
  assumes "f_dot\<in>M" "p\<in>M" "B\<in>M"
  shows "separation
     (##M, \<lambda>p .  snd(snd(p)) \<preceq> fst(snd(p)) \<and>
    (\<exists>b\<in>B. M, [snd(snd(p)), \<bbbP>, leq, \<one>, f_dot, (\<Union>fst(p))\<^sup>v, b\<^sup>v] \<Turnstile> forces(\<cdot>0`1 is 2\<cdot> )))"
proof -
  have "separation(##M, \<lambda>z. M, [snd(snd(fst(z))), \<bbbP>, leq, \<one>, f_dot, (\<Union>fst(fst(z)))\<^sup>v, snd(z)\<^sup>v] \<Turnstile> \<chi>)"
    if "\<chi>\<in>formula" "arity(\<chi>) \<le> 7" for \<chi>
  proof -
    let ?f_fm="hcomp_fm(snd_fm,hcomp_fm(snd_fm,fst_fm),1,0)"
    let ?g="\<lambda>z . (\<Union>(fst(fst(z))))\<^sup>v"
    let ?g_fm="hcomp_fm(check_fm(6),hcomp_fm(big_union_fm,hcomp_fm(fst_fm,fst_fm)),2,0)"
    let ?h_fm="hcomp_fm(check_fm(7),snd_fm,3,0)"
    note assms
    moreover
    have f_fm_facts:"?f_fm \<in> formula" "arity(?f_fm) \<le> 6"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    moreover from assms
    have "?g_fm \<in> formula" "arity(?g_fm) \<le> 7" "?h_fm \<in> formula" "arity(?h_fm) \<le> 8"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function3[OF _ _ _ f_fm_facts] check_abs
        sats_check_fm that fst_abs snd_abs sats_fst_fm sats_snd_fm
      unfolding hcomp_fm_def
      by simp
  qed
  with assms
  show ?thesis
    using
      separation_conj separation_bex
      lam_replacement_constant lam_replacement_hcomp
      lam_replacement_fst lam_replacement_snd
      arity_forces[of " \<cdot>0`1 is 2\<cdot>"] arity_fun_apply_fm[of 0 1 2] ord_simp_union
      separation_in[OF _ lam_replacement_product]
    by simp
qed

lemma separation_closed_leq_and_forces_eq_check_aux :
  assumes "A\<in>M" "r\<in>G" "\<tau> \<in> M"
  shows "(##M)({q\<in>\<bbbP>. \<exists>h\<in>A. q \<preceq> r \<and> q \<tturnstile> \<cdot>0 = 1\<cdot> [\<tau>, h\<^sup>v]})"
proof -
  have "separation(##M, \<lambda>z. M, [fst(z), \<bbbP>, leq, \<one>, \<tau>, snd(z)\<^sup>v] \<Turnstile> \<chi>)" if
    "\<chi>\<in>formula" "arity(\<chi>) \<le> 6" for \<chi>
  proof -
    let ?f_fm="fst_fm(1,0)"
    let ?g_fm="hcomp_fm(check_fm(6),snd_fm,2,0)"
    note assms
    moreover
    have "?f_fm \<in> formula" "arity(?f_fm) \<le> 6" "?g_fm \<in> formula" "arity(?g_fm) \<le> 7"
      using ord_simp_union
      unfolding hcomp_fm_def
      by (simp_all add:arity)
    ultimately
    show ?thesis
      using separation_sat_after_function_1 sats_fst_fm that
        fst_abs snd_abs sats_snd_fm sats_check_fm check_abs
      unfolding hcomp_fm_def
      by simp
  qed
  with assms
  show ?thesis
    using separation_conj separation_in G_subset_M[THEN subsetD]
      lam_replacement_constant lam_replacement_fst lam_replacement_product
      arity_forces[of "\<cdot>0 = 1\<cdot>",simplified] ord_simp_union
    by(rule_tac separation_closed[OF separation_bex],simp_all)
qed

lemma separation_closed_forces_apply_aux:
  assumes "B\<in>M" "f_dot\<in>M" "r\<in>M"
  shows "(##M)({\<langle>n,b\<rangle> \<in> \<omega> \<times> B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]})"
  using nat_in_M assms transitivity[OF _ \<open>B\<in>M\<close>] nat_into_M separation_check_fst_snd_aux
    arity_forces[of " \<cdot>0`1 is 2\<cdot>"] arity_fun_apply_fm[of 0 1 2] ord_simp_union
  unfolding split_def
  by simp_all

\<comment> \<open>Kunen IV.6.9 (3)$\Rightarrow$(2), with general domain.\<close>
lemma kunen_IV_6_9_function_space_rel_eq:
  assumes "\<And>p \<tau>. p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [\<tau>, A\<^sup>v, B\<^sup>v] \<Longrightarrow> p\<in>\<bbbP> \<Longrightarrow> \<tau> \<in> M \<Longrightarrow>
    \<exists>q\<in>\<bbbP>. \<exists>h\<in>A \<rightarrow>\<^bsup>M\<^esup> B. q \<preceq> p \<and>  q \<tturnstile> \<cdot>0 = 1\<cdot> [\<tau>, h\<^sup>v]" "A\<in>M" "B\<in>M"
  shows
    "A \<rightarrow>\<^bsup>M\<^esup> B = A \<rightarrow>\<^bsup>M[G]\<^esup> B"
proof (intro equalityI; clarsimp simp add:
    assms function_space_rel_char ext.function_space_rel_char)
  fix f
  assume "f \<in> A \<rightarrow> B" "f \<in> M[G]"
  moreover from this
  obtain \<tau> where "val(G,\<tau>) = f" "\<tau> \<in> M"
    using GenExtD by force
  moreover from calculation and \<open>A\<in>M\<close> \<open>B\<in>M\<close>
  obtain r where "r \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [\<tau>, A\<^sup>v, B\<^sup>v]" "r\<in>G"
    using truth_lemma[of "\<cdot>0:1\<rightarrow>2\<cdot>" "[\<tau>, A\<^sup>v, B\<^sup>v]"]
      typed_function_type arity_typed_function_fm val_check[OF one_in_G one_in_P]
    by (auto simp: union_abs2 union_abs1)
  moreover from \<open>A\<in>M\<close> \<open>B\<in>M\<close> \<open>r\<in>G\<close> \<open>\<tau> \<in> M\<close>
  have "{q\<in>\<bbbP>. \<exists>h\<in>A \<rightarrow>\<^bsup>M\<^esup> B. q \<preceq> r \<and> q \<tturnstile> \<cdot>0 = 1\<cdot> [\<tau>, h\<^sup>v]} \<in> M" (is "?D \<in> M")
    using separation_closed_leq_and_forces_eq_check_aux by auto
  moreover from calculation and assms(2-)
  have "dense_below(?D, r)"
    using strengthening_lemma[of r "\<cdot>0:1\<rightarrow>2\<cdot>" _ "[\<tau>, A\<^sup>v, B\<^sup>v]", THEN assms(1)[of _ \<tau>]]
      leq_transD generic_dests(1)[of r]
    by (auto simp: union_abs2 union_abs1 typed_function_type arity_typed_function_fm) blast
  moreover from calculation
  obtain q h where "h\<in>A \<rightarrow>\<^bsup>M\<^esup> B" "q \<tturnstile> \<cdot>0 = 1\<cdot> [\<tau>, h\<^sup>v]" "q \<preceq> r" "q\<in>\<bbbP>" "q\<in>G"
    using generic_inter_dense_below[of ?D r] by blast
  note \<open>q \<tturnstile> \<cdot>0 = 1\<cdot> [\<tau>, h\<^sup>v]\<close> \<open>\<tau>\<in>M\<close> \<open>h\<in>A \<rightarrow>\<^bsup>M\<^esup> B\<close> \<open>A\<in>M\<close> \<open>B\<in>M\<close> \<open>q\<in>G\<close>
  moreover from this
  have "map(val(G), [\<tau>, h\<^sup>v]) \<in> list(M[G])" "h\<in>M"
    by (auto dest:transitivity)
  ultimately
  have "h = f"
    using truth_lemma[of "\<cdot>0=1\<cdot>" "[\<tau>, h\<^sup>v]"] val_check[OF one_in_G one_in_P]
    by (auto simp: ord_simp_union)
  with \<open>h\<in>M\<close>
  show "f \<in> M" by simp
qed

subsection\<open>$(\omega+1)$-Closed notions preserve countable sequences\<close>

\<comment> \<open>Kunen IV.7.15, only for countable sequences\<close>
lemma succ_omega_closed_imp_no_new_nat_sequences:
  assumes "succ(\<omega>)-closed\<^bsup>M\<^esup>(\<bbbP>,leq)" "f : \<omega> \<rightarrow> B" "f\<in>M[G]" "B\<in>M"
  shows "f\<in>M"
proof -
  (* Nice jEdit folding level to read this: 7 *)
  text\<open>The next long block proves that the assumptions of Lemma
  @{thm [source] kunen_IV_6_9_function_space_rel_eq} are satisfied.\<close>
  {
    fix p f_dot
    assume "p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, \<omega>\<^sup>v, B\<^sup>v]" "p\<in>\<bbbP>" "f_dot\<in>M"
    let ?subp="{q\<in>\<bbbP>. q \<preceq> p}"
    from \<open>p\<in>\<bbbP>\<close>
    have "?subp \<in> M"
      using first_section_closed[of \<bbbP> p "converse(leq)"]
      by (auto dest:transitivity)
    define S where "S \<equiv> \<lambda>n\<in>nat.
    {\<langle>q,r\<rangle> \<in> ?subp\<times>?subp. r \<preceq> q \<and> (\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, (\<Union>(n))\<^sup>v, b\<^sup>v])}"
      (is "S \<equiv> \<lambda>n\<in>nat. ?Y(n)")
    define S' where "S' \<equiv> \<lambda>n\<in>nat.
    {\<langle>q,r\<rangle> \<in> ?subp\<times>?subp. r \<preceq> q \<and> (\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, (pred(n))\<^sup>v, b\<^sup>v])}"
      \<comment> \<open>Towards proving \<^term>\<open>S\<in>M\<close>.\<close>
    moreover
    have "S = S'"
      unfolding S_def S'_def using pred_nat_eq lam_cong by auto
    moreover from \<open>B\<in>M\<close> \<open>?subp\<in>M\<close> \<open>f_dot\<in>M\<close>
    have "{r \<in> ?subp. \<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, (\<Union>(n))\<^sup>v, b\<^sup>v]} \<in> M" (is "?X(n) \<in> M")
      if "n\<in>\<omega>" for n
      using that separation_check_snd_aux nat_into_M ord_simp_union
        arity_forces[of " \<cdot>0`1 is 2\<cdot>"] arity_fun_apply_fm
      by(rule_tac separation_closed[OF separation_bex,simplified], simp_all)
    moreover
    have "?Y(n) = (?subp \<times> ?X(n)) \<inter> converse(leq)" for n
      by (intro equalityI) auto
    moreover
    note \<open>?subp \<in> M\<close> \<open>B\<in>M\<close> \<open>p\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close>
    moreover from calculation
    have "n \<in> \<omega> \<Longrightarrow> ?Y(n) \<in> M" for n
      using nat_into_M by simp
    moreover from calculation
    have "S \<in> M"
      using  separation_leq_and_forces_apply_aux separation_leq_and_forces_apply_aux'
        transitivity[OF \<open>p\<in>\<bbbP>\<close>]
      unfolding S_def split_def
      by(rule_tac lam_replacement_Collect'[THEN lam_replacement_imp_lam_closed,simplified], simp_all)
    ultimately
    have "S' \<in> M"
      by simp
    from \<open>p\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close> \<open>p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, \<omega>\<^sup>v, B\<^sup>v]\<close> \<open>B\<in>M\<close>
    have exr:"\<exists>r\<in>\<bbbP>. r \<preceq> q \<and> (\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, pred(n)\<^sup>v, b\<^sup>v])"
      if "q \<preceq> p" "q\<in>\<bbbP>" "n\<in>\<omega>" for q n
      using that forcing_a_value by (auto dest:transitivity)
    have "\<forall>q\<in>?subp. \<forall>n\<in>\<omega>. \<exists>r\<in>?subp. \<langle>q,r\<rangle> \<in> S'`n"
    proof -
      {
        fix q n
        assume "q \<in> ?subp" "n\<in>\<omega>"
        moreover from this
        have "q \<preceq> p" "q \<in> \<bbbP>" "pred(n) = \<Union>n"
          using pred_nat_eq by simp_all
        moreover from calculation and exr
        obtain r where MM:"r \<preceq> q" "\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, pred(n)\<^sup>v, b\<^sup>v]" "r\<in>\<bbbP>"
          by blast
        moreover from calculation \<open>q \<preceq> p\<close> \<open>p \<in> \<bbbP>\<close>
        have "r \<preceq> p"
          using leq_transD[of r q p] by auto
        ultimately
        have "\<exists>r\<in>?subp. r \<preceq> q \<and> (\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, (pred(n))\<^sup>v, b\<^sup>v])"
          by auto
      }
      then
      show ?thesis
        unfolding S'_def by simp
    qed
    with \<open>p\<in>\<bbbP>\<close> \<open>?subp \<in> M\<close> \<open>S' \<in> M\<close>
    obtain g where "g \<in> \<omega> \<rightarrow>\<^bsup>M\<^esup> ?subp" "g`0 = p" "\<forall>n \<in> nat. \<langle>g`n,g`succ(n)\<rangle>\<in>S'`succ(n)"
      using sequence_DC[simplified] refl_leq[of p] by blast
    moreover from this and \<open>?subp \<in> M\<close>
    have "g : \<omega> \<rightarrow> \<bbbP>" "g \<in> M"
      using fun_weaken_type[of g \<omega> ?subp \<bbbP>] function_space_rel_char by auto
    ultimately
    have "g : \<omega> \<^sub><\<rightarrow>\<^bsup>M\<^esup> (\<bbbP>,converse(leq))"
      using decr_succ_decr[of g] leq_preord
      unfolding S'_def by (auto simp:absolut intro:leI)
    moreover from \<open>succ(\<omega>)-closed\<^bsup>M\<^esup>(\<bbbP>,leq)\<close> and this
    have "\<exists>q\<in>M. q \<in> \<bbbP> \<and> (\<forall>\<alpha>\<in>M. \<alpha> \<in> \<omega> \<longrightarrow> q \<preceq> g ` \<alpha>)"
      using transitivity[simplified, of g] mono_seqspace_rel_closed[of \<omega> _ "converse(leq)"]
      unfolding kappa_closed_rel_def
      by auto
    ultimately
    obtain r where "r\<in>\<bbbP>" "r\<in>M" "\<forall>n\<in>\<omega>. r \<preceq> g`n"
      using nat_into_M by auto
    with \<open>g`0 = p\<close>
    have "r \<preceq> p"
      by blast
    let ?h="{\<langle>n,b\<rangle> \<in> \<omega> \<times> B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]}"
    have "function(?h)"
    proof (rule_tac functionI, rule_tac ccontr, auto simp del: app_Cons)
      fix n b b'
      assume "n \<in> \<omega>" "b \<noteq> b'" "b \<in> B" "b' \<in> B"
      moreover
      assume "r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]" "r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b'\<^sup>v]"
      moreover
      note \<open>r \<in> \<bbbP>\<close>
      moreover from this
      have "\<not> r \<bottom> r"
        by (auto intro!:refl_leq)
      moreover
      note \<open>f_dot\<in>M\<close> \<open>B\<in>M\<close>
      ultimately
      show False
        using forces_neq_apply_imp_incompatible[of r f_dot "n\<^sup>v" b r b']
          transitivity[of _ B] by (auto dest:transitivity)
    qed
    moreover
    have "range(?h) \<subseteq> B"
      by auto
    moreover
    have "domain(?h) = \<omega>"
    proof -
      {
        fix n
        assume "n \<in> \<omega>"
        moreover from this
        have 1:"(\<Union>(n)) = pred(n)"
          using pred_nat_eq by simp
        moreover from calculation and \<open>\<forall>n \<in> nat. \<langle>g`n,g`succ(n)\<rangle>\<in>S'`succ(n)\<close>
        obtain b where "g`(succ(n)) \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]" "b\<in>B"
          unfolding S'_def by auto
        moreover from \<open>B\<in>M\<close> and calculation
        have "b \<in> M" "n \<in> M"
          by (auto dest:transitivity)
        moreover
        note \<open>g : \<omega> \<rightarrow> \<bbbP>\<close> \<open>\<forall>n\<in>\<omega>. r \<preceq> g`n\<close> \<open>r\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close>
        moreover from calculation
        have "r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]"
          using fun_apply_type arity_fun_apply_fm
            strengthening_lemma[of "g`succ(n)" "\<cdot>0`1 is 2\<cdot>" r "[f_dot, n\<^sup>v, b\<^sup>v]"]
          by (simp add: union_abs2 union_abs1)
        ultimately
        have "\<exists>b\<in>B. r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]"
          by auto
      }
      then
      show ?thesis
        by force
    qed
    moreover
    have "relation(?h)"
      unfolding relation_def by simp
    moreover from \<open>f_dot\<in>M\<close> \<open>r\<in>M\<close> \<open>B\<in>M\<close>
    have "?h \<in> M"
      using separation_closed_forces_apply_aux by simp
    moreover
    note \<open>B \<in> M\<close>
    ultimately
    have "?h: \<omega> \<rightarrow>\<^bsup>M\<^esup> B"
      using function_imp_Pi[THEN fun_weaken_type[of ?h _ "range(?h)" B]]
        function_space_rel_char by simp
    moreover
    note \<open>p \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, \<omega>\<^sup>v, B\<^sup>v]\<close> \<open>r \<preceq> p\<close> \<open>r\<in>\<bbbP>\<close> \<open>p\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close> \<open>B\<in>M\<close>
    moreover from this
    have "r \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, \<omega>\<^sup>v, B\<^sup>v]"
      using strengthening_lemma[of p "\<cdot>0:1\<rightarrow>2\<cdot>" r "[f_dot, \<omega>\<^sup>v, B\<^sup>v]"]
        typed_function_type arity_typed_function_fm
      by (auto simp: union_abs2 union_abs1)
    moreover
    note \<open>?h\<in>M\<close>
    moreover from calculation
    have "r \<tturnstile> \<cdot>0 = 1\<cdot> [f_dot, ?h\<^sup>v]"
    proof (intro definition_of_forcing[THEN iffD2] allI impI,
        simp_all add:union_abs2 union_abs1 del:app_Cons)
      fix H
      let ?f="val(H,f_dot)"
      assume "M_generic(H) \<and> r \<in> H"
      moreover from this
      interpret g:G_generic1 _ _ _ _ _ H
        by unfold_locales simp
      note \<open>r\<in>\<bbbP>\<close> \<open>f_dot\<in>M\<close> \<open>B\<in>M\<close>
      moreover from calculation
      have "map(val(H), [f_dot, \<omega>\<^sup>v, B\<^sup>v]) \<in> list(M[H])" "r\<in>H"
        by simp_all
      moreover from calculation and \<open>r\<in>H\<close> and \<open>r \<tturnstile> \<cdot>0:1\<rightarrow>2\<cdot> [f_dot, \<omega>\<^sup>v, B\<^sup>v]\<close>
      have "?f : \<omega> \<rightarrow> B"
        using g.truth_lemma[of "\<cdot>0:1\<rightarrow>2\<cdot>" "[f_dot, \<omega>\<^sup>v, B\<^sup>v]",THEN iffD1] g.one_in_G one_in_P
          typed_function_type arity_typed_function_fm val_check
        by (auto simp: union_abs2 union_abs1)
      moreover
      have "?h`n = ?f`n" if "n \<in> \<omega>" for n
      proof -
        note \<open>n \<in> \<omega>\<close> \<open>domain(?h) = \<omega>\<close>
        moreover from this
        have "n\<in>domain(?h)"
          by simp
        moreover from this
        obtain b where "r \<tturnstile> \<cdot>0`1 is 2\<cdot> [f_dot, n\<^sup>v, b\<^sup>v]" "b\<in>B"
          by force
        moreover
        note \<open>function(?h)\<close>
        moreover from calculation
        have "b = ?h`n"
          using function_apply_equality by simp
        moreover
        note \<open>B \<in> M\<close>
        moreover from calculation
        have "?h`n \<in> M"
          by (auto dest:transitivity)
        moreover
        note \<open>f_dot \<in> M\<close> \<open>r \<in> \<bbbP>\<close> \<open>M_generic(H) \<and> r \<in> H\<close> \<open>map(val(H), [f_dot, \<omega>\<^sup>v, B\<^sup>v]) \<in> list(M[H])\<close>
        moreover from calculation
        have "[?f, n, ?h`n] \<in> list(M[H])"
          using M_subset_MG nat_into_M[of n] g.one_in_G by (auto dest:transitivity)
        ultimately
        show ?thesis
          using definition_of_forcing[of r "\<cdot>0`1 is 2\<cdot>" "[f_dot, n\<^sup>v, b\<^sup>v]",
              THEN iffD1, rule_format, of H]\<comment> \<open>without this line is slower\<close>
            val_check g.one_in_G one_in_P nat_into_M
          by (auto dest:transitivity simp add:fun_apply_type
              arity_fun_apply_fm union_abs2 union_abs1)
      qed
      with calculation and \<open>B\<in>M\<close> \<open>?h: \<omega> \<rightarrow>\<^bsup>M\<^esup> B\<close>
      have "?h = ?f"
        using function_space_rel_char
        by (rule_tac fun_extension[of ?h \<omega> "\<lambda>_.B" ?f]) auto
      ultimately
      show "?f = val(H, ?h\<^sup>v)"
        using val_check g.one_in_G one_in_P generic by simp
    qed
    ultimately
    have "\<exists>r\<in>\<bbbP>. \<exists>h\<in>\<omega> \<rightarrow>\<^bsup>M\<^esup> B. r \<preceq> p \<and> r \<tturnstile> \<cdot>0 = 1\<cdot> [f_dot, h\<^sup>v]"
      by blast
  }
  moreover
  note \<open>B \<in> M\<close> assms
  moreover from calculation
  have "f : \<omega> \<rightarrow>\<^bsup>M\<^esup> B"
    using kunen_IV_6_9_function_space_rel_eq function_space_rel_char
      ext.mem_function_space_rel_abs by auto
  ultimately
  show ?thesis
    by (auto dest:transitivity)
qed

declare mono_seqspace_rel_closed[rule del]
  \<comment> \<open>Mysteriously breaks the end of the next proof\<close>

lemma succ_omega_closed_imp_no_new_reals:
  assumes "succ(\<omega>)-closed\<^bsup>M\<^esup>(\<bbbP>,leq)"
  shows "\<omega> \<rightarrow>\<^bsup>M\<^esup> 2 = \<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2"
proof -
  from assms
  have "\<omega> \<rightarrow>\<^bsup>M[G]\<^esup> 2 \<subseteq> \<omega> \<rightarrow>\<^bsup>M\<^esup> 2"
    using succ_omega_closed_imp_no_new_nat_sequences function_space_rel_char
      ext.function_space_rel_char Aleph_rel_succ Aleph_rel_zero
    by auto
  then
  show ?thesis
    using function_space_rel_transfer by (intro equalityI) auto
qed

lemma succ_omega_closed_imp_Aleph_1_preserved:
  assumes "succ(\<omega>)-closed\<^bsup>M\<^esup>(\<bbbP>,leq)"
  shows "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> = \<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup>"
proof -
  have "\<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup> \<le> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
  proof (rule ccontr)
    assume "\<not> \<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup> \<le> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"
    then
    have "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup> < \<aleph>\<^bsub>1\<^esub>\<^bsup>M[G]\<^esup>"
      \<comment> \<open>Ridiculously complicated proof\<close>
      using Card_rel_is_Ord ext.Card_rel_is_Ord
        not_le_iff_lt[THEN iffD1] by auto
    then
    have "|\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>|\<^bsup>M[G]\<^esup> \<le> \<omega>"
      using ext.Card_rel_lt_csucc_rel_iff ext.Aleph_rel_zero
        ext.Aleph_rel_succ ext.Card_rel_nat
      by (auto intro!:ext.lt_csucc_rel_iff[THEN iffD1]
          intro:Card_rel_Aleph_rel[THEN Card_rel_is_Ord, of 1])
    then
    obtain f where "f \<in> inj(\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>,\<omega>)" "f \<in> M[G]"
      using ext.countable_rel_iff_cardinal_rel_le_nat[of "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>", THEN iffD2]
      unfolding countable_rel_def lepoll_rel_def
      by auto
    then
    obtain g where "g \<in> surj\<^bsup>M[G]\<^esup>(\<omega>, \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>)"
      using ext.inj_rel_imp_surj_rel[of f _ \<omega>, OF _ zero_lt_Aleph_rel1[THEN ltD]]
      by auto
    moreover from this
    have "g : \<omega> \<rightarrow> \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>" "g \<in> M[G]"
      using ext.surj_rel_char surj_is_fun by simp_all
    moreover
    note \<open>succ(\<omega>)-closed\<^bsup>M\<^esup>(\<bbbP>,leq)\<close>
    ultimately
    have "g \<in> surj\<^bsup>M\<^esup>(\<omega>, \<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>)" "g \<in> M"
      using succ_omega_closed_imp_no_new_nat_sequences
        mem_surj_abs ext.mem_surj_abs by simp_all
    then
    show False
      using surj_rel_implies_cardinal_rel_le[of g \<omega> "\<aleph>\<^bsub>1\<^esub>\<^bsup>M\<^esup>"]
        Card_rel_nat[THEN Card_rel_cardinal_rel_eq] Card_rel_is_Ord
        not_le_iff_lt[THEN iffD2, OF _ _ nat_lt_Aleph_rel1]
      by simp
  qed
  then
  show ?thesis
    using Aleph_rel_le_Aleph_rel
    by (rule_tac le_anti_sym) simp
qed

end \<comment> \<open>bundle G\_generic1\_lemmas\<close>

end \<comment> \<open>\<^locale>\<open>G_generic3_AC\<close>\<close>

end


(*  Title:    HOL/Prolog/Test.thy
    Author:   David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
*)

section \<open>Basic examples\<close>

theory Test
imports HOHH
begin

typedecl nat

typedecl 'a list

consts
  Nil   :: "'a list"                                  ("[]")
  Cons  :: "'a => 'a list => 'a list"                 (infixr "#"  65)

syntax
  (* list Enumeration *)
  "_list"     :: "args => 'a list"                          ("[(_)]")

translations
  "[x, xs]"     == "x#[xs]"
  "[x]"         == "x#[]"

typedecl person

axiomatization
  append  :: "['a list, 'a list, 'a list]            => bool" and
  reverse :: "['a list, 'a list]                     => bool" and

  mappred :: "[('a => 'b => bool), 'a list, 'b list] => bool" and
  mapfun  :: "[('a => 'b), 'a list, 'b list]         => bool" and

  bob     :: person and
  sue     :: person and
  ned     :: person and

  nat23   :: nat          ("23") and
  nat24   :: nat          ("24") and
  nat25   :: nat          ("25") and

  age     :: "[person, nat]                          => bool" and

  eq      :: "['a, 'a]                               => bool" and

  empty   :: "['b]                                   => bool" and
  add     :: "['a, 'b, 'b]                           => bool" and
  remove  :: "['a, 'b, 'b]                           => bool" and
  bag_appl:: "['a, 'a, 'a, 'a]                       => bool"
where
        append:  "\<And>x xs ys zs. append  []    xs  xs    ..
                  append (x#xs) ys (x#zs) :- append xs ys zs" and
        reverse: "\<And>L1 L2. reverse L1 L2 :- (!rev_aux.
                  (!L.          rev_aux  []    L  L )..
                  (!X L1 L2 L3. rev_aux (X#L1) L2 L3 :- rev_aux L1 L2 (X#L3))
                  => rev_aux L1 L2 [])" and

        mappred: "\<And>x xs y ys P. mappred P  []     []    ..
                  mappred P (x#xs) (y#ys) :- P x y  &  mappred P xs ys" and
        mapfun:  "\<And>x xs ys f. mapfun f  []     []      ..
                  mapfun f (x#xs) (f x#ys) :- mapfun f xs ys" and

        age:     "age bob 24 ..
                  age sue 23 ..
                  age ned 23" and

        eq:      "\<And>x. eq x x" and

(* actual definitions of empty and add is hidden -> yields abstract data type *)

        bag_appl: "\<And>A B X Y. bag_appl A B X Y:- (? S1 S2 S3 S4 S5.
                                empty    S1    &
                                add A    S1 S2 &
                                add B    S2 S3 &
                                remove X S3 S4 &
                                remove Y S4 S5 &
                                empty    S5)"

lemmas prog_Test = append reverse mappred mapfun age eq bag_appl

schematic_goal "append ?x ?y [a,b,c,d]"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

schematic_goal "append [a,b] y ?L"
  apply (prolog prog_Test)
  done

schematic_goal "!y. append [a,b] y (?L y)"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [23] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse [23,24,?x] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "reverse ?L [23,24,?x]"
  apply (prolog prog_Test)
  done

schematic_goal "mappred age ?x [23,24]"
  apply (prolog prog_Test)
  back
  done

schematic_goal "mappred (%x y. ? z. age z y) ?x [23,24]"
  apply (prolog prog_Test)
  done

schematic_goal "mappred ?P [bob,sue] [24,23]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun f [bob,bob,sue] [?x,?y,?z]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun (%x. h x 25) [bob,sue] ?L"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun ?F [24,25] [h bob 24,h bob 25]"
  apply (prolog prog_Test)
  done

schematic_goal "mapfun ?F [24] [h 24 24]"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "True"
  apply (prolog prog_Test)
  done

schematic_goal "age ?x 24 & age ?y 23"
  apply (prolog prog_Test)
  back
  done

schematic_goal "age ?x 24 | age ?x 23"
  apply (prolog prog_Test)
  back
  back
  done

lemma "? x y. age x y"
  apply (prolog prog_Test)
  done

lemma "!x y. append [] x x"
  apply (prolog prog_Test)
  done

schematic_goal "age sue 24 .. age bob 23 => age ?x ?y"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

(*set trace_DEPTH_FIRST;*)
lemma "age bob 25 :- age bob 24 => age bob 25"
  apply (prolog prog_Test)
  done
(*reset trace_DEPTH_FIRST;*)

schematic_goal "(!x. age x 25 :- age x 23) => age ?x 25 & age ?y 25"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "!x. ? y. eq x y"
  apply (prolog prog_Test)
  done

schematic_goal "? P. P & eq P ?x"
  apply (prolog prog_Test)
(*
  back
  back
  back
  back
  back
  back
  back
  back
*)
  done

lemma "? P. eq P (True & True) & P"
  apply (prolog prog_Test)
  done

lemma "? P. eq P op | & P k True"
  apply (prolog prog_Test)
  done

lemma "? P. eq P (Q => True) & P"
  apply (prolog prog_Test)
  done

(* P flexible: *)
lemma "(!P k l. P k l :- eq P Q) => Q a b"
  apply (prolog prog_Test)
  done
(*
loops:
lemma "(!P k l. P k l :- eq P (%x y. x | y)) => a | b"
*)

(* implication and disjunction in atom: *)
lemma "? Q. (!p q. R(q :- p) => R(Q p q)) & Q (t | s) (s | t)"
  by fast

(* disjunction in atom: *)
lemma "(!P. g P :- (P => b | a)) => g(a | b)"
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
   prefer 2
   apply fast
  apply fast
  done

(*
hangs:
lemma "(!P. g P :- (P => b | a)) => g(a | b)"
  by fast
*)

schematic_goal "!Emp Stk.(
                       empty    (Emp::'b) ..
         (!(X::nat) S. add    X (S::'b)         (Stk X S)) ..
         (!(X::nat) S. remove X ((Stk X S)::'b) S))
 => bag_appl 23 24 ?X ?Y"
  oops

schematic_goal "!Qu. (
          (!L.            empty    (Qu L L)) ..
          (!(X::nat) L K. add    X (Qu L (X#K)) (Qu L K)) ..
          (!(X::nat) L K. remove X (Qu (X#L) K) (Qu L K)))
 => bag_appl 23 24 ?X ?Y"
  oops

lemma "D & (!y. E) :- (!x. True & True) :- True => D"
  apply (prolog prog_Test)
  done

schematic_goal "P x .. P y => P ?X"
  apply (prolog prog_Test)
  back
  done

end


theory IMP_Minus_To_SAS_Plus_Nat imports
  Primitives IMP_Minus_To_SAS_Plus IMP_Minus_Max_Constant_Nat
  IMP_Minus_To_IMP_Minus_Minus_nat SAS_Plus_Plus_To_SAS_Plus_Nat
  IMP_Minus_Minus_To_SAS_Plus_Plus_Reduction_Nat

begin

definition max_input_bits_list :: "IMP_Minus_com \<Rightarrow> (vname,nat) assignment list \<Rightarrow> nat \<Rightarrow> nat" where
" max_input_bits_list c I r =
 bit_length (max (max (max_list (ran_list I)) r) (max_constant c)) "

definition max_input_bits_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat\<Rightarrow> nat" where
"max_input_bits_nat c I r =
bit_length (max (max (max_list_nat (ran_nat I)) r) (max_constant_nat c))"

definition max_input_bits_tail :: "nat \<Rightarrow> nat \<Rightarrow> nat\<Rightarrow> nat" where
"max_input_bits_tail c I r =
bit_length (max (max (max_list_tail (ran_tail I)) r) (max_constant_tail c))"

lemma subtail_max_input_bits:
"max_input_bits_tail c I r = max_input_bits_nat c I r "
  using max_constant_tail_def max_input_bits_nat_def max_input_bits_tail_def
 subtail_max_list subtail_ran by presburger

lemma impm_assignment_simp:"impm_assignment_encode = prod_encode o (\<lambda>(a,b). (vname_encode a,b))"
  apply auto
  done
lemma sublist_max_input_bits:
  assumes "I \<noteq> []"
  shows " max_input_bits_list c I r =  max_input_bits c (map_of I) r"
  using assms ran_list_pre apply (auto simp only: max_input_bits_list_def  max_input_bits_def  simp flip:sub_ran_list  )
  using sub_max_list  by fastforce

lemma subnat_max_input_bits: " max_input_bits_nat (com_encode c)
(impm_assignment_list_encode  I) r = max_input_bits_list c I r"
  using vname_inj
  apply (auto simp only:max_input_bits_nat_def sub_ran_nat impm_assignment_list_encode_def
 impm_assignment_simp sub_max_list_nat sub_max_constant ran_inj max_input_bits_list_def simp flip: map_map
)
  done

definition IMP_Minus_initial_to_IMP_Minus_Minus:: "(vname \<rightharpoonup> nat)
  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (vname \<rightharpoonup> bit)" where
"IMP_Minus_initial_to_IMP_Minus_Minus I n guess_range = (\<lambda>v.
  (case var_to_operand_bit v of
    Some (CHR ''a'', k) \<Rightarrow> if k < n then Some Zero else None |
    Some (CHR ''b'', k) \<Rightarrow> if k < n then Some Zero else None |
    _ \<Rightarrow> (if v = ''carry'' then Some Zero
  else (IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range) v)))"

definition IMP_Minus_initial_to_IMP_Minus_Minus_list:: "(vname, nat) assignment list
  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> vname \<Rightarrow> bit option" where
"IMP_Minus_initial_to_IMP_Minus_Minus_list I n guess_range v =
  (case var_to_operand_bit v of
    Some (CHR ''a'', k) \<Rightarrow> if k < n then Some Zero else None |
    Some (CHR ''b'', k) \<Rightarrow> if k < n then Some Zero else None |
    _ \<Rightarrow> (if v = ''carry'' then Some Zero
  else (IMP_Minus_State_To_IMP_Minus_Minus_partial_list I n guess_range) v))"

lemma sublist_IMP_Minus_initial_to_IMP_Minus_Minus:
"IMP_Minus_initial_to_IMP_Minus_Minus (map_of I) n guess_range v =
IMP_Minus_initial_to_IMP_Minus_Minus_list I n guess_range v"
  apply (auto simp only:IMP_Minus_initial_to_IMP_Minus_Minus_def
sublist_IMP_Minus_State_To_IMP_Minus_Minus_partial
IMP_Minus_initial_to_IMP_Minus_Minus_list_def
)
  done

definition IMP_Minus_initial_to_IMP_Minus_Minus_nat::" nat
  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"IMP_Minus_initial_to_IMP_Minus_Minus_nat I n guess_range v =
  (let p = var_to_operand_bit_nat v; v' = fst_nat (p-1) ; k = snd_nat (p-1) in if
    p \<noteq> 0 \<and> v' = encode_char (CHR ''a'') then
    if k < n then Suc 0 else 0 else if  p \<noteq> 0 \<and> v' = encode_char (CHR ''b'')
   then if k < n then Suc 0 else 0
 else (if v = vname_encode ''carry'' then Suc 0
  else (IMP_Minus_State_To_IMP_Minus_Minus_partial_nat I n guess_range) v))"

definition IMP_Minus_initial_to_IMP_Minus_Minus_tail::" nat
  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"IMP_Minus_initial_to_IMP_Minus_Minus_tail I n guess_range v =
  (let p = var_to_operand_bit_tail v; v' = fst_nat (p-1) ; k = snd_nat (p-1) in if
    p \<noteq> 0 \<and> v' = encode_char (CHR ''a'') then
    if k < n then Suc 0 else 0 else if  p \<noteq> 0 \<and> v' = encode_char (CHR ''b'')
   then if k < n then Suc 0 else 0
 else (if v = vname_encode ''carry'' then Suc 0
  else (IMP_Minus_State_To_IMP_Minus_Minus_partial_tail I n guess_range) v))"

lemma subtail_IMP_Minus_initial_to_IMP_Minus_Minus:
"IMP_Minus_initial_to_IMP_Minus_Minus_tail I n guess_range v =
IMP_Minus_initial_to_IMP_Minus_Minus_nat I n guess_range v"
  using IMP_Minus_initial_to_IMP_Minus_Minus_nat_def IMP_Minus_initial_to_IMP_Minus_Minus_tail_def
subtail_IMP_Minus_State_To_IMP_Minus_Minus_partial subtail_var_to_operand_bit by presburger

lemma subnat_IMP_Minus_initial_to_IMP_Minus_Minus:
"IMP_Minus_initial_to_IMP_Minus_Minus_nat (impm_assignment_list_encode I) n guess_range
(vname_encode v) =

bit_option_encode (IMP_Minus_initial_to_IMP_Minus_Minus_list I n guess_range v)"
  apply (cases "var_to_operand_bit
        v")
  apply (auto simp add: IMP_Minus_initial_to_IMP_Minus_Minus_nat_def vname_inj_simp Let_def
     sub_var_to_operand_bit  char_nat_option_encode_0 char_inj_simp sub_snd sub_fst
IMP_Minus_initial_to_IMP_Minus_Minus_list_def subnat_IMP_Minus_State_To_IMP_Minus_Minus_partial)
   apply (smt char.case char.exhaust)
  apply (smt char.case char.exhaust)
  done

definition IMP_Minus_to_SAS_Plus_list:: "IMP_Minus_com \<Rightarrow> (vname, nat) assignment list \<Rightarrow> nat \<Rightarrow> (vname, nat) assignment list
  \<Rightarrow>  nat \<Rightarrow> (var,dom) sas_plus_list_problem" where
"IMP_Minus_to_SAS_Plus_list c I r G t = (let
  guess_range = max_input_bits_list c I r;
  n = t + guess_range + 1;
  c' = IMP_Minus_To_IMP_Minus_Minus c n;
  I' =
map (\<lambda>(x,y). (x, the y)) (filter (\<lambda>(x,y) . y \<noteq> None) (map (\<lambda>x. (x,IMP_Minus_State_To_IMP_Minus_Minus_partial_list I n guess_range x)) (enumerate_variables c')))
;

  G' = map (\<lambda>(x,y). (x, the y)) (filter (\<lambda>(x,y) . y \<noteq> None) (map (\<lambda>x. (x,IMP_Minus_State_To_IMP_Minus_Minus_partial_list G n n x)) (enumerate_variables c')))
 in
  SAS_Plus_Plus_To_SAS_Plus_list (imp_minus_minus_to_sas_plus_list c' I' G'))"

lemma sublist_IMP_Minus_to_SAS_Plus:
  assumes "I \<noteq> []"
  shows
" list_problem_to_problem ( IMP_Minus_to_SAS_Plus_list c I r G t)
= IMP_Minus_to_SAS_Plus c (map_of I) r (map_of G) t "
  apply (auto simp only:  IMP_Minus_to_SAS_Plus_list_def
        IMP_Minus_to_SAS_Plus_def Let_def  sublist_imp_minus_minus_to_sas_plus
sublist_SAS_Plus_Plus_To_SAS_Plus
sub_restrict

 )
  using assms
  apply (auto simp add: sublist_max_input_bits sublist_IMP_Minus_State_To_IMP_Minus_Minus_partial
simp flip:sublist_IMP_Minus_initial_to_IMP_Minus_Minus)
  done

fun map_IMP_Minus_initial_to_IMP_Minus_Minus:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_IMP_Minus_initial_to_IMP_Minus_Minus I n guess_range x  =(if x = 0 then 0 else (prod_encode(hd_nat x, IMP_Minus_initial_to_IMP_Minus_Minus_nat I n guess_range (hd_nat x)))## map_IMP_Minus_initial_to_IMP_Minus_Minus I n guess_range (tl_nat x))"

lemma submap_IMP_Minus_initial_to_IMP_Minus_Minus:
"map_IMP_Minus_initial_to_IMP_Minus_Minus I n guess_range x = map_nat (\<lambda>x. prod_encode(x, IMP_Minus_initial_to_IMP_Minus_Minus_nat I n guess_range x))x"
  apply (induct I n guess_range  x rule:map_IMP_Minus_initial_to_IMP_Minus_Minus.induct)
  apply auto
  done

fun map_IMP_Minus_State_To_IMP_Minus_Minus_partial :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range x = (if x =0 then 0 else
( prod_encode(hd_nat x,IMP_Minus_State_To_IMP_Minus_Minus_partial_nat I n guess_range (hd_nat x)))## map_IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range (tl_nat x) )"

lemma submap_IMP_Minus_State_To_IMP_Minus_Minus_partial :
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range x = map_nat (\<lambda>x. prod_encode(x,IMP_Minus_State_To_IMP_Minus_Minus_partial_nat I n guess_range x)) x "
  apply(induct I  n guess_range x rule: map_IMP_Minus_State_To_IMP_Minus_Minus_partial.induct)
  apply auto
  done
fun map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc acc I n guess_range x = (if x =0 then acc else  map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc (
( prod_encode(hd_nat x,IMP_Minus_State_To_IMP_Minus_Minus_partial_nat I n guess_range (hd_nat x)))## acc) I n guess_range (tl_nat x) )"

lemma map_IMP_Minus_State_To_IMP_Minus_Minus_partial_induct:
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc acc  I n guess_range x =
 map_acc (\<lambda>x. prod_encode(x,IMP_Minus_State_To_IMP_Minus_Minus_partial_nat I n guess_range x)) acc x  "
  apply(induct acc I n guess_range x rule: map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc.induct)
  apply auto
  done

definition map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail ::"nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail   I n guess_range x =
reverse_nat (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_acc 0  I n guess_range x)  "

lemma subtail_map_IMP_Minus_State_To_IMP_Minus_Minus_partial:
"map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail   I n guess_range x =
map_IMP_Minus_State_To_IMP_Minus_Minus_partial   I n guess_range x "
  using IMP_Minus_To_SAS_Plus_Nat.map_IMP_Minus_State_To_IMP_Minus_Minus_partial_induct
IMP_Minus_To_SAS_Plus_Nat.map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail_def
 IMP_Minus_To_SAS_Plus_Nat.submap_IMP_Minus_State_To_IMP_Minus_Minus_partial
subtail_map by presburger

fun filter_none :: "nat \<Rightarrow> nat" where
"filter_none n = (if n =0 then 0 else if snd_nat (hd_nat n) \<noteq> 0 then (hd_nat n) ## (filter_none (tl_nat n)) else filter_none (tl_nat n))"

fun filter_none_acc :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"filter_none_acc acc n = (if n =0 then acc else if snd_nat (hd_nat n) \<noteq> 0 then filter_none_acc ((hd_nat n) ## acc) (tl_nat n) else filter_none_acc acc (tl_nat n))"

lemma subfilter_none :
"filter_none n = filter_nat (\<lambda>n . snd_nat n \<noteq> 0) n"
  apply (induct n rule: filter_none.induct)
  apply auto
  done
lemma filter_none_induct :
"filter_none_acc acc n = filter_acc (\<lambda>n . snd_nat n \<noteq> 0) acc n"
  apply(induct acc n rule:filter_none_acc.induct)
  apply auto
  done

definition filter_none_tail :: "nat \<Rightarrow> nat" where
"filter_none_tail n = reverse_nat (filter_none_acc 0 n)"

lemma subtail_filter_none:
"filter_none_tail n = filter_none n"
  using filter_none_induct filter_none_tail_def subfilter_none subtail_filter by presburger

fun map_prod_the :: "nat \<Rightarrow> nat" where
"map_prod_the n = (if n = 0 then 0 else (prod_encode(fst_nat (hd_nat n), the_nat (snd_nat (hd_nat n)))) ## map_prod_the(tl_nat n) )"

lemma submap_prod_the:
"map_prod_the n = map_nat (\<lambda>n. prod_encode(fst_nat n, the_nat (snd_nat n))) n"
  apply (induct n rule:map_prod_the.induct)
  apply auto
  done

fun map_prod_the_acc :: "nat\<Rightarrow> nat \<Rightarrow> nat" where
"map_prod_the_acc acc n = (if n = 0 then acc else map_prod_the_acc ( (prod_encode(fst_nat (hd_nat n), the_nat (snd_nat (hd_nat n)))) ## acc) (tl_nat n) )"

lemma map_prod_the_induct:
"map_prod_the_acc acc n = map_acc (\<lambda>n. prod_encode(fst_nat n, the_nat (snd_nat n))) acc n "
  apply(induct acc n rule:map_prod_the_acc.induct)
  apply auto
  done

definition map_prod_the_tail :: "nat \<Rightarrow> nat" where
"map_prod_the_tail n = reverse_nat (map_prod_the_acc 0 n)"

lemma subtail_map_prod_the:
"map_prod_the_tail n = map_prod_the n"
  using map_prod_the_induct map_prod_the_tail_def submap_prod_the subtail_map by presburger

definition IMP_Minus_to_SAS_Plus_nat:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat
  \<Rightarrow>  nat \<Rightarrow> nat" where
"IMP_Minus_to_SAS_Plus_nat c I r G t = (let
  guess_range = max_input_bits_nat c I r;
  n = t + guess_range + 1;
  c' = IMP_Minus_To_IMP_Minus_Minus_nat c n;
  I' =
map_prod_the (filter_none (map_IMP_Minus_State_To_IMP_Minus_Minus_partial I n guess_range (enumerate_variables_nat c')))
;

  G' = map_prod_the (filter_none (map_IMP_Minus_State_To_IMP_Minus_Minus_partial G n n (enumerate_variables_nat c')))
 in
  SAS_Plus_Plus_To_SAS_Plus_nat (imp_minus_minus_to_sas_plus_nat c' I' G'))"

definition IMP_Minus_to_SAS_Plus_tail:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat
  \<Rightarrow>  nat \<Rightarrow> nat" where
"IMP_Minus_to_SAS_Plus_tail c I r G t = (let
  guess_range = max_input_bits_tail c I r;
  n = t + guess_range + 1;
  c' = IMP_Minus_To_IMP_Minus_Minus_tail c n;
  I' =
map_prod_the_tail (filter_none_tail (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail I n guess_range (enumerate_variables_tail c')))
;

  G' = map_prod_the_tail (filter_none_tail (map_IMP_Minus_State_To_IMP_Minus_Minus_partial_tail G n n (enumerate_variables_tail c')))
 in
  SAS_Plus_Plus_To_SAS_Plus_tail (imp_minus_minus_to_sas_plus_tail c' I' G'))"

lemma subtail_IMP_Minus_to_SAS_Plus:
"IMP_Minus_to_SAS_Plus_tail c I r G t = IMP_Minus_to_SAS_Plus_nat c I r G t "
  using IMP_Minus_To_IMP_Minus_Minus_tail_def
 IMP_Minus_To_SAS_Plus_Nat.subtail_map_IMP_Minus_State_To_IMP_Minus_Minus_partial
IMP_Minus_to_SAS_Plus_nat_def IMP_Minus_to_SAS_Plus_tail_def subtail_SAS_Plus_Plus_To_SAS_Plus
subtail_enumerate_variables subtail_filter_none subtail_imp_minus_minus_to_sas_plus
 subtail_map_prod_the subtail_max_input_bits by presburger

lemma thef_bit_option_lambda:"
map (\<lambda>x. prod_encode
                     (vname_encode x,
                      thefn
                       (bit_option_to_option
                         (ff x))))
           (filter
             (\<lambda>x. ff x \<noteq>
                   None)
xs)
=
map (\<lambda>x. prod_encode
                     (vname_encode x,
                      bit_encode ( the
                         (ff x))))
           (filter
             (\<lambda>x. ff x \<noteq>
                   None)
xs)

"
  apply (induct xs)
   apply auto
  done

lemma subnat_IMP_Minus_to_SAS_Plus:
"IMP_Minus_to_SAS_Plus_nat (com_encode c) (impm_assignment_list_encode I) r (impm_assignment_list_encode G) t
=  list_problem_plus_encode (IMP_Minus_to_SAS_Plus_list c I r G t) "
  apply (auto simp only:IMP_Minus_to_SAS_Plus_nat_def submap_IMP_Minus_State_To_IMP_Minus_Minus_partial
          submap_IMP_Minus_initial_to_IMP_Minus_Minus  submap_prod_the  subfilter_none
         subnat_max_input_bits sub_IMP_Minus_To_IMP_Minus_Minus Let_def
                sub_enumerate_variables vname_list_encode_def sub_map map_map
filter_map sub_fst fst_def sub_snd snd_def
comp_def sub_filter  subnat_SAS_Plus_Plus_To_SAS_Plus
IMP_Minus_to_SAS_Plus_list_def
subnat_IMP_Minus_State_To_IMP_Minus_Minus_partial
bit_option_encode_0 sub_the
subnat_imp_minus_minus_to_sas_plus
subnat_IMP_Minus_initial_to_IMP_Minus_Minus
 subnat_IMP_Minus_initial_to_IMP_Minus_Minus
)
  apply (auto simp only: bit_option_encode_simps comp_def sub_the2

 thef_bit_option_lambda

imp_assignment_list_encode_def

 simp flip: imp_assignment_encode.simps)
  apply (auto simp only:
subnat_SAS_Plus_Plus_To_SAS_Plus
 subnat_imp_minus_minus_to_sas_plus simp flip:comp_def[of imp_assignment_encode "\<lambda>x.(x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list I
(t + max_input_bits_list c I r + 1)
(max_input_bits_list c I r)
                                x))" ]
comp_def[of imp_assignment_encode "\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list G
                               (t + max_input_bits_list c I r + 1)
                               (t + max_input_bits_list c I r + 1) x))" ]

 map_map
imp_assignment_list_encode_def
)
proof -
  let ?P = "imp_minus_minus_to_sas_plus_list (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list I
                              (t + max_input_bits_list c I r + 1) (max_input_bits_list c I r) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list I (t + max_input_bits_list c I r + 1)
                    (max_input_bits_list c I r) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1)))))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list G
                              (t + max_input_bits_list c I r + 1) (t + max_input_bits_list c I r + 1) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list G (t + max_input_bits_list c I r + 1)
                    (t + max_input_bits_list c I r + 1) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1)))))"
  have "is_valid_problem_sas_plus_plus (list_problem_to_problem ?P)"
    by (auto simp only:sublist_imp_minus_minus_to_sas_plus  imp_minus_minus_to_sas_plus_valid)
  thus " SAS_Plus_Plus_To_SAS_Plus_nat
     (list_problem_encode
       (imp_minus_minus_to_sas_plus_list (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list I
                              (t + max_input_bits_list c I r + 1) (max_input_bits_list c I r) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list I (t + max_input_bits_list c I r + 1)
                    (max_input_bits_list c I r) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1)))))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list G
                              (t + max_input_bits_list c I r + 1) (t + max_input_bits_list c I r + 1) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list G (t + max_input_bits_list c I r + 1)
                    (t + max_input_bits_list c I r + 1) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1))))))) =
    list_problem_plus_encode
     (SAS_Plus_Plus_To_SAS_Plus_list
       (imp_minus_minus_to_sas_plus_list (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list I
                              (t + max_input_bits_list c I r + 1) (max_input_bits_list c I r) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list I (t + max_input_bits_list c I r + 1)
                    (max_input_bits_list c I r) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1)))))
         (map (\<lambda>x. (x, the (IMP_Minus_State_To_IMP_Minus_Minus_partial_list G
                              (t + max_input_bits_list c I r + 1) (t + max_input_bits_list c I r + 1) x)))
           (filter
             (\<lambda>x. IMP_Minus_State_To_IMP_Minus_Minus_partial_list G (t + max_input_bits_list c I r + 1)
                    (t + max_input_bits_list c I r + 1) x \<noteq>
                   None)
             (enumerate_variables (IMP_Minus_To_IMP_Minus_Minus c (t + max_input_bits_list c I r + 1)))))))"
    by (auto simp only: subnat_SAS_Plus_Plus_To_SAS_Plus)
qed

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

header {* \isaheader{Lifting the Typing Framework to err, app, and eff} *}

theory Typing_Framework_err
imports
  Typing_Framework
  SemilatAlg
begin

definition wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
where
  "wt_err_step r step \<tau>s \<longleftrightarrow> wt_step (Err.le r) Err step \<tau>s"

definition wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
where
  "wt_app_eff r app step \<tau>s \<longleftrightarrow>
    (\<forall>p < size \<tau>s. app p (\<tau>s!p) \<and> (\<forall>(q,\<tau>) \<in> set (step p (\<tau>s!p)). \<tau> <=_r \<tau>s!q))"

definition map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
where
  "map_snd f = map (\<lambda>(x,y). (x, f y))"

definition error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
where
  "error n = map (\<lambda>x. (x,Err)) [0..<n]"

definition err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
where
  "err_step n app step p t =
  (case t of
    Err   \<Rightarrow> error n
  | OK \<tau> \<Rightarrow> if app p \<tau> then map_snd OK (step p \<tau>) else error n)"

definition app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "app_mono r app n A \<longleftrightarrow>
    (\<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> app p s)"

lemmas err_step_defs = err_step_def map_snd_def error_def

lemma bounded_err_stepD:
  "\<lbrakk> bounded (err_step n app step) n;
     p < n; app p a; (q,b) \<in> set (step p a) \<rbrakk> \<Longrightarrow> q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)

lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)

lemma bounded_err_stepI:
  "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
  \<Longrightarrow> bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)

lemma bounded_lift:
  "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac \<tau>)
  apply (auto simp add: map_snd_def split: split_if_asm)
  done
(*>*)

lemma le_list_map_OK [simp]:
  "\<And>b. (map OK a [\<sqsubseteq>\<^bsub>Err.le r\<^esub>] map OK b) = (a [\<sqsubseteq>\<^sub>r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)

lemma map_snd_lessI:
  "set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys \<Longrightarrow> set (map_snd OK xs) {\<sqsubseteq>\<^bsub>Err.le r\<^esub>} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)

lemma mono_lift:
  "\<lbrakk> order r; app_mono r app n A; bounded (err_step n app step) n;
    \<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t) \<rbrakk>
  \<Longrightarrow>  mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (unfold app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac \<tau>)
 apply simp
apply simp
apply (case_tac \<tau>')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
(*>*)

lemma in_errorD: "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
  \<Longrightarrow> pres_type (err_step n app step) n (err A)"
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac \<tau>)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: split_if_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)

lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)
    assume "\<not> app p (map ok_val ts ! p)"
    with OKp lp have "\<not> app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
      by (simp add: err_step_def)
    with err ts obtain q where
      "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q \<noteq> Err" ..
    ultimately show False by blast
  qed

  show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
  proof clarify
    fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q \<noteq> Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  qed
qed
(*>*)

lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)"
  hence p: "p < size ts" by simp
  thus "map OK ts ! p \<noteq> Err" by simp
  { fix q t
    assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
    with p app_eff obtain
      "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t \<sqsubseteq>\<^sub>r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately
    have "t \<sqsubseteq>\<^bsub>Err.le r\<^esub> map OK ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end