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

    Copyright (C) 2005-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>ZF set theory basics\<close>

theory ZF1 imports ZF.Perm

begin

text\<open>The standard Isabelle distribution contains lots of facts about basic set
  theory. This theory file adds some more.\<close>

subsection\<open>Lemmas in Zermelo-Fraenkel set theory\<close>

text\<open>Here we put lemmas from the set theory that we could not find in
  the standard Isabelle distribution or just so that they are easier to find.\<close>

text\<open>A set cannot be a member of itself. This is exactly lemma \<open>mem_not_refl\<close>
  from Isabelle/ZF \<open>upair.thy\<close>, we put it here for easy reference. \<close>

lemma mem_self: shows "x\<notin>x" by (rule mem_not_refl)

text\<open>If one collection is contained in another, then we can say the same
  about their unions.\<close>

lemma collection_contain: assumes "A\<subseteq>B" shows "\<Union>A \<subseteq> \<Union>B"
proof
  fix x assume "x \<in> \<Union>A"
  then obtain X where "x\<in>X" and "X\<in>A" by auto
  with assms show "x \<in> \<Union>B" by auto
qed

text\<open>If all sets of a nonempty collection are the same, then its union
  is the same.\<close>

lemma ZF1_1_L1: assumes "C\<noteq>0" and "\<forall>y\<in>C. b(y) = A"
  shows "(\<Union>y\<in>C. b(y)) = A" using assms by blast

text\<open>The union af all values of a constant meta-function belongs to
the same set as the constant.\<close>

lemma ZF1_1_L2: assumes A1:"C\<noteq>0" and A2: "\<forall>x\<in>C. b(x) \<in> A"
  and A3: "\<forall>x y. x\<in>C \<and> y\<in>C \<longrightarrow> b(x) = b(y)"
  shows "(\<Union>x\<in>C. b(x))\<in>A"
proof -
  from A1 obtain x where D1: "x\<in>C" by auto
  with A3 have "\<forall>y\<in>C. b(y) = b(x)" by blast
  with A1 have "(\<Union>y\<in>C. b(y)) = b(x)"
    using ZF1_1_L1 by simp
  with D1 A2 show ?thesis by simp
qed

text\<open>If two meta-functions are the same on a cartesian product,
  then the subsets defined by them are the same. I am surprised Isabelle
  can not handle this automatically.\<close>

lemma ZF1_1_L4: assumes A1: "\<forall>x\<in>X.\<forall>y\<in>Y. a(x,y) = b(x,y)"
  shows "{a(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y} = {b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y}"
proof
  show "{a(x, y). \<langle>x,y\<rangle> \<in> X \<times> Y} \<subseteq> {b(x, y). \<langle>x,y\<rangle> \<in> X \<times> Y}"
  proof
    fix z assume "z \<in> {a(x, y) . \<langle>x,y\<rangle> \<in> X \<times> Y}"
    with A1 show  "z \<in> {b(x,y).\<langle>x,y\<rangle> \<in> X\<times>Y}" by auto
  qed
  show "{b(x, y). \<langle>x,y\<rangle> \<in> X \<times> Y} \<subseteq> {a(x, y). \<langle>x,y\<rangle> \<in> X \<times> Y}"
  proof
    fix z assume "z \<in> {b(x, y). \<langle>x,y\<rangle> \<in> X \<times> Y}"
    with A1 show "z \<in> {a(x,y).\<langle>x,y\<rangle> \<in> X\<times>Y}" by auto
  qed
qed

text\<open>If two meta-functions are the same on a cartesian product,
  then the subsets defined by them are the same.
  This is similar to \<open>ZF1_1_L4\<close>, except that
  the set definition varies over \<open>p\<in>X\<times>Y\<close> rather than
  \<open>\<langle> x,y\<rangle>\<in>X\<times>Y\<close>.\<close>

lemma ZF1_1_L4A: assumes A1: "\<forall>x\<in>X.\<forall>y\<in>Y. a(\<langle> x,y\<rangle>) = b(x,y)"
  shows "{a(p). p \<in> X\<times>Y} = {b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y}"
proof
  { fix z assume "z \<in> {a(p). p\<in>X\<times>Y}"
    then obtain p where D1: "z=a(p)" "p\<in>X\<times>Y" by auto
    let ?x = "fst(p)" let ?y = "snd(p)"
    from A1 D1 have "z \<in> {b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y}" by auto
  } then show "{a(p). p \<in> X\<times>Y} \<subseteq> {b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y}" by blast
next
  { fix z assume "z \<in> {b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y}"
    then obtain x y where D1: "\<langle>x,y\<rangle> \<in> X\<times>Y" "z=b(x,y)" by auto
    let ?p = "\<langle> x,y\<rangle>"
    from A1 D1 have "?p\<in>X\<times>Y" "z = a(?p)" by auto
    then have "z \<in> {a(p). p \<in> X\<times>Y}" by auto
  } then show "{b(x,y). \<langle>x,y\<rangle> \<in> X\<times>Y} \<subseteq> {a(p). p \<in> X\<times>Y}" by blast
qed

text\<open>A lemma about inclusion in cartesian products. Included here to remember
  that we need the $U\times V \neq \emptyset$ assumption.\<close>

lemma prod_subset: assumes "U\<times>V\<noteq>0" "U\<times>V \<subseteq> X\<times>Y" shows "U\<subseteq>X" and "V\<subseteq>Y"
  using assms by auto

text\<open>A technical lemma about sections in cartesian products.\<close>

lemma section_proj: assumes "A \<subseteq> X\<times>Y" and "U\<times>V \<subseteq> A" and "x \<in> U"  "y \<in> V"
  shows "U \<subseteq> {t\<in>X. \<langle>t,y\<rangle> \<in> A}" and "V \<subseteq> {t\<in>Y. \<langle>x,t\<rangle> \<in> A}"
  using assms by auto

text\<open>If two meta-functions are the same on a set, then they define the same
  set by separation.\<close>

lemma ZF1_1_L4B: assumes "\<forall>x\<in>X. a(x) = b(x)"
  shows "{a(x). x\<in>X} = {b(x). x\<in>X}"
  using assms by simp

text\<open>A set defined by a constant meta-function is a singleton.\<close>

lemma ZF1_1_L5: assumes "X\<noteq>0" and "\<forall>x\<in>X. b(x) = c"
  shows "{b(x). x\<in>X} = {c}" using assms by blast

text\<open>Most of the time, \<open>auto\<close> does this job, but there are strange
  cases when the next lemma is needed.\<close>

lemma subset_with_property: assumes "Y = {x\<in>X. b(x)}"
  shows "Y \<subseteq> X"
  using assms by auto

text\<open>We can choose an element from a nonempty set.\<close>

lemma nonempty_has_element: assumes "X\<noteq>0" shows "\<exists>x. x\<in>X"
  using assms by auto

(*text{*If after removing an element from a set we get an empty set,
  then this set must be a singleton.*}

lemma rem_point_empty: assumes "a\<in>A" and "A-{a} = 0"
  shows "A = {a}" using assms by auto; *)

text\<open>In Isabelle/ZF the intersection of an empty family is
  empty. This is exactly lemma \<open>Inter_0\<close> from Isabelle's
  \<open>equalities\<close> theory. We repeat this lemma here as it is very
  difficult to find. This is one reason we need comments before every
  theorem: so that we can search for keywords.\<close>

lemma inter_empty_empty: shows "\<Inter>0 = 0" by (rule Inter_0)

text\<open>If an intersection of a collection is not empty, then the collection is
  not empty. We are (ab)using the fact the the intersection of empty collection
  is defined to be empty.\<close>

lemma inter_nempty_nempty: assumes "\<Inter>A \<noteq> 0" shows "A\<noteq>0"
  using assms by auto

text\<open>For two collections $S,T$ of sets we define the product collection
  as the collections of cartesian products $A\times B$, where $A\in S, B\in T$.\<close>

definition
  "ProductCollection(T,S) \<equiv> \<Union>U\<in>T.{U\<times>V. V\<in>S}"

text\<open>The union of the product collection of collections $S,T$ is the
  cartesian product of $\bigcup S$ and  $\bigcup T$.\<close>

lemma ZF1_1_L6: shows "\<Union> ProductCollection(S,T) = \<Union>S \<times> \<Union>T"
  using ProductCollection_def by auto

text\<open>An intersection of subsets is a subset.\<close>

lemma ZF1_1_L7: assumes A1: "I\<noteq>0" and A2: "\<forall>i\<in>I. P(i) \<subseteq> X"
  shows "( \<Inter>i\<in>I. P(i) ) \<subseteq> X"
proof -
  from A1 obtain i\<^sub>0 where "i\<^sub>0 \<in> I" by auto
  with A2 have "( \<Inter>i\<in>I. P(i) ) \<subseteq> P(i\<^sub>0)" and "P(i\<^sub>0) \<subseteq> X"
    by auto
  thus "( \<Inter>i\<in>I. P(i) ) \<subseteq> X" by auto
qed

text\<open>Isabelle/ZF has a "THE" construct that allows to define an element
  if there is only one such that is satisfies given predicate.
  In pure ZF we can express something similar using the indentity proven below.\<close>

lemma ZF1_1_L8: shows "\<Union> {x} = x" by auto

text\<open>Some properties of singletons.\<close>

lemma ZF1_1_L9: assumes A1: "\<exists>! x. x\<in>A \<and> \<phi>(x)"
  shows
  "\<exists>a. {x\<in>A. \<phi>(x)} = {a}"
  "\<Union> {x\<in>A. \<phi>(x)} \<in> A"
  "\<phi>(\<Union> {x\<in>A. \<phi>(x)})"
proof -
  from A1 show "\<exists>a. {x\<in>A. \<phi>(x)} = {a}" by auto
  then obtain a where I: "{x\<in>A. \<phi>(x)} = {a}" by auto
  then have "\<Union> {x\<in>A. \<phi>(x)} = a" by auto
  moreover
  from I have "a \<in> {x\<in>A. \<phi>(x)}" by simp
  hence "a\<in>A" and "\<phi>(a)" by auto
  ultimately show "\<Union> {x\<in>A. \<phi>(x)} \<in> A" and "\<phi>(\<Union> {x\<in>A. \<phi>(x)})"
    by auto
qed

text\<open>A simple version of \<open> ZF1_1_L9\<close>.\<close>

corollary singleton_extract: assumes  "\<exists>! x. x\<in>A"
  shows "(\<Union> A) \<in> A"
proof -
  from assms have "\<exists>! x. x\<in>A \<and> True" by simp
  then have "\<Union> {x\<in>A. True} \<in> A" by (rule ZF1_1_L9)
  thus "(\<Union> A) \<in> A" by simp
qed

text\<open>A criterion for when a set defined by comprehension is a singleton.\<close>

lemma singleton_comprehension:
  assumes A1: "y\<in>X" and A2: "\<forall>x\<in>X. \<forall>y\<in>X. P(x) = P(y)"
  shows "(\<Union>{P(x). x\<in>X}) = P(y)"
proof -
  let ?A = "{P(x). x\<in>X}"
  have "\<exists>! c. c \<in> ?A"
  proof
    from A1 show "\<exists>c. c \<in> ?A" by auto
  next
    fix a b assume "a \<in> ?A" and "b \<in> ?A"
    then obtain x t where
      "x \<in> X" "a = P(x)" and "t \<in> X" "b = P(t)"
      by auto
    with A2 show "a=b" by blast
  qed
  then have "(\<Union>?A) \<in> ?A" by (rule singleton_extract)
  then obtain x where "x \<in> X" and "(\<Union>?A) = P(x)"
    by auto
  from A1 A2 \<open>x \<in> X\<close> have "P(x) = P(y)"
    by blast
  with \<open>(\<Union>?A) = P(x)\<close> show "(\<Union>?A) = P(y)" by simp
qed

text\<open>Adding an element of a set to that set does not change the set.\<close>

lemma set_elem_add: assumes "x\<in>X" shows "X \<union> {x} = X" using assms
  by auto

text\<open>Here we define a restriction of a collection of sets to a given set.
  In romantic math this is typically denoted $X\cap M$ and means
  $\{X\cap A : A\in M \} $. Note there is also restrict$(f,A)$
  defined for relations in ZF.thy.\<close>

definition
  RestrictedTo (infixl "{restricted to}" 70) where
  "M {restricted to} X \<equiv> {X \<inter> A . A \<in> M}"

text\<open>A lemma on a union of a restriction of a collection
  to a set.\<close>

lemma union_restrict:
  shows "\<Union>(M {restricted to} X) = (\<Union>M) \<inter> X"
  using RestrictedTo_def by auto

text\<open>Next we show a technical identity that is used to prove sufficiency
  of some condition for a collection of sets to be a base for a topology.\<close>

lemma ZF1_1_L10: assumes A1: "\<forall>U\<in>C. \<exists>A\<in>B. U = \<Union>A"
  shows "\<Union>\<Union> {\<Union>{A\<in>B. U = \<Union>A}. U\<in>C} = \<Union>C"
proof
  show "\<Union>(\<Union>U\<in>C. \<Union>{A \<in> B . U = \<Union>A}) \<subseteq> \<Union>C" by blast
  show "\<Union>C \<subseteq> \<Union>(\<Union>U\<in>C. \<Union>{A \<in> B . U = \<Union>A})"
  proof
    fix x assume "x \<in> \<Union>C"
    show "x \<in> \<Union>(\<Union>U\<in>C. \<Union>{A \<in> B . U = \<Union>A})"
    proof -
      from \<open>x \<in> \<Union>C\<close> obtain U where "U\<in>C \<and> x\<in>U" by auto
      with A1 obtain A where "A\<in>B \<and> U = \<Union>A" by auto
      from \<open>U\<in>C \<and> x\<in>U\<close> \<open>A\<in>B \<and> U = \<Union>A\<close> show "x\<in> \<Union>(\<Union>U\<in>C. \<Union>{A \<in> B . U = \<Union>A})"
	by auto
    qed
  qed
qed

text\<open>Standard Isabelle uses a notion of \<open>cons(A,a)\<close> that can be thought
  of as $A\cup \{a\}$.\<close>

lemma consdef: shows "cons(a,A) = A \<union> {a}"
  using cons_def by auto

text\<open>If a difference between a set and a singleton is empty, then
  the set is empty or it is equal to the singleton.\<close>

lemma singl_diff_empty: assumes "A - {x} = 0"
  shows "A = 0 \<or> A = {x}"
  using assms by auto

text\<open>If a difference between a set and a singleton is the set,
  then the only element of the singleton is not in the set.\<close>

lemma singl_diff_eq: assumes A1: "A - {x} = A"
  shows "x \<notin> A"
proof -
  have "x \<notin> A - {x}" by auto
  with A1 show "x \<notin> A" by simp
qed

text\<open>A basic property of sets defined by comprehension.\<close>

lemma comprehension: assumes "a \<in> {x\<in>X. p(x)}"
  shows "a\<in>X" and "p(a)" using assms by auto

text\<open>A basic property of a set defined by another type of comprehension.\<close>

lemma comprehension_repl: assumes "y \<in> {p(x). x\<in>X}"
  shows "\<exists>x\<in>X. y = p(x)" using assms by auto

text\<open>The inverse of the \<open>comprehension\<close> lemma.\<close>

lemma mem_cond_in_set: assumes "\<phi>(c)" and "c\<in>X"
  shows "c \<in> {x\<in>X. \<phi>(x)}" using assms by blast

text\<open>The image of a set by a greater relation is greater. \<close>

lemma image_rel_mono: assumes "r\<subseteq>s" shows "r``(A) \<subseteq> s``(A)"
  using assms by auto

text\<open> A technical lemma about relations: if $x$ is in its image by a relation $U$
  and that image is contained in some set $C$, then the image of the singleton
  $\{ x\}$ by the relation $U \cup C\times C$ equals $C$. \<close>

lemma image_greater_rel:
  assumes  "x \<in> U``{x}"  and "U``{x} \<subseteq> C"
  shows "(U \<union> C\<times>C)``{x} = C"
  using assms image_Un_left by blast

text\<open>Reformulation of the definition of composition of two relations: \<close>

lemma rel_compdef:
  shows "\<langle>x,z\<rangle> \<in> r O s  \<longleftrightarrow>  (\<exists>y. \<langle>x,y\<rangle> \<in> s \<and> \<langle>y,z\<rangle> \<in> r)"
  unfolding comp_def by auto

text\<open>Domain and range of the relation of the form $\bigcup \{U\times U : U\in P\}$
  is $\bigcup P$: \<close>

lemma domain_range_sym: shows "domain(\<Union>{U\<times>U. U\<in>P}) = \<Union>P" and "range(\<Union>{U\<times>U. U\<in>P}) = \<Union>P"
  by auto

text\<open>An identity for the square (in the sense of composition) of a symmetric relation.\<close>

lemma symm_sq_prod_image: assumes "converse(r) = r"
  shows "r O r = \<Union>{(r``{x})\<times>(r``{x}). x \<in> domain(r)}"
proof
  { fix p assume "p \<in> r O r"
    then obtain y z where "\<langle>y,z\<rangle> = p" by auto
    with \<open>p \<in> r O r\<close> obtain x where "\<langle>y,x\<rangle> \<in> r" and "\<langle>x,z\<rangle> \<in> r"
      using rel_compdef by auto
    from \<open>\<langle>y,x\<rangle> \<in> r\<close> have "\<langle>x,y\<rangle> \<in> converse(r)" by simp
    with assms \<open>\<langle>x,z\<rangle> \<in> r\<close> \<open>\<langle>y,z\<rangle> = p\<close> have "\<exists>x\<in>domain(r). p \<in> (r``{x})\<times>(r``{x})"
      by auto
  } thus "r O r \<subseteq> (\<Union>{(r``{x})\<times>(r``{x}). x \<in> domain(r)})"
    by blast
  { fix x assume "x \<in> domain(r)"
    have "(r``{x})\<times>(r``{x}) \<subseteq> r O r"
    proof -
      { fix p assume "p \<in> (r``{x})\<times>(r``{x})"
        then obtain y z where "\<langle>y,z\<rangle> = p" "y \<in> r``{x}" "z \<in> r``{x}"
          by auto
        from \<open>y \<in> r``{x}\<close> have "\<langle>x,y\<rangle> \<in> r" by auto
        then have "\<langle>y,x\<rangle> \<in> converse(r)" by simp
        with assms \<open>z \<in> r``{x}\<close> \<open>\<langle>y,z\<rangle> = p\<close> have "p \<in> r O r" by auto
      } thus ?thesis  by auto
    qed
  } thus "(\<Union>{(r``{x})\<times>(r``{x}). x \<in> domain(r)}) \<subseteq> r O r"
    by blast
qed

text\<open>A reflexive relation is contained in the union of products of its singleton images. \<close>

lemma refl_union_singl_image:
  assumes "A \<subseteq> X\<times>X" and "id(X)\<subseteq>A" shows "A \<subseteq> \<Union>{A``{x}\<times>A``{x}. x \<in> X}"
proof -
  { fix p assume "p\<in>A"
    with assms(1) obtain x y where "x\<in>X" "y\<in>X" and "p=\<langle>x,y\<rangle>" by auto
    with assms(2) \<open>p\<in>A\<close> have "\<exists>x\<in>X. p \<in> A``{x}\<times>A``{x}" by auto
  } thus ?thesis by auto
qed

text\<open>If the cartesian product of the images of $x$ and $y$ by a
  symmetric relation $W$ has a nonempty intersection with $R$
  then $x$ is in relation $W\circ (R\circ W)$ with $y$. \<close>

lemma sym_rel_comp:
  assumes "W=converse(W)" and "(W``{x})\<times>(W``{y}) \<inter> R \<noteq> 0"
  shows "\<langle>x,y\<rangle> \<in> (W O (R O W))"
proof -
  from assms(2) obtain s t where "s\<in>W``{x}" "t\<in>W``{y}" and "\<langle>s,t\<rangle>\<in>R"
    by blast
  then have "\<langle>x,s\<rangle> \<in> W" and "\<langle>y,t\<rangle> \<in> W" by auto
  from \<open>\<langle>x,s\<rangle> \<in> W\<close> \<open>\<langle>s,t\<rangle> \<in> R\<close> have "\<langle>x,t\<rangle> \<in> R O W" by auto
  from \<open>\<langle>y,t\<rangle> \<in> W\<close> have "\<langle>t,y\<rangle> \<in> converse(W)" by blast
  with assms(1) \<open>\<langle>x,t\<rangle> \<in> R O W\<close> show ?thesis by auto
qed

text\<open> It's hard to believe but there are cases where we have to reference this rule. \<close>

lemma set_mem_eq: assumes "x\<in>A" "A=B" shows "x\<in>B" using assms by simp

text\<open>Given some family $\mathcal{A}$ of subsets of $X$ we can define the family of supersets of
  $\mathcal{A}$. \<close>

definition
  "Supersets(X,\<A>) \<equiv> {B\<in>Pow(X). \<exists>A\<in>\<A>. A\<subseteq>B}"

text\<open>The family itself is in its supersets. \<close>

lemma superset_gen: assumes "A\<subseteq>X" "A\<in>\<A>" shows "A \<in> Supersets(X,\<A>)"
  using assms unfolding Supersets_def by auto

text\<open>This can be done by the auto method, but sometimes takes a long time. \<close>

lemma witness_exists: assumes "x\<in>X" and "\<phi>(x)" shows "\<exists>x\<in>X. \<phi>(x)"
  using assms by auto

text\<open>The next lemma has to be used as a rule in some rare cases. \<close>

lemma exists_in_set: assumes "\<forall>x. x\<in>A \<longrightarrow> \<phi>(x)" shows "\<forall>x\<in>A. \<phi>(x)"
  using assms by simp

text\<open>If $x$ belongs to a set where a property holds, then the property holds
  for $x$. This has to be used as rule in rare cases. \<close>

lemma property_holds: assumes "\<forall>t\<in>X. \<phi>(t)" and "x\<in>X"
  shows "\<phi>(x)" using assms by simp

text\<open>Set comprehensions defined by equal expressions are the equal.
  The second assertion is actually about functions, which are sets of pairs
  as illustrated in lemma \<open>fun_is_set_of_pairs\<close> in \<open>func1.thy\<close>  \<close>

lemma set_comp_eq: assumes "\<forall>x\<in>X. p(x) = q(x)"
  shows "{p(x). x\<in>X} = {q(x). x\<in>X}" and "{\<langle>x,p(x)\<rangle>. x\<in>X} = {\<langle>x,q(x)\<rangle>. x\<in>X}"
  using assms by auto

text\<open>If $z$ is a pair, then the cartesian product of the singletons of its
  elements is the same as the singleton $\{ z\}$.\<close>

lemma pair_prod: assumes "z = \<langle>x,y\<rangle>" shows "{x}\<times>{y} = {z}"
  using assms by blast

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)
(*<*)
theory RPCFrom imports
  "../../tools/c-parser/CTranslation"
  "../../tools/autocorres/AutoCorres"
begin

(* THIS THEORY IS GENERATED. DO NOT EDIT. *)

declare [[allow_underscore_idents=true]]

install_C_file "RPCFrom.c"

(* Use non-determinism instead of the standard option monad type stregthening and do not heap
 * abstract seL4_SetMR.
 *)
autocorres [ts_rules = nondet, no_heap_abs = seL4_SetMR] "RPCFrom.c"

context RPCFrom begin

(* Repeated constants from C. *)
abbreviation "seL4_MsgMaxLength \<equiv> 120"

(* Introduce this definition here so we can refer to it in the locale extension below. *)
definition
  seL4_SetMR_lifted' :: "int \<Rightarrow> word32 \<Rightarrow> lifted_globals \<Rightarrow> (unit \<times> lifted_globals) set \<times> bool"
where
  "seL4_SetMR_lifted' i val \<equiv>
   do
     ret' \<leftarrow> seL4_GetIPCBuffer';
     guard (\<lambda>s. i < seL4_MsgMaxLength);
     guard (\<lambda>s. 0 \<le> i);
     modify (\<lambda>s. s \<lparr>heap_seL4_IPCBuffer__C :=
       (heap_seL4_IPCBuffer__C s)(ret' :=
          msg_C_update (\<lambda>a. Arrays.update a (nat i) val)
             (heap_seL4_IPCBuffer__C s ret'))
     \<rparr>)
  od"

end

locale RPCFrom_glue = RPCFrom +
  assumes seL4_SetMR_axiom: "exec_concrete lift_global_heap (seL4_SetMR' i val) = seL4_SetMR_lifted' i val"
  assumes swi_safe_to_ignore[simplified, simp]:
    "asm_semantics_ok_to_ignore TYPE(nat) true (''swi '' @ x)"
begin
(*>*)

chapter {* Assumptions *}

text {*
  This chapter introduces some definitions for properties that we assume to be invariant across the
  execution of user code. That is, the glue code lemmas in chapters that follow contain explicit
  assumptions that the user code in a component preserves the properties given below.

  Threads in seL4 communicate with one another via an Inter-Process Communication (IPC) mechanism
  provided by the kernel. Each thread has an assigned IPC buffer, a region of memory in their
  address space, that is taken by the kernel as an implicit parameter to any syscall. In an IPC
  message that involves communication with another thread, the sender writes the transfer payload
  to their IPC buffer before syscall invocation. CAmkES leverages this communication mechanism in
  implementing its own primitives.

  In seL4, the globals frame is a single page mapped read-only to userspace, whose first word
  contains a pointer to the current thread's IPC buffer. The CAmkES glue code uses this to marshal
  RPC arguments in to and out of the IPC buffer. For the glue code's operations to be valid, we
  require the globals frame not to have been modified. We create the following two definitions as
  shorthands for the globals frame still containing a valid pointer to the IPC buffer and the
  pointed to buffer still being valid, typed memory, respectively.
*}
definition
  globals_frame_intact :: "lifted_globals \<Rightarrow> bool"
where
  "globals_frame_intact s \<equiv>
    is_valid_seL4_IPCBuffer__C'ptr s (Ptr (scast seL4_GlobalsFrame))"

definition
  ipc_buffer_valid :: "lifted_globals \<Rightarrow> bool"
where
  "ipc_buffer_valid s \<equiv> is_valid_seL4_IPCBuffer__C s
    (heap_seL4_IPCBuffer__C'ptr s (Ptr (scast seL4_GlobalsFrame)))"

text {*
  One of the underlying tools we rely on does not currently fully abstract writes to arrays within
  structs. The glue code performs such operations when writing to threads' IPC buffers, in the
  function \code{seL4\_SetMR}. In order to work with a fully abstracted representation of these writes, we
  provide the following abstract definition of the function and axiomatise its equivalence to the
  partially abstracted representation we have. In future this axiomatisation will be removed and the
  abstraction framework will emit the definition below and an accompanying proof of equivalence in
  place of the axiom.
*}
text {* \newpage *}
(* We repeat this definition because Isabelle's rendering of the original back to us via @{thm ...}
 * does not get formatted nicely. We use a different name in order not to interfere with any
 * following lemmas. Hopefully it won't confuse the reader.
 *)
definition
  seL4_SetMR_lifted
where
  "seL4_SetMR_lifted i val \<equiv>
     do
       ret' \<leftarrow> seL4_GetIPCBuffer';
       guard (\<lambda>s. i < seL4_MsgMaxLength);
       guard (\<lambda>s. 0 \<le> i);
       modify (\<lambda>s. s \<lparr>heap_seL4_IPCBuffer__C :=
         (heap_seL4_IPCBuffer__C s)(ret' :=
            msg_C_update (\<lambda>a. Arrays.update a (nat i) val)
               (heap_seL4_IPCBuffer__C s ret'))
       \<rparr>)
    od"

text {*
  The number of threads in a CAmkES component is dependent on the incoming and outgoing interfaces
  to that component. Per-thread data is generated as part of the connector glue code, including
  thread-local storage (TLS) variables. These variables are accessed via the current thread's TLS
  region. The following definitions are later used to express assumptions that the TLS region of
  the current thread has not been modified by intervening user code. In practice, non-malicious user
  code should never modify the TLS region or any thread-local variables.
*}
definition
  tls_ptr :: "lifted_globals \<Rightarrow> camkes_tls_t_C ptr"
where
  "tls_ptr s \<equiv> Ptr (ptr_val (heap_seL4_IPCBuffer__C'ptr s
     (Ptr (scast seL4_GlobalsFrame))) && 0xFFFFF000)"

definition
  tls :: "lifted_globals \<Rightarrow> camkes_tls_t_C"
where
  "tls s \<equiv> heap_camkes_tls_t_C s (tls_ptr s)"

definition
  tls_valid :: "lifted_globals \<Rightarrow> bool"
where
  "tls_valid s \<equiv> is_valid_camkes_tls_t_C s (tls_ptr s)"

text {*
  We make a further assumption about the execution of the kernel on behalf of a user thread that is
  explained in the next chapter.
*}

chapter {* System Calls *}

text {*
  A thread's IPC buffer contains a number of message registers that are used for transferring data
  during an IPC operation. The following two definitions are used to abbreviate the operation of
  setting a specific message register and setting the first four message registers, respectively.
  We have a specific definition for setting the first four message registers because this is a
  common operation performed by the seL4 syscall stubs (user-level kernel entry utility functions).
*}
definition
  setMR :: "lifted_globals \<Rightarrow> nat \<Rightarrow> word32 \<Rightarrow> lifted_globals"
where
  "setMR s i v \<equiv>
      s\<lparr>heap_seL4_IPCBuffer__C := (heap_seL4_IPCBuffer__C s)
        (heap_seL4_IPCBuffer__C'ptr s (Ptr (scast seL4_GlobalsFrame)) :=
          msg_C_update (\<lambda>a. Arrays.update a i v)
            (heap_seL4_IPCBuffer__C s (heap_seL4_IPCBuffer__C'ptr s
              (Ptr (scast seL4_GlobalsFrame)))))\<rparr>"

definition
  setMRs :: "lifted_globals \<Rightarrow> word32 \<Rightarrow> word32 \<Rightarrow>
             word32 \<Rightarrow> word32 \<Rightarrow> lifted_globals"
where
  "setMRs s mr0 mr1 mr2 mr3 \<equiv>
    setMR (setMR (setMR (setMR s 0 mr0) 1 mr1) 2 mr2) 3 mr3"

text {*
  Before showing properties of the syscall stubs, we introduce some lemmas specifying the effect
  of some seL4 supporting functions. The function \code{seL4\_GetIPCBuffer} returns a pointer to
  the current thread's IPC buffer, while the functions \code{seL4\_SetMR} and \code{seL4\_GetMR}
  write to and read from the message registers of the IPC buffer, respectively. The following
  lemmas state their effects, and are used below in reasoning about the effect of the syscall stubs
  themselves.

  Some of these are tagged ``[wp\_unsafe],'' which allows the wp tactic to hint to an
  interactive user when it could have made further progress with this lemma available. These tags
  are included for convenience when adapting or exploring a generated proof. The optional ``notes''
  header of a lemma allows existing lemmas to be modified for the duration of the current proof.
  The \code{seL4\_SetMR} proof uses this to make the axiom we discussed previously available to
  Isabelle's simp tactic.
*}
text {* \newpage *}
lemma seL4_GetIPCBuffer_wp':
  "\<forall>s'. \<lbrace>\<lambda>s. globals_frame_intact s \<and>
             s = s'\<rbrace>
         seL4_GetIPCBuffer'
        \<lbrace>\<lambda>r s. r = heap_seL4_IPCBuffer__C'ptr s
                 (Ptr (scast seL4_GlobalsFrame)) \<and>
               s = s'\<rbrace>!"
  apply (rule allI)
  apply (simp add:seL4_GetIPCBuffer'_def)
  apply wp
  apply (clarsimp simp:globals_frame_intact_def)
  done

(*<*)
lemmas seL4_GetIPCBuffer_wp[wp_unsafe] =
  seL4_GetIPCBuffer_wp'[THEN validNF_make_schematic_post, simplified]
(*>*)

lemma seL4_SetMR_wp[wp_unsafe]:
  notes seL4_SetMR_axiom[simp]
  shows
  "\<lbrace>\<lambda>s. globals_frame_intact s \<and>
        ipc_buffer_valid s \<and>
        i \<ge> 0 \<and>
        i < seL4_MsgMaxLength \<and>
        (\<forall>x. P x (setMR s (nat i) v))\<rbrace>
    exec_concrete lift_global_heap (seL4_SetMR' i v)
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_SetMR_lifted'_def)
  apply (wp seL4_GetIPCBuffer_wp)
  apply (simp add:setMR_def globals_frame_intact_def ipc_buffer_valid_def)
  done

lemma seL4_GetMR_wp[wp_unsafe]:
  "\<lbrace>\<lambda>s. \<forall>x. i \<ge> 0 \<and>
            i < seL4_MsgMaxLength \<and>
            globals_frame_intact s \<and>
            ipc_buffer_valid s \<and>
            P x s\<rbrace>
    seL4_GetMR' i
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_GetMR'_def)
  apply (wp seL4_GetIPCBuffer_wp)
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def)
  done

text {*
  The C standard library provides a function, \code{abort}, that is called by
  the CAmkES glue code in the event of an unrecoverable error. We do not
  provide a definition of the function itself and instead use the following
  lemma to later prove that all invocations to \code{abort} are dead code that
  is never executed.
*}
lemma abort_wp[wp]:
  "\<lbrace>\<lambda>_. False\<rbrace> abort' \<lbrace>P\<rbrace>!"
  by (rule validNF_false_pre)

text {*
  We now introduce lemmas specifying the behaviour of seL4 syscall stubs. These functions write
  syscall arguments into hardware registers, perform an assembly instruction to enter the kernel
  and then unpack the kernel's response. The following lemmas express that these invocations can
  never fail. We only provide lemmas for the syscalls used by the CAmkES glue code.
*}
lemma seL4_Call_wp[wp_unsafe]:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s. globals_frame_intact s \<and>
        ipc_buffer_valid s \<and>
        (\<forall>x v0 v1 v2 v3. P x (setMRs s v0 v1 v2 v3))\<rbrace>
    seL4_Call' cap info
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_Call'_def)
  apply (wp seL4_GetIPCBuffer_wp)
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def setMRs_def
                  setMR_def)
  done
(* The remaining syscall WP lemmas are irrelevant for the proofs in this locale, but we prove them
 * here so they appear in a logical location if we're building a document.
 *)
lemma seL4_Notify_wp[wp_unsafe]:
  "\<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace>
    seL4_Notify' cap data
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_Notify'_def seL4_MessageInfo_new'_def)
  apply wp
  apply simp
  done

lemma seL4_Poll_wp[wp_unsafe]:
  "\<lbrace>\<lambda>s. globals_frame_intact s \<and>
        ipc_buffer_valid s \<and>
        (\<forall>x b v0 v1 v2 v3. P x (heap_w32_update
          (\<lambda>a. a(badge := b)) (setMRs s v0 v1 v2 v3))) \<and>
        badge \<noteq> NULL \<and>
        is_valid_w32 s badge\<rbrace>
    seL4_Poll' cap badge
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_Poll'_def seL4_GetIPCBuffer'_def)
  apply (wp seL4_SetMR_wp)
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def setMRs_def
                  setMR_def)
  done

text {* \newpage *}
lemma seL4_ReplyWait_wp[wp_unsafe]:
  "\<lbrace>\<lambda>s. globals_frame_intact s \<and>
        ipc_buffer_valid s \<and>
        (\<forall>x v0 v1 v2 v3. P x (setMRs s v0 v1 v2 v3))\<rbrace>
    seL4_ReplyWait' cap info NULL
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_ReplyWait'_def seL4_GetMR'_def)
  apply (wp seL4_SetMR_wp seL4_GetIPCBuffer_wp)
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def setMRs_def
                  setMR_def)
  done

lemma seL4_Wait_wp[wp_unsafe]:
  "\<lbrace>\<lambda>s. globals_frame_intact s \<and>
        ipc_buffer_valid s \<and>
        (\<forall>x v0 v1 v2 v3. P x (setMRs s v0 v1 v2 v3))\<rbrace>
    seL4_Wait' cap NULL
   \<lbrace>P\<rbrace>!"
  apply (simp add:seL4_Wait'_def)
  apply (wp seL4_SetMR_wp)
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def setMRs_def
                  setMR_def)
  done

text {*
  It should be noted that each of these proofs about a system call stub implicitly assumes that the
  execution of the kernel itself has no effect on the user state. Obviously this is not true in
  practice or components would not be able to communicate via IPC. For now, the actual behaviour of
  the kernel is not required to show safe execution of the glue code. Further functional
  correctness proofs in future will involve a semantics of the kernel's execution and its effect on
  the user state.
*}

(*<*)

definition
  thread_count :: word32
where
  "thread_count \<equiv> 2"

(* Any array parameters will have caused a TLS array to be generated. Prove a WP lemma for each
 * here.
 *)

(*>*)

chapter {* RPC Send *}
(*<*)
(* This lemma captures the safety of the RPCFrom__run function
 * which is invoked on startup in this glue code. It is excluded from the final document because
 * the function itself is trivial and the proof uninteresting.
 *)
lemma RPCFrom_run_nf: "\<lbrace>\<lambda>s. \<forall>r. P r s\<rbrace> RPCFrom__run' \<lbrace>P\<rbrace>!"
  apply (simp add: RPCFrom__run'_def)
  apply wp
  apply simp
  done
(*>*)

text {*
  Having introduced supporting lemmas, we are now in a position to express the safety of the CAmkES
  glue code itself. The lemmas and proofs in this chapter are generated from the following CAmkES
  interface definition:
  \camkeslisting{simple.camkes}
  This describes a CAmkES procedural interface containing six methods. To give some idea of what
  the code for this procedure looks like, the generated implementation of the first method follows.
  \clisting{from-echo-int.c}

  We generate a proof for each
  method that the generated glue code does not fail. The purpose of these six is to
  demonstrate that proof generation generalises across the various CAmkES data types and
  parameter combinations. The same generation logic produces a proof for word-sized parameters
  (e.g. \code{int}), parameters smaller than a word (e.g. \code{char}) and parameters greater than
  a word (e.g. \code{uint64\_t}). Similarly the generation logic handles input, output and
  bidirectional parameters, as well as methods with and without a return value.

  The proofs themselves state that the glue code obeys the C99 standard and that, when invoked, it
  consistently terminates (returns to the user) and does not reference invalid memory. The
  assumptions are the properties of the globals frame and TLS region discussed previously and,
  where relevant, that any pointers passed to the glue code can be safely dereferenced.
*}

lemma RPCFrom_echo_int_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s0'. globals_frame_intact s0' \<and>
          ipc_buffer_valid s0'\<rbrace>
   RPCFrom_echo_int' i
  \<lbrace>\<lambda>_ s0'. globals_frame_intact s0' \<and>
           ipc_buffer_valid s0'\<rbrace>!"
  apply (simp add:RPCFrom_echo_int'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

lemma RPCFrom_echo_parameter_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s1'. globals_frame_intact s1' \<and>
          is_valid_w32 s1' (ptr_coerce pout) \<and>
          ipc_buffer_valid s1'\<rbrace>
   RPCFrom_echo_parameter' pin pout
  \<lbrace>\<lambda>_ s1'. globals_frame_intact s1' \<and>
           is_valid_w32 s1' (ptr_coerce pout) \<and>
           ipc_buffer_valid s1'\<rbrace>!"
  apply (simp add:RPCFrom_echo_parameter'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

    text {* \newpage *}

lemma RPCFrom_echo_char_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s2'. globals_frame_intact s2' \<and>
          ipc_buffer_valid s2'\<rbrace>
   RPCFrom_echo_char' i
  \<lbrace>\<lambda>_ s2'. globals_frame_intact s2' \<and>
           ipc_buffer_valid s2'\<rbrace>!"
  apply (simp add:RPCFrom_echo_char'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

lemma RPCFrom_increment_char_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s3'. globals_frame_intact s3' \<and>
          is_valid_w8 s3' (ptr_coerce x) \<and>
          ipc_buffer_valid s3'\<rbrace>
   RPCFrom_increment_char' x
  \<lbrace>\<lambda>_ s3'. globals_frame_intact s3' \<and>
           is_valid_w8 s3' (ptr_coerce x) \<and>
           ipc_buffer_valid s3'\<rbrace>!"
  apply (simp add:RPCFrom_increment_char'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

    text {* \newpage *}

lemma RPCFrom_increment_parameter_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s4'. globals_frame_intact s4' \<and>
          is_valid_w32 s4' (ptr_coerce x) \<and>
          ipc_buffer_valid s4'\<rbrace>
   RPCFrom_increment_parameter' x
  \<lbrace>\<lambda>_ s4'. globals_frame_intact s4' \<and>
           is_valid_w32 s4' (ptr_coerce x) \<and>
           ipc_buffer_valid s4'\<rbrace>!"
  apply (simp add:RPCFrom_increment_parameter'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

lemma RPCFrom_increment_64_nf:
  notes seL4_SetMR_wp[wp] seL4_GetMR_wp[wp]
  shows
  "\<lbrace>\<lambda>s5'. globals_frame_intact s5' \<and>
          is_valid_w64 s5' (ptr_coerce x) \<and>
          ipc_buffer_valid s5'\<rbrace>
   RPCFrom_increment_64' x
  \<lbrace>\<lambda>_ s5'. globals_frame_intact s5' \<and>
           is_valid_w64 s5' (ptr_coerce x) \<and>
           ipc_buffer_valid s5'\<rbrace>!"
  apply (simp add:RPCFrom_increment_64'_def)
  apply (wp seL4_Call_wp)
    apply (simp add:seL4_MessageInfo_new'_def)
    apply wp+
  apply (simp add:globals_frame_intact_def ipc_buffer_valid_def
                  setMRs_def setMR_def)
  done

(*<*)
end

end
(*>*)


(* Title: UD/UD_Reference.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Reference manual for the UD.
*)

section\<open>UD\<close>
theory UD_Reference
  imports
    UD
    "../Reference_Prerequisites"
begin

subsection\<open>Introduction\<close>

subsubsection\<open>Background\<close>

text\<open>
This section presents a reference manual for the sub-framework UD.
The UD can be used for the elimination of
\textit{sort constraints} (e.g., see \<^cite>\<open>"altenkirch_constructive_2007"\<close>)
and unoverloading of definitions in the object logic Isabelle/HOL of the
formal proof assistant Isabelle.
The UD evolved from the author's work on an extension of the
framework \textit{Types-To-Sets}
(see
\<^cite>\<open>"blanchette_types_2016" and "kuncar_types_2019" and "immler_smooth_2019" and "immler_automation_2019"\<close>,
for a description of the framework Types-To-Sets
and \<^cite>\<open>"milehins_extension_2021"\<close> for a description of the author's extension)
and builds upon certain ideas expressed in \<^cite>\<open>"kaufmann_mechanized_2010"\<close>.
\<close>

subsubsection\<open>Purpose and scope\<close>

text\<open>
The primary functionality of the framework is available via the Isabelle/Isar
command @{command ud}. This command automates the processes of the
elimination of sort constraints and unoverloading of definitions.
Thus, the command @{command ud} allows for the synthesis
of the convenience constants and theorems that are usually needed for the
application of the derivation step 2 of the original relativization algorithm
of Types-To-Sets (see subsection 5.4 in \<^cite>\<open>"blanchette_types_2016"\<close>). However,
it is expected that the command can be useful for other purposes.
\<close>

subsubsection\<open>Related and previous work\<close>

text\<open>
The functionality provided by the command @{command ud} shares similarities
with the functionality provided by the algorithms for the elimination of
sort constraints and elimination of overloading that were
presented in \<^cite>\<open>"kaufmann_mechanized_2010"\<close>
and with the algorithm associated with the command
\mbox{\textbf{unoverload\_definition}} that was proposed
in \<^cite>\<open>"immler_automation_2019"\<close>.
Nonetheless, technically, unlike \mbox{\textbf{unoverload\_definition}},
the command @{command ud} does
not require the additional axiom UO associated with Types-To-Sets for
its operation (see \<^cite>\<open>"blanchette_types_2016"\<close>,
\<^cite>\<open>"immler_automation_2019"\<close>), it uses
the \textit{definitional axioms} (e.g., see \<^cite>\<open>"kaufmann_mechanized_2010"\<close>)
instead of arbitrary theorems supplied by the user
and it is independent of the infrastructure associated with
the \textit{axiomatic type classes}
\<^cite>\<open>"nipkow_type_1991" and "wenzel_type_1997" and "altenkirch_constructive_2007"\<close>.

It should also be mentioned that the Isabelle/ML code from the main
distribution of Isabelle was frequently reused during the
development of the UD. Lastly, it should be mentioned that the
framework SpecCheck \<^cite>\<open>"kappelmann_speccheck_2021"\<close> was used for unit
testing the framework UD.
\<close>

subsection\<open>Theory\label{sec:ud_theory}\<close>

text\<open>
The general references for this subsection are
\<^cite>\<open>"kaufmann_mechanized_2010"\<close> and \<^cite>\<open>"yang_comprehending_2017"\<close>.
The command @{command ud} relies
on a restricted (non-recursive) variant of the
\textit{classical overloading elimination algorithm}
that was originally proposed in \<^cite>\<open>"kaufmann_mechanized_2010"\<close>.
It is assumed that there exists
a variable $ud_{\mathsf{with}}$ that stores theorems of the
form $c_{\tau} = c_{\mathsf{with}}\ \bar{*}$, where $c_{\tau}$ and
$c_{\mathsf{with}}$ are distinct \textit{constant-instances}
and $\bar{*}$ is a finite sequence of \textit{uninterpreted constant-instances},
such that, if $c_{\tau}$ depends on a type variable $\alpha_{\Upsilon}$,
with $\Upsilon$ being a \textit{type class}
\<^cite>\<open>"nipkow_type_1991" and "wenzel_type_1997" and "altenkirch_constructive_2007"\<close>
that depends on the overloaded
constants $\bar{*'}$, then $\bar{*}$ contains $\bar{*'}$ as a subsequence.
Lastly, the binary operation $\cup$ is defined in a manner such that
for any sequences $\bar{*}$ and $\bar{*'}$, $\bar{*} \cup \bar{*'}$
is a sequence that consists of all elements of the union of the
elements of $\bar{*}$ and $\bar{*'}$ without duplication.
Assuming an underlying
\textit{well-formed definitional theory} $D$,
the input to the algorithm is a constant-instance $c_{\sigma}$.
Given the constant-instance $c_{\sigma}$,
there exists at most one definitional axiom
$c_{\tau} = \phi_{\tau}\left[\bar{*}\right]$
in $D$ such that $c_{\sigma} \leq c_{\tau}$: otherwise
the \textit{orthogonality} of $D$ and,
therefore, the \textit{well-formedness}
of $D$ are violated ($\phi$ is assumed to be parameterized by
the types that it can have with respect to the
type substitution operation,
and $\bar{*}$ in $c_{\tau} = \phi_{\tau}\left[\bar{*}\right]$
is a list of all uninterpreted constant-instances that
occur in $\phi_{\tau}\left[\bar{*}\right]$).

If a definitional axiom $c_{\tau}=\phi_{\tau}\left[\bar{*}\right]$
such that $c_{\sigma} \leq c_{\tau}$
exists for the constant-instance $c_{\sigma}$,
then the following derivation is applied to it by the algorithm
\[
\infer[(6)]
{\vdash c_{\sigma} = c_{\mathsf{with}}\ \left(\bar{*} \cup \bar{*'}\right)}
{
\infer[(5)]
{
\vdash c_{\mathsf{with}}\ \left(\bar{*} \cup \bar{*'}\right) =
\phi_{\mathsf{with}}\left[\bar{*} \cup \bar{*'}\right]
}
{
\infer[(4)]
{\vdash c_{\mathsf{with}}\ ?\bar{f} = \phi_{\mathsf{with}}\left[?\bar{f}\right]}
{
\infer[(3)]
{\vdash c_{\mathsf{with}} = (\lambda \bar{f}.\ \phi_{\mathsf{with}}\left[\bar{f}\right])}
{
\infer[(2)]
{\vdash c_{\sigma}=\phi_{\mathsf{with}}\left[\bar{*} \cup \bar{*'}\right]}
{
\infer[(1)]
{\vdash c_{\sigma}=\phi_{\sigma}\left[\bar{*}\right]}
{\vdash c_{\tau}=\phi_{\tau}\left[\bar{*}\right]}
}
}
}
}
}
\]
In step 1, the previously established
property $c_{\sigma} \leq c_{\tau}$ is used to create the
(extended variant of the) type substitution
map $\rho$ such that $\sigma = \rho \left( \tau \right)$
(see \<^cite>\<open>"kuncar_types_2015"\<close>) and perform the type
substitution in $c_{\tau}=\phi_{\tau}\left[\bar{*}\right]$
to obtain $c_{\sigma}=\phi_{\sigma}\left[\bar{*}\right]$;
in step 2, the collection of theorems $ud_{\mathsf{with}}$ is unfolded,
using it as a term rewriting system, possibly introducing further uninterpreted
constants $\bar{*'}$; in step 3, the term on the right-hand side of the
theorem is processed by removing the sort constraints from all type
variables that occur in it, replacing every uninterpreted constant-instance
(this excludes all built-in constants of Isabelle/HOL) that occurs in it by a
fresh term variable, and applying the abstraction until the resulting term
is closed: this term forms the right-hand side of a new definitional axiom
of a fresh constant $c_{\mathsf{with}}$ (if the conditions associated with
the definitional principles of Isabelle/HOL \<^cite>\<open>"yang_comprehending_2017"\<close>
are satisfied); step 4 is justified by the beta-contraction;
step 5 is a substitution of the uninterpreted constants $\bar{*} \cup \bar{*'}$;
step 6 follows trivially from the results of the application of steps 2 and 5.

The implementation of the command @{command ud} closely follows the steps of
the algorithm outlined above. Thus, at the end of the successful
execution, the command declares the constant $c_{\mathsf{with}}$ and stores the
constant-instance definition that is obtained at the end of step 3 of
the algorithm UD; furthermore, the command adds the theorem that is
obtained after the execution of step 6 of the algorithm
to $ud_{\mathsf{with}}$.

Unlike the classical overloading elimination algorithm,
the algorithm employed in the implementation
of the command @{command ud} is not recursive. Thus, the users are responsible
for maintaining an adequate collection of theorems $ud_{\mathsf{with}}$.
Nonetheless, in this case, the users can provide their own
unoverloaded constants $c_{\mathsf{with}}$ and the associated theorems
$c_{\sigma} = c_{\mathsf{with}}\ \bar{*}$ for any constant-instance $c_{\sigma}$.
From the perspective of the relativization algorithm associated with
Types-To-Sets this can be useful because there is no
guarantee that the automatically synthesized constants $c_{\mathsf{with}}$
will possess desirable parametricity characteristics
(e.g., see \<^cite>\<open>"kuncar_types_2015"\<close> and \<^cite>\<open>"immler_smooth_2019"\<close>).
Unfortunately, the implemented algorithm still suffers from the fundamental
limitation that was already outlined in \<^cite>\<open>"kaufmann_mechanized_2010"\<close>,
\<^cite>\<open>"blanchette_types_2016"\<close> and \<^cite>\<open>"kuncar_types_2019"\<close>:
it does not offer a solution for handling the
constants whose types contain occurrences of the type constructors whose
type definitions contain occurrences of unresolvable overloading.
\<close>

subsection\<open>Syntax\<close>

text\<open>
This subsection presents the syntactic categories that are associated with the
command @{command ud}. It is important to note that the presentation is
only approximate.
\<close>

text\<open>

\begin{matharray}{rcl}
  @{command_def "ud"} & : & \<open>theory \<rightarrow> theory\<close>\\
\end{matharray}

  \<^medskip>

  \<^rail>\<open>@@{command ud} binding? const mixfix?\<close>

  \<^descr> \<^theory_text>\<open>ud\<close> (\<open>b\<close>) \<open>const\<close> (\<open>mixfix\<close>) provides access to the algorithm for
the elimination of sort constraints and unoverloading of definitions
that was described in subsection \ref{sec:ud_theory}.
The optional binding \<open>b\<close> is used for the specification
of the names of the entities added by the command to the theory and the
optional argument \<open>mixfix\<close> is used for the specification
of the concrete inner syntax for the constant in the usual manner
(e.g., see \<^cite>\<open>"wenzel_isabelle/isar_2019-1"\<close>).
If either \<open>b\<close> or \<open>mixfix\<close> are not specified by the user, then the command
introduces sensible defaults. Following the specification of the
definition of the constant, an additional theorem that establishes
the relationship between the newly introduced constant and the
constant provided by the user as an input is established and added
to the dynamic fact @{thm [source] ud_with}.
\<close>

subsection\<open>Examples\label{sec:ud_ex}\<close>

text\<open>
In this subsection, some of the capabilities of the UD are
demonstrated by example. The examples that are presented in this subsection are
expected to be sufficient for beginning an independent exploration of the
framework, but do not cover the entire spectrum of the functionality
and the problems that one may encounter while using it.
\<close>

subsubsection\<open>Type classes\<close>

definition mono where
  "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"

text\<open>
We begin the exploration of the capabilities of the framework by considering
the constant @{const mono}.
It is defined as
\begin{center}
@{thm [names_short = true] mono_def[no_vars]}
\end{center}
for any @{term [show_sorts] "f::'a::order\<Rightarrow>'b::order"}.
The constants is unoverloaded using the command @{command ud}:
\<close>
ud \<open>mono\<close>
text\<open>
The invocation of the command above declares the constant @{const mono.with}
that is defined as
\begin{center}
@{thm mono.with_def[no_vars]}
\end{center}
and provides the theorem @{thm [source] mono.with} given by
\begin{center}
@{thm mono.with[no_vars]}.
\end{center}
The theorems establish the relationship between the unoverloaded constant
@{const mono.with} and the overloaded constant @{const mono}:
both theorems are automatically added to the dynamic fact
@{thm [source] ud_with}.
\<close>

subsubsection\<open>Low-level overloading\<close>

text\<open>
The following example closely follows Example 5 in section 5.2. in
\<^cite>\<open>"kaufmann_mechanized_2010"\<close>.
\<close>

consts pls :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"

overloading
pls_nat \<equiv> "pls::nat \<Rightarrow> nat \<Rightarrow> nat"
pls_times \<equiv> "pls::'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
begin
definition pls_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat" where "pls_nat a b = a + b"
definition pls_times :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
  where "pls_times \<equiv> \<lambda>x y. (pls (fst x) (fst y), pls (snd x) (snd y))"
end

ud pls_nat \<open>pls::nat \<Rightarrow> nat \<Rightarrow> nat\<close>
ud pls_times \<open>pls::'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b\<close>

text\<open>
As expected, two new unoverloaded constants are produced via
the invocations of the command @{command ud} above. The first constant,
\<^const>\<open>pls_nat.with\<close>, corresponds to \<open>pls::nat \<Rightarrow> nat \<Rightarrow> nat\<close> and is given by
\begin{center}
@{thm pls_nat.with_def[no_vars]},
\end{center}
the second constant, \<^const>\<open>pls_times.with\<close>, corresponds to
\begin{center}
\<open>pls::'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'b\<close>
\end{center}
and is given by
\begin{center}
@{thm pls_times.with_def[no_vars]}.
\end{center}
The theorems that establish the relationship between the overloaded and
the unoverloaded constants are given by
\begin{center}
@{thm pls_nat.with}
\end{center}
and
\begin{center}
@{thm pls_times.with}.
\end{center}
The definitions of the constants \<^const>\<open>pls_nat.with\<close> and
\<^const>\<open>pls_times.with\<close> are consistent with the ones suggested in
\<^cite>\<open>"kaufmann_mechanized_2010"\<close>. Nonetheless, of course, it is
important to keep in mind that the command @{command ud}
has a more restricted scope of applicability than the
algorithm suggested in \<^cite>\<open>"kaufmann_mechanized_2010"\<close>.
\<close>

text\<open>\newpage\<close>

end


(*
  File:         More_Loops.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory More_Loops
imports
  "Refine_Monadic.Refine_While"
  "Refine_Monadic.Refine_Foreach"
  "HOL-Library.Rewrite"
begin

subsection \<open>More Theorem about Loops\<close>

text \<open>Most theorem below have a counterpart in the Refinement Framework that is weaker (by missing
  assertions for example that are critical for code generation).
\<close>
lemma Down_id_eq:
  \<open>\<Down>Id x = x\<close>
  by auto

lemma while_upt_while_direct1:
  "b \<ge> a \<Longrightarrow>
  do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (FOREACH_cond c) (\<lambda>x. do {ASSERT (FOREACH_cond c x); FOREACH_body f x})
      ([a..<b],\<sigma>);
    RETURN \<sigma>
  } \<le> do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (\<lambda>(i, x). i < b \<and> c x) (\<lambda>(i, x). do {ASSERT (i < b);  \<sigma>'\<leftarrow>f i x; RETURN (i+1,\<sigma>')
}) (a,\<sigma>);
    RETURN \<sigma>
  }"
  apply (rewrite at \<open>_ \<le> \<hole>\<close> Down_id_eq[symmetric])
  apply (refine_vcg WHILET_refine[where R = \<open>{((l, x'), (i::nat, x::'a)). x= x' \<and> i \<le> b \<and> i \<ge> a \<and>
     l = drop (i-a) [a..<b]}\<close>])
  subgoal by auto
  subgoal by (auto simp: FOREACH_cond_def)
  subgoal by (auto simp: FOREACH_body_def intro!: bind_refine[OF Id_refine])
  subgoal by auto
  done

lemma while_upt_while_direct2:
  "b \<ge> a \<Longrightarrow>
  do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (FOREACH_cond c) (\<lambda>x. do {ASSERT (FOREACH_cond c x); FOREACH_body f x})
      ([a..<b],\<sigma>);
    RETURN \<sigma>
  } \<ge> do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (\<lambda>(i, x). i < b \<and> c x) (\<lambda>(i, x). do {ASSERT (i < b);  \<sigma>'\<leftarrow>f i x; RETURN (i+1,\<sigma>')
}) (a,\<sigma>);
    RETURN \<sigma>
  }"
  apply (rewrite at \<open>_ \<le> \<hole>\<close> Down_id_eq[symmetric])
  apply (refine_vcg WHILET_refine[where R = \<open>{((i::nat, x::'a), (l, x')). x= x' \<and> i \<le> b \<and> i \<ge> a \<and>
    l = drop (i-a) [a..<b]}\<close>])
  subgoal by auto
  subgoal by (auto simp: FOREACH_cond_def)
  subgoal by (auto simp: FOREACH_body_def intro!: bind_refine[OF Id_refine])
  subgoal by (auto simp: FOREACH_body_def intro!: bind_refine[OF Id_refine])
  subgoal by auto
  done

lemma while_nfoldli:
  "do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (FOREACH_cond c) (\<lambda>x. do {ASSERT (FOREACH_cond c x); FOREACH_body f x}) (l,\<sigma>);
    RETURN \<sigma>
  } \<le> nfoldli l c f \<sigma>"
  apply (induct l arbitrary: \<sigma>)
  apply (subst WHILET_unfold)
  apply (simp add: FOREACH_cond_def)

  apply (subst WHILET_unfold)
  apply (auto
    simp: FOREACH_cond_def FOREACH_body_def
    intro: bind_mono Refine_Basic.bind_mono(1))
 done
lemma nfoldli_while: "nfoldli l c f \<sigma>
          \<le>
         (WHILE\<^sub>T\<^bsup>I\<^esup>
           (FOREACH_cond c) (\<lambda>x. do {ASSERT (FOREACH_cond c x); FOREACH_body f x}) (l, \<sigma>) \<bind>
          (\<lambda>(_, \<sigma>). RETURN \<sigma>))"
proof (induct l arbitrary: \<sigma>)
  case Nil thus ?case by (subst WHILEIT_unfold) (auto simp: FOREACH_cond_def)
next
  case (Cons x ls)
  show ?case
  proof (cases "c \<sigma>")
    case False thus ?thesis
      apply (subst WHILEIT_unfold)
      unfolding FOREACH_cond_def
      by simp
  next
    case [simp]: True
    from Cons show ?thesis
      apply (subst WHILEIT_unfold)
      unfolding FOREACH_cond_def FOREACH_body_def
      apply clarsimp
      apply (rule Refine_Basic.bind_mono)
      apply simp_all
      done
  qed
qed

lemma while_eq_nfoldli: "do {
    (_,\<sigma>) \<leftarrow> WHILE\<^sub>T (FOREACH_cond c) (\<lambda>x. do {ASSERT (FOREACH_cond c x); FOREACH_body f x}) (l,\<sigma>);
    RETURN \<sigma>
  } = nfoldli l c f \<sigma>"
  apply (rule antisym)
  apply (rule while_nfoldli)
  apply (rule order_trans[OF nfoldli_while[where I="\<lambda>_. True"]])
  apply (simp add: WHILET_def)
  done

end