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

    Copyright (C) 2005 - 2008  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>Binary operations\<close>

theory func_ZF imports func1

begin

text\<open>In this theory we consider properties of functions that are binary
  operations, that is they map $X\times X$ into $X$.\<close>

subsection\<open>Lifting operations to a function space\<close>

text\<open>It happens quite often that we have a binary operation on some set and
  we need a similar operation that is defined for functions on that set.
  For example once we know how to add real numbers we also know how to add
  real-valued functions: for $f,g:X \rightarrow \mathbf{R}$ we define
  $(f+g)(x) = f(x) + g(x)$. Note that formally the $+$ means something
  different on the left hand side of this equality than on the
  right hand side.
  This section aims at formalizing this process.
  We will call it "lifting to a function space", if you have a
  suggestion for a better name, please let me know.\<close>

text\<open>Since we are writing in generic set notation,
  the definition below is a bit complicated. Here it what it says:
  Given a set $X$ and another set $f$ (that represents a binary function on $X$)
  we are defining $f$ lifted to function space over $X$
  as the binary function (a set of pairs) on the space
  $F = X \rightarrow \textrm{range}(f)$ such that the value of this function
  on pair $\langle a,b \rangle$ of functions on $X$ is another function $c$ on $X$
  with values defined by $c(x) = f\langle a(x), b(x)\rangle$.
\<close>

definition
Lift2FcnSpce (infix "{lifted to function space over}" 65) where
 "f {lifted to function space over} X \<equiv>
  {\<langle> p,{\<langle>x,f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>\<rangle>. x \<in> X}\<rangle>.
  p \<in> (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))}"

text\<open>The result of the lift belongs to the function space.\<close>

lemma func_ZF_1_L1:
  assumes A1: "f : Y\<times>Y\<rightarrow>Y"
  and A2: "p \<in>(X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))"
  shows
  "{\<langle>x,f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>\<rangle>. x \<in> X} : X\<rightarrow>range(f)"
  proof -
    have "\<forall>x\<in>X. f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle> \<in> range(f)"
    proof
      fix x assume "x\<in>X"
      let ?p = "\<langle>fst(p)`(x),snd(p)`(x)\<rangle>"
      from A2 \<open>x\<in>X\<close> have
	"fst(p)`(x) \<in> range(f)"  "snd(p)`(x) \<in> range(f)"
	using apply_type by auto
      with A1 have "?p \<in> Y\<times>Y"
	using func1_1_L5B by blast
      with A1 have "\<langle>?p, f`(?p)\<rangle> \<in> f"
	using apply_Pair by simp
      with A1 show
	"f`(?p) \<in> range(f)"
	using rangeI by simp
    qed
    then show ?thesis using ZF_fun_from_total by simp
qed

text\<open>The values of the lift are defined by the value of the liftee in a
  natural way.\<close>

lemma func_ZF_1_L2:
  assumes A1: "f : Y\<times>Y\<rightarrow>Y"
  and A2: "p \<in> (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))" and A3: "x\<in>X"
  and A4: "P = {\<langle>x,f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>\<rangle>. x \<in> X}"
  shows "P`(x) = f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>"
proof -
  from A1 A2 have
    "{\<langle>x,f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>\<rangle>. x \<in> X} : X \<rightarrow> range(f)"
    using func_ZF_1_L1 by simp
  with A4 have "P :  X \<rightarrow> range(f)" by simp
  with  A3 A4 show "P`(x) = f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>"
    using ZF_fun_from_tot_val by simp
qed

text\<open>Function lifted to a function space results in  function space
  operator.\<close>

theorem func_ZF_1_L3:
  assumes "f : Y\<times>Y\<rightarrow>Y"
  and "F = f {lifted to function space over} X"
  shows "F : (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))\<rightarrow>(X\<rightarrow>range(f))"
  using assms Lift2FcnSpce_def func_ZF_1_L1 ZF_fun_from_total
  by simp

text\<open>The values of the lift are defined by the values of the liftee in
  the natural way.\<close>

theorem func_ZF_1_L4:
  assumes A1: "f : Y\<times>Y\<rightarrow>Y"
  and A2: "F = f {lifted to function space over} X"
  and A3: "s:X\<rightarrow>range(f)" "r:X\<rightarrow>range(f)"
  and A4: "x\<in>X"
  shows "(F`\<langle>s,r\<rangle>)`(x) = f`\<langle>s`(x),r`(x)\<rangle>"
proof -
  let ?p = "\<langle>s,r\<rangle>"
  let ?P = "{\<langle>x,f`\<langle>fst(?p)`(x),snd(?p)`(x)\<rangle>\<rangle>. x \<in> X}"
  from A1 A3 A4 have
    "f : Y\<times>Y\<rightarrow>Y"  "?p \<in> (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))"
    "x\<in>X"  "?P = {\<langle>x,f`\<langle>fst(?p)`(x),snd(?p)`(x)\<rangle>\<rangle>. x \<in> X}"
    by auto
  then have "?P`(x) = f`\<langle>fst(?p)`(x),snd(?p)`(x)\<rangle>"
    by (rule func_ZF_1_L2)
  hence "?P`(x) = f`\<langle>s`(x),r`(x)\<rangle>" by auto
  moreover have "?P = F`\<langle>s,r\<rangle>"
  proof -
    from A1 A2 have "F : (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))\<rightarrow>(X\<rightarrow>range(f))"
      using func_ZF_1_L3 by simp
    moreover from A3 have "?p \<in> (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))"
      by auto
    moreover from A2 have
      "F = {\<langle>p,{\<langle>x,f`\<langle>fst(p)`(x),snd(p)`(x)\<rangle>\<rangle>. x \<in> X}\<rangle>.
      p \<in> (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))}"
      using Lift2FcnSpce_def by simp
    ultimately show ?thesis using ZF_fun_from_tot_val
      by simp
  qed
  ultimately show "(F`\<langle>s,r\<rangle>)`(x) = f`\<langle>s`(x),r`(x)\<rangle>" by auto
qed

subsection\<open>Associative and commutative operations\<close>

text\<open>In this section we define associative and commutative operations
  and prove that they remain such when we lift them
  to a function space.\<close>

text\<open>Typically we say that a binary operation "$\cdot $"
  on a set $G$ is ''associative''
  if $(x\cdot y)\cdot z = x\cdot (y\cdot z)$ for all $x,y,z \in G$.
  Our actual definition below does not use the multiplicative notation
  so that we can apply it equally to the additive notation $+$
  or whatever infix symbol we may want to use.
  Instead, we use the generic set theory notation
  and write $P\langle x,y \rangle$ to denote the value of the operation
  $P$ on a pair $\langle x,y \rangle \in G\times G$.\<close>

definition
  IsAssociative (infix "{is associative on}" 65) where
  "P {is associative on} G \<equiv> P : G\<times>G\<rightarrow>G \<and>
  (\<forall> x \<in> G. \<forall> y \<in> G. \<forall> z \<in> G.
  ( P`(\<langle>P`(\<langle>x,y\<rangle>),z\<rangle>) = P`( \<langle>x,P`(\<langle>y,z\<rangle>)\<rangle> )))"

text\<open>A binary function $f: X\times X \rightarrow Y$ is commutative
  if $f\langle x,y \rangle = f\langle y,x \rangle$. Note that
  in the definition of associativity above we talk about binary
  ''operation'' and here we say use the term binary ''function''.
  This is not set in stone, but usually the word "operation" is used
  when the range is a factor of the domain, while the word "function"
  allows the range to be a completely unrelated set.\<close>

definition
  IsCommutative (infix "{is commutative on}" 65) where
  "f {is commutative on} G \<equiv> \<forall>x\<in>G. \<forall>y\<in>G. f`\<langle>x,y\<rangle> = f`\<langle>y,x\<rangle>"

text\<open>The lift of a commutative function is commutative.\<close>

lemma func_ZF_2_L1:
  assumes A1: "f : G\<times>G\<rightarrow>G"
  and A2: "F = f {lifted to function space over} X"
  and A3: "s : X\<rightarrow>range(f)" "r : X\<rightarrow>range(f)"
  and A4: "f {is commutative on} G"
  shows "F`\<langle>s,r\<rangle> = F`\<langle>r,s\<rangle>"
proof -
  from A1 A2 have
    "F : (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))\<rightarrow>(X\<rightarrow>range(f))"
    using func_ZF_1_L3 by simp
  with A3 have
    "F`\<langle>s,r\<rangle> : X\<rightarrow>range(f)" and "F`\<langle>r,s\<rangle> : X\<rightarrow>range(f)"
    using apply_type by auto
  moreover have
    "\<forall>x\<in>X. (F`\<langle>s,r\<rangle>)`(x) = (F`\<langle>r,s\<rangle>)`(x)"
  proof
    fix x assume "x\<in>X"
    from A1 have "range(f)\<subseteq>G"
      using func1_1_L5B by simp
    with A3 \<open>x\<in>X\<close> have "s`(x) \<in> G" and "r`(x) \<in> G"
      using apply_type by auto
    with A1 A2 A3 A4 \<open>x\<in>X\<close> show
      "(F`\<langle>s,r\<rangle>)`(x) = (F`\<langle>r,s\<rangle>)`(x)"
      using func_ZF_1_L4 IsCommutative_def by simp
  qed
  ultimately show ?thesis using fun_extension_iff
    by simp
qed

text\<open>The lift of a commutative function is commutative
  on the function space.\<close>

lemma func_ZF_2_L2:
  assumes "f : G\<times>G\<rightarrow>G"
  and "f {is commutative on} G"
  and "F = f {lifted to function space over} X"
  shows "F {is commutative on} (X\<rightarrow>range(f))"
  using assms IsCommutative_def func_ZF_2_L1 by simp

text\<open>The lift of an associative function is associative.\<close>

lemma func_ZF_2_L3:
  assumes A2: "F = f {lifted to function space over} X"
  and A3: "s : X\<rightarrow>range(f)" "r : X\<rightarrow>range(f)" "q : X\<rightarrow>range(f)"
  and A4: "f {is associative on} G"
  shows "F`\<langle>F`\<langle>s,r\<rangle>,q\<rangle> = F`\<langle>s,F`\<langle>r,q\<rangle>\<rangle>"
proof -
  from A4 A2 have
    "F : (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))\<rightarrow>(X\<rightarrow>range(f))"
    using IsAssociative_def func_ZF_1_L3 by auto
  with A3 have I:
    "F`\<langle>s,r\<rangle> : X\<rightarrow>range(f)"
    "F`\<langle>r,q\<rangle> : X\<rightarrow>range(f)"
    "F`\<langle>F`\<langle>s,r\<rangle>,q\<rangle> : X\<rightarrow>range(f)"
    "F`\<langle>s,F`\<langle>r,q\<rangle>\<rangle>: X\<rightarrow>range(f)"
    using apply_type by auto
  moreover have
    "\<forall>x\<in>X. (F`\<langle>F`\<langle>s,r\<rangle>,q\<rangle>)`(x) = (F`\<langle>s,F`\<langle>r,q\<rangle>\<rangle>)`(x)"
  proof
    fix x assume "x\<in>X"
    from A4 have "f:G\<times>G\<rightarrow>G"
      using IsAssociative_def by simp
    then have "range(f)\<subseteq>G"
      using func1_1_L5B by simp
    with A3 \<open>x\<in>X\<close> have
      "s`(x) \<in> G" "r`(x) \<in> G" "q`(x) \<in> G"
      using apply_type by auto
    with A2 I A3 A4 \<open>x\<in>X\<close> \<open>f:G\<times>G\<rightarrow>G\<close> show
      "(F`\<langle>F`\<langle>s,r\<rangle>,q\<rangle>)`(x) = (F`\<langle>s,F`\<langle>r,q\<rangle>\<rangle>)`(x)"
      using func_ZF_1_L4 IsAssociative_def by simp
  qed
  ultimately show ?thesis using fun_extension_iff
    by simp
qed

text\<open>The lift of an associative function is associative
  on the function space.\<close>

lemma func_ZF_2_L4:
  assumes A1: "f {is associative on} G"
  and A2: "F = f {lifted to function space over} X"
  shows "F {is associative on} (X\<rightarrow>range(f))"
proof -
  from A1 A2 have
    "F : (X\<rightarrow>range(f))\<times>(X\<rightarrow>range(f))\<rightarrow>(X\<rightarrow>range(f))"
    using IsAssociative_def func_ZF_1_L3 by auto
  moreover from A1 A2 have
    "\<forall>s \<in> X\<rightarrow>range(f). \<forall> r \<in> X\<rightarrow>range(f). \<forall>q \<in> X\<rightarrow>range(f).
    F`\<langle>F`\<langle>s,r\<rangle>,q\<rangle> = F`\<langle>s,F`\<langle>r,q\<rangle>\<rangle>"
    using func_ZF_2_L3 by simp
  ultimately show ?thesis using IsAssociative_def
    by simp
qed

subsection\<open>Restricting operations\<close>

text\<open>In this section we consider conditions under which
  restriction of the operation to a set
  inherits properties like commutativity and associativity.\<close>

text\<open>The commutativity is inherited when restricting a function to a set.\<close>

lemma func_ZF_4_L1:
  assumes A1: "f:X\<times>X\<rightarrow>Y" and A2: "A\<subseteq>X"
  and A3: "f {is commutative on} X"
  shows "restrict(f,A\<times>A) {is commutative on} A"
proof -
  { fix x y assume "x\<in>A" and "y\<in>A"
    with A2 have "x\<in>X" and "y\<in>X" by auto
    with A3 \<open>x\<in>A\<close> \<open>y\<in>A\<close> have
      "restrict(f,A\<times>A)`\<langle>x,y\<rangle> = restrict(f,A\<times>A)`\<langle>y,x\<rangle>"
      using IsCommutative_def restrict_if by simp }
  then show ?thesis using IsCommutative_def by simp
qed

text\<open>Next we define what it means that a set is closed with
  respect to an operation.\<close>

definition
  IsOpClosed (infix "{is closed under}" 65) where
  "A {is closed under} f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. f`\<langle>x,y\<rangle> \<in> A"

text\<open>Associative operation restricted to a set that is closed with
  resp. to this operation is associative.\<close>

lemma func_ZF_4_L2:assumes A1: "f {is associative on} X"
  and A2: "A\<subseteq>X" and A3: "A {is closed under} f"
  and A4: "x\<in>A" "y\<in>A" "z\<in>A"
  and A5: "g = restrict(f,A\<times>A)"
  shows "g`\<langle>g`\<langle>x,y\<rangle>,z\<rangle> = g`\<langle>x,g`\<langle>y,z\<rangle>\<rangle>"
proof -
  from A4 A2 have I: "x\<in>X" "y\<in>X" "z\<in>X"
    by auto
  from A3 A4 A5 have
    "g`\<langle>g`\<langle>x,y\<rangle>,z\<rangle> = f`\<langle>f`\<langle>x,y\<rangle>,z\<rangle>"
    "g`\<langle>x,g`\<langle>y,z\<rangle>\<rangle> = f`\<langle>x,f`\<langle>y,z\<rangle>\<rangle>"
    using IsOpClosed_def restrict_if by auto
  moreover from A1 I have
    "f`\<langle>f`\<langle>x,y\<rangle>,z\<rangle> = f`\<langle>x,f`\<langle>y,z\<rangle>\<rangle>"
    using IsAssociative_def by simp
  ultimately show ?thesis by simp
qed

text\<open>An associative operation restricted to a set that is closed with
  resp. to this operation is associative on the set.\<close>

lemma func_ZF_4_L3: assumes A1: "f {is associative on} X"
  and A2: "A\<subseteq>X" and A3: "A {is closed under} f"
  shows "restrict(f,A\<times>A) {is associative on} A"
proof -
  let ?g = "restrict(f,A\<times>A)"
  from A1 have "f:X\<times>X\<rightarrow>X"
    using IsAssociative_def by simp
  moreover from A2 have "A\<times>A \<subseteq> X\<times>X" by auto
  moreover from A3 have "\<forall>p \<in> A\<times>A. ?g`(p) \<in> A"
    using IsOpClosed_def restrict_if by auto
  ultimately have "?g : A\<times>A\<rightarrow>A"
    using func1_2_L4 by simp
  moreover from  A1 A2 A3 have
    "\<forall> x \<in> A. \<forall> y \<in> A. \<forall> z \<in> A.
    ?g`\<langle>?g`\<langle>x,y\<rangle>,z\<rangle> = ?g`\<langle> x,?g`\<langle>y,z\<rangle>\<rangle>"
    using func_ZF_4_L2 by simp
  ultimately show ?thesis
    using IsAssociative_def by simp
qed

text\<open>The essential condition to show that if a set $A$ is closed
  with respect to an operation,
  then it is closed under this operation restricted
  to any superset of $A$.\<close>

lemma func_ZF_4_L4: assumes "A {is closed under} f"
  and "A\<subseteq>B" and "x\<in>A"  "y\<in>A" and "g = restrict(f,B\<times>B)"
  shows "g`\<langle>x,y\<rangle> \<in> A"
  using assms IsOpClosed_def restrict by auto

text\<open>If a set $A$ is closed under an operation,
  then it is closed under this operation restricted
  to any superset of $A$.\<close>

lemma func_ZF_4_L5:
  assumes A1: "A {is closed under} f"
  and A2: "A\<subseteq>B"
  shows "A {is closed under} restrict(f,B\<times>B)"
proof -
  let ?g = "restrict(f,B\<times>B)"
  from A1 A2 have "\<forall>x\<in>A. \<forall>y\<in>A. ?g`\<langle>x,y\<rangle> \<in> A"
    using func_ZF_4_L4 by simp
  then show ?thesis using IsOpClosed_def by simp
qed

text\<open>The essential condition to show that intersection of sets that are
  closed with respect to an operation is closed with respect
  to the operation.\<close>

lemma func_ZF_4_L6:
  assumes "A {is closed under} f"
  and "B {is closed under} f"
  and "x \<in> A\<inter>B" "y\<in> A\<inter>B"
  shows "f`\<langle>x,y\<rangle> \<in> A\<inter>B" using assms IsOpClosed_def by auto

text\<open>Intersection of sets that are
  closed with respect to an operation is closed under
  the operation.\<close>

lemma func_ZF_4_L7:
  assumes "A {is closed under} f"
  "B {is closed under} f"
  shows "A\<inter>B {is closed under} f"
  using assms IsOpClosed_def by simp

subsection\<open>Compositions\<close>

text\<open>For any set $X$ we can consider a binary operation
  on the set of functions
  $f:X\rightarrow X$ defined by $C(f,g) = f\circ g$. Composition of functions
  (or relations) is defined in the standard Isabelle distribution as a higher
  order function and denoted with the letter \<open>O\<close>.
  In this section we consider the corresponding two-argument
  ZF-function (binary operation), that is a subset of
  $((X\rightarrow X)\times (X\rightarrow X))\times (X\rightarrow X)$.\<close>

text\<open>We define the notion of composition on the set $X$ as the
  binary operation on the function space $X\rightarrow X$
  that takes two functions and creates the their composition.\<close>

definition
  "Composition(X) \<equiv>
  {\<langle>p,fst(p) O snd(p)\<rangle>. p \<in> (X\<rightarrow>X)\<times>(X\<rightarrow>X)}"

text\<open>Composition operation is a function that maps
  $(X\rightarrow X)\times (X\rightarrow X)$ into $X\rightarrow X$.\<close>

lemma func_ZF_5_L1: shows "Composition(X) : (X\<rightarrow>X)\<times>(X\<rightarrow>X)\<rightarrow>(X\<rightarrow>X)"
  using comp_fun Composition_def ZF_fun_from_total by simp

text\<open>The value of the composition operation is the composition of arguments.\<close>

lemma func_ZF_5_L2: assumes "f:X\<rightarrow>X" and "g:X\<rightarrow>X"
  shows "Composition(X)`\<langle>f,g\<rangle> = f O g"
proof -
  from assms have
    "Composition(X) : (X\<rightarrow>X)\<times>(X\<rightarrow>X)\<rightarrow>(X\<rightarrow>X)"
    "\<langle>f,g\<rangle> \<in> (X\<rightarrow>X)\<times>(X\<rightarrow>X)"
    "Composition(X) = {\<langle>p,fst(p) O snd(p)\<rangle>. p \<in> (X\<rightarrow>X)\<times>(X\<rightarrow>X)}"
    using  func_ZF_5_L1 Composition_def by auto
  then show "Composition(X)`\<langle>f,g\<rangle> = f O g"
    using  ZF_fun_from_tot_val by auto
qed

text\<open>What is the value of a composition on an argument?\<close>

lemma func_ZF_5_L3: assumes "f:X\<rightarrow>X" and "g:X\<rightarrow>X" and "x\<in>X"
  shows "(Composition(X)`\<langle>f,g\<rangle>)`(x) = f`(g`(x))"
  using assms func_ZF_5_L2 comp_fun_apply by simp

text\<open>The essential condition to show that composition is associative.\<close>

lemma func_ZF_5_L4: assumes A1: "f:X\<rightarrow>X" "g:X\<rightarrow>X" "h:X\<rightarrow>X"
  and A2: "C = Composition(X)"
  shows "C`\<langle>C`\<langle>f,g\<rangle>,h\<rangle> = C`\<langle> f,C`\<langle>g,h\<rangle>\<rangle>"
proof -
  from A2 have "C : ((X\<rightarrow>X)\<times>(X\<rightarrow>X))\<rightarrow>(X\<rightarrow>X)"
    using func_ZF_5_L1 by simp
  with A1 have I:
    "C`\<langle>f,g\<rangle> : X\<rightarrow>X"
    "C`\<langle>g,h\<rangle> : X\<rightarrow>X"
    "C`\<langle>C`\<langle>f,g\<rangle>,h\<rangle> : X\<rightarrow>X"
    "C`\<langle> f,C`\<langle>g,h\<rangle>\<rangle> : X\<rightarrow>X"
    using apply_funtype by auto
  moreover have
    "\<forall> x \<in> X. C`\<langle>C`\<langle>f,g\<rangle>,h\<rangle>`(x) = C`\<langle>f,C`\<langle>g,h\<rangle>\<rangle>`(x)"
  proof
    fix x assume "x\<in>X"
    with A1 A2 I have
      "C`\<langle>C`\<langle>f,g\<rangle>,h\<rangle> ` (x) = f`(g`(h`(x)))"
      "C`\<langle> f,C`\<langle>g,h\<rangle>\<rangle>`(x) = f`(g`(h`(x)))"
      using func_ZF_5_L3 apply_funtype by auto
    then show "C`\<langle>C`\<langle>f,g\<rangle>,h\<rangle>`(x) = C`\<langle> f,C`\<langle>g,h\<rangle>\<rangle>`(x)"
      by simp
    qed
  ultimately show ?thesis using fun_extension_iff by simp
qed

text\<open>Composition is an associative operation on $X\rightarrow X$ (the space
  of functions that map $X$ into itself).\<close>

lemma func_ZF_5_L5: shows "Composition(X) {is associative on} (X\<rightarrow>X)"
proof -
  let ?C = "Composition(X)"
  have "\<forall>f\<in>X\<rightarrow>X. \<forall>g\<in>X\<rightarrow>X. \<forall>h\<in>X\<rightarrow>X.
    ?C`\<langle>?C`\<langle>f,g\<rangle>,h\<rangle> = ?C`\<langle>f,?C`\<langle>g,h\<rangle>\<rangle>"
    using func_ZF_5_L4 by simp
  then show ?thesis using func_ZF_5_L1 IsAssociative_def
    by simp
qed

subsection\<open>Identity function\<close>

text\<open>In this section we show some additional facts about the identity
  function defined in the standard Isabelle's \<open>Perm\<close> theory.
  Note there is also \<open>image_id_same\<close> lemma in \<open>func1\<close> theory.
  \<close>

text\<open>A function that maps every point to itself is the identity on its domain.\<close>

lemma indentity_fun: assumes A1: "f:X\<rightarrow>Y" and A2:"\<forall>x\<in>X. f`(x)=x"
  shows "f = id(X)"
proof -
  from assms have "f:X\<rightarrow>Y" and "id(X):X\<rightarrow>X" and "\<forall>x\<in>X. f`(x) = id(X)`(x)"
    using id_type id_conv by auto
  then show ?thesis by (rule func_eq)
qed

text\<open>Composing a function with identity does not change the function.\<close>

lemma func_ZF_6_L1A: assumes A1: "f : X\<rightarrow>X"
  shows "Composition(X)`\<langle>f,id(X)\<rangle> = f"
  "Composition(X)`\<langle>id(X),f\<rangle> = f"
proof -
  have "Composition(X) : (X\<rightarrow>X)\<times>(X\<rightarrow>X)\<rightarrow>(X\<rightarrow>X)"
    using func_ZF_5_L1 by simp
  with A1 have "Composition(X)`\<langle>id(X),f\<rangle> : X\<rightarrow>X"
    "Composition(X)`\<langle>f,id(X)\<rangle> : X\<rightarrow>X"
    using id_type apply_funtype by auto
  moreover note A1
  moreover from A1 have
    "\<forall>x\<in>X. (Composition(X)`\<langle>id(X),f\<rangle>)`(x) = f`(x)"
    "\<forall>x\<in>X. (Composition(X)`\<langle>f,id(X)\<rangle>)`(x) = f`(x)"
    using id_type func_ZF_5_L3 apply_funtype id_conv
    by auto
  ultimately show "Composition(X)`\<langle>id(X),f\<rangle> = f"
    "Composition(X)`\<langle>f,id(X)\<rangle> = f"
    using fun_extension_iff by auto
qed

text\<open>An intuitively clear, but surprisingly nontrivial fact: identity is the only function from
  a singleton to itself.\<close>

lemma singleton_fun_id: shows "({x} \<rightarrow> {x}) = {id({x})}"
proof
  show "{id({x})} \<subseteq> ({x} \<rightarrow> {x})"
    using id_def by simp
  { let ?g = "id({x})"
    fix f assume "f : {x} \<rightarrow> {x}"
    then have "f : {x} \<rightarrow> {x}" and "?g : {x} \<rightarrow> {x}"
      using id_def by auto
    moreover from \<open>f : {x} \<rightarrow> {x}\<close> have "\<forall>x \<in> {x}. f`(x) = ?g`(x)"
      using apply_funtype id_def by auto
    ultimately have "f = ?g" by (rule func_eq)
  } then show  "({x} \<rightarrow> {x}) \<subseteq> {id({x})}" by auto
qed

text\<open>Another trivial fact: identity is the only bijection of a singleton
  with itself.\<close>

lemma single_bij_id: shows "bij({x},{x}) = {id({x})}"
proof
  show "{id({x})} \<subseteq> bij({x},{x})" using id_bij
    by simp
  { fix f assume "f \<in> bij({x},{x})"
    then have "f : {x} \<rightarrow> {x}" using bij_is_fun
      by simp
    then have "f \<in> {id({x})}" using singleton_fun_id
      by simp
  } then show "bij({x},{x}) \<subseteq> {id({x})}" by auto
qed

text\<open>A kind of induction for the identity: if a function
  $f$ is the identity on a set with a fixpoint of $f$
  removed, then it is the indentity on the whole set.\<close>

lemma id_fixpoint_rem: assumes A1: "f:X\<rightarrow>X" and
  A2: "p\<in>X" and A3: "f`(p) = p" and
  A4: "restrict(f, X-{p}) = id(X-{p})"
  shows "f = id(X)"
proof -
  from A1 have "f: X\<rightarrow>X" and "id(X) : X\<rightarrow>X"
    using id_def by auto
  moreover
  { fix x assume "x\<in>X"
    { assume "x \<in> X-{p}"
      then have "f`(x) = restrict(f, X-{p})`(x)"
	using restrict by simp
      with A4 \<open>x \<in> X-{p}\<close> have "f`(x) = x"
	using id_def by simp }
    with A2 A3 \<open>x\<in>X\<close> have "f`(x) = x" by auto
  } then have "\<forall>x\<in>X. f`(x) = id(X)`(x)"
    using id_def by simp
  ultimately show "f = id(X)" by (rule func_eq)
qed

subsection\<open>Lifting to subsets\<close>

text\<open>Suppose we have a binary operation $f : X \times X \rightarrow X$
  written additively as $f\langle x,y\rangle = x + y$. Such operation
  naturally defines another binary operation on the subsets of $X$
  that satisfies $A+B = \{ x+y : x \in A, y\in B\}$. This new operation
  which we will call "$f$ lifted to subsets" inherits many properties
  of $f$, such as associativity, commutativity and existence of the
  neutral element. This notion is useful for considering interval arithmetics.
\<close>

text\<open>The next definition describes the notion of a binary operation
  lifted to subsets. It is written in a way that might be a bit unexpected,
  but really it is the same as the intuitive definition, but shorter.
  In the definition we take a pair $p \in Pow(X)\times Pow(X)$, say
  $p = \langle A, B\rangle $, where $A,B \subseteq X$.
  Then we assign this pair of sets the set
  $\{f\langle x,y \rangle : x\in A, y\in B \} = \{ f(x'): x' \in A\times B\}$
  The set on the right hand side is the same as the image
  of $A\times B$ under $f$. In the definition we don't use $A$ and $B$ symbols,
  but write \<open>fst(p)\<close> and \<open>snd(p)\<close>, resp. Recall that in Isabelle/ZF
  \<open>fst(p)\<close> and  \<open>snd(p)\<close> denote the first and second components
  of an ordered pair $p$.
  See the lemma \<open>lift_subsets_explained\<close> for a more intuitive
  notation.\<close>

definition
  Lift2Subsets (infix "{lifted to subsets of}" 65) where
  "f {lifted to subsets of} X \<equiv>
  {\<langle>p, f``(fst(p)\<times>snd(p))\<rangle>. p \<in> Pow(X)\<times>Pow(X)}"

text\<open>The lift to subsets defines a binary operation on the subsets.\<close>

lemma lift_subsets_binop: assumes A1: "f : X \<times> X \<rightarrow> Y"
  shows "(f {lifted to subsets of} X) : Pow(X) \<times> Pow(X) \<rightarrow> Pow(Y)"
proof -
  let ?F = "{\<langle>p, f``(fst(p)\<times>snd(p))\<rangle>. p \<in> Pow(X)\<times>Pow(X)}"
  from A1 have "\<forall>p \<in> Pow(X) \<times> Pow(X). f``(fst(p)\<times>snd(p)) \<in> Pow(Y)"
    using func1_1_L6 by simp
  then have "?F : Pow(X) \<times> Pow(X) \<rightarrow> Pow(Y)"
    by (rule ZF_fun_from_total)
  then show ?thesis unfolding Lift2Subsets_def by simp
qed

text\<open>The definition of the lift to subsets rewritten in a more intuitive
  notation. We would like to write the last assertion as
  \<open>F`\<langle>A,B\<rangle> = {f`\<langle>x,y\<rangle>. x \<in> A, y \<in> B}\<close>, but Isabelle/ZF does not allow
  such syntax.\<close>

lemma lift_subsets_explained: assumes A1: "f : X\<times>X \<rightarrow> Y"
  and A2: "A \<subseteq> X"  "B \<subseteq> X" and A3: "F = f {lifted to subsets of} X"
  shows
  "F`\<langle>A,B\<rangle> \<subseteq> Y" and
  "F`\<langle>A,B\<rangle> = f``(A\<times>B)"
  "F`\<langle>A,B\<rangle> = {f`(p). p \<in> A\<times>B}"
  "F`\<langle>A,B\<rangle> = {f`\<langle>x,y\<rangle> . \<langle>x,y\<rangle> \<in> A\<times>B}"
proof -
  let ?p = "\<langle>A,B\<rangle>"
  from assms have
    I: "F : Pow(X) \<times> Pow(X) \<rightarrow> Pow(Y)" and  "?p \<in> Pow(X) \<times> Pow(X)"
    using lift_subsets_binop by auto
  moreover from A3 have "F = {\<langle>p, f``(fst(p)\<times>snd(p))\<rangle>. p \<in> Pow(X)\<times>Pow(X)}"
    unfolding  Lift2Subsets_def by simp
  ultimately show "F`\<langle>A,B\<rangle> =  f``(A\<times>B)"
    using  ZF_fun_from_tot_val by auto
  also
  from A1 A2 have "A\<times>B \<subseteq> X\<times>X" by auto
  with A1 have "f``(A\<times>B) = {f`(p). p \<in> A\<times>B}"
    by (rule func_imagedef)
  finally show  "F`\<langle>A,B\<rangle> = {f`(p) . p \<in> A\<times>B}" by simp
  also
  have "\<forall>x\<in>A. \<forall>y \<in> B. f`\<langle>x,y\<rangle> = f`\<langle>x,y\<rangle>" by simp
  then have "{f`(p). p \<in> A\<times>B} = {f`\<langle>x,y\<rangle>.  \<langle>x,y\<rangle> \<in> A\<times>B}"
    by (rule ZF1_1_L4A)
  finally show "F`\<langle>A,B\<rangle> = {f`\<langle>x,y\<rangle> . \<langle>x,y\<rangle> \<in> A\<times>B}"
    by simp
  from A2 I show "F`\<langle>A,B\<rangle> \<subseteq> Y" using apply_funtype by blast
qed

text\<open>A sufficient condition for a point to belong to a result of
  lifting to subsets.\<close>

lemma lift_subset_suff:  assumes A1: "f : X \<times> X \<rightarrow> Y" and
  A2: "A \<subseteq> X"  "B \<subseteq> X" and A3: "x\<in>A" "y\<in>B" and
  A4: "F = f {lifted to subsets of} X"
  shows "f`\<langle>x,y\<rangle> \<in> F`\<langle>A,B\<rangle>"
proof -
  from A3 have "f`\<langle>x,y\<rangle> \<in> {f`(p) . p \<in> A\<times>B}" by auto
  moreover from A1 A2 A4 have "{f`(p). p \<in> A\<times>B} = F`\<langle>A,B\<rangle> "
    using lift_subsets_explained by simp
  ultimately show "f`\<langle>x,y\<rangle> \<in> F`\<langle>A,B\<rangle>" by simp
qed

text\<open>A kind of converse of \<open>lift_subset_apply\<close>, providing
  a necessary condition for a point to be in the result of lifting to
  subsets.\<close>

lemma lift_subset_nec: assumes A1: "f : X \<times> X \<rightarrow> Y" and
  A2: "A \<subseteq> X"  "B \<subseteq> X" and
  A3: "F = f {lifted to subsets of} X" and
  A4: "z \<in> F`\<langle>A,B\<rangle>"
  shows "\<exists>x y. x\<in>A \<and> y\<in>B \<and> z = f`\<langle>x,y\<rangle>"
proof -
  from A1 A2 A3 have "F`\<langle>A,B\<rangle> = {f`(p). p \<in> A\<times>B}"
    using lift_subsets_explained by simp
  with A4 show ?thesis by auto
qed

text\<open>Lifting to subsets inherits commutativity.\<close>

lemma lift_subset_comm: assumes A1: "f : X \<times> X \<rightarrow> Y" and
  A2: "f {is commutative on} X" and
  A3: "F = f {lifted to subsets of} X"
  shows "F {is commutative on} Pow(X)"
proof -
  have "\<forall>A \<in> Pow(X). \<forall>B \<in> Pow(X). F`\<langle>A,B\<rangle> = F`\<langle>B,A\<rangle>"
  proof -
    { fix A assume "A \<in> Pow(X)"
      fix B assume "B \<in> Pow(X)"
      have  "F`\<langle>A,B\<rangle> = F`\<langle>B,A\<rangle>"
      proof -
	have "\<forall>z \<in>  F`\<langle>A,B\<rangle>. z \<in>  F`\<langle>B,A\<rangle>"
	proof
	  fix z assume I: "z \<in> F`\<langle>A,B\<rangle>"
	  with A1 A3 \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> have
	    "\<exists>x y. x\<in>A \<and> y\<in>B \<and> z = f`\<langle>x,y\<rangle>"
	    using lift_subset_nec by simp
	  then obtain x y where "x\<in>A" and "y\<in>B" and "z = f`\<langle>x,y\<rangle>"
	    by auto
	  with A2 \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> have "z = f`\<langle>y,x\<rangle>"
	    using IsCommutative_def by auto
	  with A1 A3 I \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> \<open>x\<in>A\<close> \<open>y\<in>B\<close>
	  show "z \<in> F`\<langle>B,A\<rangle>" using lift_subset_suff by simp
	qed
	moreover have "\<forall>z \<in>  F`\<langle>B,A\<rangle>. z \<in>  F`\<langle>A,B\<rangle>"
	proof
	  fix z assume I: "z \<in> F`\<langle>B,A\<rangle>"
	  with A1 A3 \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> have
	    "\<exists>x y. x\<in>B \<and> y\<in>A \<and> z = f`\<langle>x,y\<rangle>"
	    using lift_subset_nec by simp
	  then obtain x y where "x\<in>B" and "y\<in>A" and "z = f`\<langle>x,y\<rangle>"
	    by auto
	  with A2 \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> have "z = f`\<langle>y,x\<rangle>"
	    using IsCommutative_def by auto
	  with A1 A3 I \<open>A \<in> Pow(X)\<close> \<open>B \<in> Pow(X)\<close> \<open>x\<in>B\<close> \<open>y\<in>A\<close>
	  show "z \<in> F`\<langle>A,B\<rangle>" using lift_subset_suff by simp
	qed
	ultimately show "F`\<langle>A,B\<rangle> = F`\<langle>B,A\<rangle>" by auto
      qed
    } thus ?thesis by auto
  qed
  then show "F {is commutative on} Pow(X)"
    unfolding IsCommutative_def by auto
qed

text\<open>Lifting to subsets inherits associativity.
  To show that
  $F\langle \langle A,B\rangle C\rangle = F\langle A,F\langle B,C\rangle\rangle$
  we prove two inclusions and the proof of the second inclusion is very similar
  to the proof of the first one.\<close>

lemma lift_subset_assoc:  assumes
  A1: "f {is associative on} X" and A2: "F = f {lifted to subsets of} X"
  shows "F {is associative on} Pow(X)"
proof -
  from A1 have "f : X\<times>X \<rightarrow> X" unfolding IsAssociative_def by simp
  with A2 have "F : Pow(X)\<times>Pow(X) \<rightarrow> Pow(X)"
    using lift_subsets_binop by simp
  moreover have "\<forall>A \<in> Pow(X).\<forall>B \<in> Pow(X). \<forall>C \<in> Pow(X).
    F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle> = F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle>"
  proof -
    { fix A B C
      assume "A \<in> Pow(X)"  "B \<in> Pow(X)"  "C \<in> Pow(X)"
      have "F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle> \<subseteq> F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle>"
      proof
	fix z assume I: "z \<in> F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle>"
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close>
	have "F`\<langle>A,B\<rangle> \<in> Pow(X)"
	  using lift_subsets_binop apply_funtype by blast
	with \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>C \<in> Pow(X)\<close> I have
	  "\<exists>x y. x \<in> F`\<langle>A,B\<rangle> \<and> y \<in> C \<and> z = f`\<langle>x,y\<rangle>"
	  using lift_subset_nec by simp
	then obtain x y where
	  II: "x \<in> F`\<langle>A,B\<rangle>" and "y \<in> C" and III: "z = f`\<langle>x,y\<rangle>"
	  by auto
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close> II have
	  "\<exists> s t. s \<in> A \<and> t \<in> B \<and> x = f`\<langle>s,t\<rangle>"
	  using lift_subset_nec by auto
	then obtain s t where "s\<in>A" and "t\<in>B" and "x = f`\<langle>s,t\<rangle>"
	  by auto
	with A1 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close> \<open>C \<in> Pow(X)\<close> III
	  \<open>s\<in>A\<close> \<open>t\<in>B\<close> \<open>y\<in>C\<close> have IV: "z = f`\<langle>s, f`\<langle>t,y\<rangle>\<rangle>"
	  using IsAssociative_def by blast
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>B \<in> Pow(X)\<close>  \<open>C \<in> Pow(X)\<close>  \<open>t\<in>B\<close>  \<open>y\<in>C\<close>
	have "f`\<langle>t,y\<rangle> \<in> F`\<langle>B,C\<rangle>" using lift_subset_suff by simp
	moreover from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>B \<in> Pow(X)\<close>  \<open>C \<in> Pow(X)\<close>
	have "F`\<langle>B,C\<rangle> \<subseteq> X" using lift_subsets_binop apply_funtype
	  by blast
	moreover note \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close> \<open>s\<in>A\<close> IV
	ultimately show "z \<in> F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle>"
	  using lift_subset_suff by simp
      qed
      moreover have "F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle> \<subseteq> F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle>"
      proof
	fix z assume I: "z \<in> F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle>"
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>B \<in> Pow(X)\<close> \<open>C \<in> Pow(X)\<close>
	have "F`\<langle>B,C\<rangle> \<in> Pow(X)"
	  using lift_subsets_binop apply_funtype by blast
	with \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close> I have
	  "\<exists>x y. x \<in> A \<and> y \<in> F`\<langle>B,C\<rangle> \<and> z = f`\<langle>x,y\<rangle>"
	  using lift_subset_nec by simp
	then obtain x y where
	  "x \<in> A" and II: "y \<in> F`\<langle>B,C\<rangle>" and III: "z = f`\<langle>x,y\<rangle>"
	  by auto
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>B \<in> Pow(X)\<close>  \<open>C \<in> Pow(X)\<close> II have
	  "\<exists> s t. s \<in> B \<and> t \<in> C \<and> y = f`\<langle>s,t\<rangle>"
	  using lift_subset_nec by auto
	then obtain s t where "s\<in>B" and "t\<in>C" and "y = f`\<langle>s,t\<rangle>"
	  by auto
	with III have "z = f`\<langle>x,f`\<langle>s,t\<rangle>\<rangle>" by simp
	moreover from A1 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close>  \<open>C \<in> Pow(X)\<close>
	  \<open>x\<in>A\<close> \<open>s\<in>B\<close> \<open>t\<in>C\<close> have "f`\<langle>f`\<langle>x,s\<rangle>,t\<rangle> = f`\<langle>x,f`\<langle>s,t\<rangle>\<rangle>"
	  using IsAssociative_def by blast
	ultimately have IV: "z = f`\<langle>f`\<langle>x,s\<rangle>,t\<rangle>" by simp
	from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close>  \<open>x\<in>A\<close>  \<open>s\<in>B\<close>
	have "f`\<langle>x,s\<rangle> \<in> F`\<langle>A,B\<rangle>" using lift_subset_suff by simp
	moreover from \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>A \<in> Pow(X)\<close>  \<open>B \<in> Pow(X)\<close>
	have "F`\<langle>A,B\<rangle> \<subseteq> X" using lift_subsets_binop apply_funtype
	  by blast
	moreover note \<open>f:X\<times>X \<rightarrow> X\<close> A2 \<open>C \<in> Pow(X)\<close> \<open>t\<in>C\<close> IV
	ultimately show "z \<in> F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle>"
	  using lift_subset_suff by simp
      qed
      ultimately have "F`\<langle>F`\<langle>A,B\<rangle>,C\<rangle> = F`\<langle>A,F`\<langle>B,C\<rangle>\<rangle>" by auto
    } thus ?thesis by auto
  qed
  ultimately show ?thesis unfolding IsAssociative_def
    by auto
qed

subsection\<open>Distributive operations\<close>

text\<open>In this section we deal with pairs of operations such that one is
  distributive with respect to the other, that is
  $a\cdot (b+c) = a\cdot b + a\cdot c$ and
  $(b+c)\cdot a = b\cdot a + c\cdot a$. We show that this property is
  preserved under restriction to a set closed with respect to both
  operations. In \<open>EquivClass1\<close> theory we show that this property is
  preserved by projections to the quotient space if both operations are
  congruent with respect to the equivalence relation.\<close>

text\<open>We define distributivity as a statement about three sets. The first
  set is the set on which the operations act. The second set is the
  additive operation (a ZF function) and the third is the multiplicative
  operation.\<close>

definition
  "IsDistributive(X,A,M) \<equiv> (\<forall>a\<in>X.\<forall>b\<in>X.\<forall>c\<in>X.
  M`\<langle>a,A`\<langle>b,c\<rangle>\<rangle> = A`\<langle>M`\<langle>a,b\<rangle>,M`\<langle>a,c\<rangle>\<rangle> \<and>
  M`\<langle>A`\<langle>b,c\<rangle>,a\<rangle> = A`\<langle>M`\<langle>b,a\<rangle>,M`\<langle>c,a\<rangle> \<rangle>)"

text\<open>The essential condition to show that distributivity is preserved by
  restrictions to sets that are closed with
  respect to both operations.\<close>

lemma func_ZF_7_L1:
  assumes A1: "IsDistributive(X,A,M)"
  and A2: "Y\<subseteq>X"
  and A3: "Y {is closed under} A"  "Y {is closed under} M"
  and A4: "A\<^sub>r = restrict(A,Y\<times>Y)" "M\<^sub>r = restrict(M,Y\<times>Y)"
  and A5: "a\<in>Y"  "b\<in>Y"  "c\<in>Y"
  shows "M\<^sub>r`\<langle> a,A\<^sub>r`\<langle>b,c\<rangle> \<rangle>  = A\<^sub>r`\<langle> M\<^sub>r`\<langle>a,b\<rangle>,M\<^sub>r`\<langle>a,c\<rangle> \<rangle>  \<and>
  M\<^sub>r`\<langle> A\<^sub>r`\<langle>b,c\<rangle>,a \<rangle> = A\<^sub>r`\<langle> M\<^sub>r`\<langle>b,a\<rangle>, M\<^sub>r`\<langle>c,a\<rangle> \<rangle>"
proof -
  from A3 A5 have "A`\<langle>b,c\<rangle> \<in> Y"  "M`\<langle>a,b\<rangle> \<in> Y"  "M`\<langle>a,c\<rangle> \<in> Y"
    "M`\<langle>b,a\<rangle> \<in> Y"  "M`\<langle>c,a\<rangle> \<in> Y" using IsOpClosed_def by auto
  with A5 A4 have
    "A\<^sub>r`\<langle>b,c\<rangle> \<in> Y"  "M\<^sub>r`\<langle>a,b\<rangle> \<in> Y"  "M\<^sub>r`\<langle>a,c\<rangle> \<in> Y"
    "M\<^sub>r`\<langle>b,a\<rangle> \<in> Y"  "M\<^sub>r`\<langle>c,a\<rangle> \<in> Y"
    using restrict by auto
  with A1 A2 A4 A5 show ?thesis
    using restrict IsDistributive_def by auto
qed

text\<open>Distributivity is preserved by restrictions to sets that are closed with
  respect to both operations.\<close>

lemma func_ZF_7_L2:
  assumes "IsDistributive(X,A,M)"
  and "Y\<subseteq>X"
  and "Y {is closed under} A"
  "Y {is closed under} M"
  and "A\<^sub>r = restrict(A,Y\<times>Y)" "M\<^sub>r = restrict(M,Y\<times>Y)"
  shows "IsDistributive(Y,A\<^sub>r,M\<^sub>r)"
proof -
  from assms have "\<forall>a\<in>Y.\<forall>b\<in>Y.\<forall>c\<in>Y.
    M\<^sub>r`\<langle> a,A\<^sub>r`\<langle>b,c\<rangle> \<rangle> = A\<^sub>r`\<langle> M\<^sub>r`\<langle>a,b\<rangle>,M\<^sub>r`\<langle>a,c\<rangle> \<rangle> \<and>
    M\<^sub>r`\<langle> A\<^sub>r`\<langle>b,c\<rangle>,a \<rangle> = A\<^sub>r`\<langle> M\<^sub>r`\<langle>b,a\<rangle>,M\<^sub>r`\<langle>c,a\<rangle>\<rangle>"
    using func_ZF_7_L1 by simp
  then show ?thesis using IsDistributive_def by simp
qed

end


(*  Title:      HOL/HOLCF/FOCUS/Buffer_adm.thy
    Author:     David von Oheimb, TU Muenchen
*)

section \<open>One-element buffer, proof of Buf_Eq_imp_AC by induction + admissibility\<close>

theory Buffer_adm
imports Buffer Stream_adm
begin

declare enat_0 [simp]

lemma BufAC_Asm_d2: "a\<leadsto>s:BufAC_Asm ==> ? d. a=Md d"
by (drule BufAC_Asm_unfold [THEN iffD1], auto)

lemma BufAC_Asm_d3:
    "a\<leadsto>b\<leadsto>s:BufAC_Asm ==> ? d. a=Md d & b=\<bullet> & s:BufAC_Asm"
by (drule BufAC_Asm_unfold [THEN iffD1], auto)

lemma BufAC_Asm_F_def3:
 "(s:BufAC_Asm_F A) = (s=<> |
  (? d. ft\<cdot>s=Def(Md d)) & (rt\<cdot>s=<> | ft\<cdot>(rt\<cdot>s)=Def \<bullet> & rt\<cdot>(rt\<cdot>s):A))"
by (unfold BufAC_Asm_F_def, auto)

lemma cont_BufAC_Asm_F: "inf_continuous BufAC_Asm_F"
by (auto simp add: inf_continuous_def BufAC_Asm_F_def3)

lemma BufAC_Cmt_F_def3:
 "((s,t):BufAC_Cmt_F C) = (!d x.
    (s = <>       --> t = <>                   ) &
    (s = Md d\<leadsto><>  --> t = <>                   ) &
    (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C))"
apply (unfold BufAC_Cmt_F_def)
apply (subgoal_tac "!d x. (s = Md d\<leadsto>\<bullet>\<leadsto>x --> (? y. t = d\<leadsto>y & (x,y):C)) =
                     (s = Md d\<leadsto>\<bullet>\<leadsto>x --> ft\<cdot>t = Def d & (x,rt\<cdot>t):C)")
apply (simp)
apply (auto intro: surjectiv_scons [symmetric])
done

lemma cont_BufAC_Cmt_F: "inf_continuous BufAC_Cmt_F"
by (auto simp add: inf_continuous_def BufAC_Cmt_F_def3)

(**** adm_BufAC_Asm ***********************************************************)

lemma BufAC_Asm_F_stream_monoP: "stream_monoP BufAC_Asm_F"
apply (unfold BufAC_Asm_F_def stream_monoP_def)
apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
apply (rule_tac x="Suc (Suc 0)" in exI)
apply (clarsimp)
done

lemma adm_BufAC_Asm: "adm (%x. x:BufAC_Asm)"
apply (unfold BufAC_Asm_def)
apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_monoP [THEN fstream_gfp_admI]])
done

(**** adm_non_BufAC_Asm *******************************************************)

lemma BufAC_Asm_F_stream_antiP: "stream_antiP BufAC_Asm_F"
apply (unfold stream_antiP_def BufAC_Asm_F_def)
apply (intro strip)
apply (rule_tac x="{x. (? d. x = Md d\<leadsto>\<bullet>\<leadsto><>)}" in exI)
apply (rule_tac x="Suc (Suc 0)" in exI)
apply (rule conjI)
prefer 2
apply ( intro strip)
apply ( drule slen_mono)
apply ( drule (1) order_trans)
apply (force)+
done

lemma adm_non_BufAC_Asm: "adm (%u. u~:BufAC_Asm)"
apply (unfold BufAC_Asm_def)
apply (rule cont_BufAC_Asm_F [THEN BufAC_Asm_F_stream_antiP [THEN fstream_non_gfp_admI]])
done

(**** adm_BufAC ***************************************************************)

(*adm_non_BufAC_Asm*)
lemma BufAC_Asm_cong [rule_format]: "!f ff. f:BufEq --> ff:BufEq --> s:BufAC_Asm --> f\<cdot>s = ff\<cdot>s"
apply (rule fstream_ind2)
apply (simp add: adm_non_BufAC_Asm)
apply   (force dest: Buf_f_empty)
apply  (force dest!: BufAC_Asm_d2
              dest: Buf_f_d elim: ssubst)
apply (safe dest!: BufAC_Asm_d3)
apply (drule Buf_f_d_req)+
apply (fast elim: ssubst)
done

(*adm_non_BufAC_Asm,BufAC_Asm_cong*)
lemma BufAC_Cmt_d_req:
"!!X. [|f:BufEq; s:BufAC_Asm; (s, f\<cdot>s):BufAC_Cmt|] ==> (a\<leadsto>b\<leadsto>s, f\<cdot>(a\<leadsto>b\<leadsto>s)):BufAC_Cmt"
apply (rule BufAC_Cmt_unfold [THEN iffD2])
apply (intro strip)
apply (frule Buf_f_d_req)
apply (auto elim: BufAC_Asm_cong [THEN subst])
done

(*adm_BufAC_Asm*)
lemma BufAC_Asm_antiton: "antitonP BufAC_Asm"
apply (rule antitonPI)
apply (rule allI)
apply (rule fstream_ind2)
apply (  rule adm_lemmas)+
apply (   rule cont_id)
apply (   rule adm_BufAC_Asm)
apply (  safe)
apply (  rule BufAC_Asm_empty)
apply ( force dest!: fstream_prefix
              dest: BufAC_Asm_d2 intro: BufAC_Asm_d)
apply ( force dest!: fstream_prefix
              dest: BufAC_Asm_d3 intro!: BufAC_Asm_d_req)
done

(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong*)
lemma BufAC_Cmt_2stream_monoP: "f:BufEq ==> ? l. !i x s. s:BufAC_Asm --> x << s --> enat (l i) < #x -->
                     (x,f\<cdot>x):(BufAC_Cmt_F ^^ i) top -->
                     (s,f\<cdot>s):(BufAC_Cmt_F ^^ i) top"
apply (rule_tac x="%i. 2*i" in exI)
apply (rule allI)
apply (induct_tac "i")
apply ( simp)
apply (simp add: add.commute)
apply (intro strip)
apply (subst BufAC_Cmt_F_def3)
apply (drule_tac P="%x. x" in BufAC_Cmt_F_def3 [THEN subst])
apply safe
apply (   erule Buf_f_empty)
apply (  erule Buf_f_d)
apply ( drule Buf_f_d_req)
apply ( safe, erule ssubst, simp)
apply clarsimp
apply (rename_tac i d xa ya t)
(*
 1. \<And>i d xa ya t.
       \<lbrakk>f \<in> BufEq;
          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
                x \<sqsubseteq> s \<longrightarrow>
                enat (2 * i) < #x \<longrightarrow>
                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
          Md d\<leadsto>\<bullet>\<leadsto>xa \<in> BufAC_Asm; enat (2 * i) < #ya; f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>t;
          (ya, t) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa\<rbrakk>
       \<Longrightarrow> (xa, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>xa))) \<in> down_iterate BufAC_Cmt_F i
*)
apply (rotate_tac 2)
apply (drule BufAC_Asm_prefix2)
apply (frule Buf_f_d_req, erule exE, erule conjE, rotate_tac -1, erule ssubst)
apply (frule Buf_f_d_req, erule exE, erule conjE)
apply (            subgoal_tac "f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya")
prefer 2
apply ( assumption)
apply (            rotate_tac -1)
apply (            simp)
apply (erule subst)
(*
 1. \<And>i d xa ya t ff ffa.
       \<lbrakk>f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>ya) = d\<leadsto>ffa\<cdot>ya; enat (2 * i) < #ya;
          (ya, ffa\<cdot>ya) \<in> down_iterate BufAC_Cmt_F i; ya \<sqsubseteq> xa; f \<in> BufEq;
          \<forall>x s. s \<in> BufAC_Asm \<longrightarrow>
                x \<sqsubseteq> s \<longrightarrow>
                enat (2 * i) < #x \<longrightarrow>
                (x, f\<cdot>x) \<in> down_iterate BufAC_Cmt_F i \<longrightarrow>
                (s, f\<cdot>s) \<in> down_iterate BufAC_Cmt_F i;
          xa \<in> BufAC_Asm; ff \<in> BufEq; ffa \<in> BufEq\<rbrakk>
       \<Longrightarrow> (xa, ff\<cdot>xa) \<in> down_iterate BufAC_Cmt_F i
*)
apply (drule spec, drule spec, drule (1) mp)
apply (drule (1) mp)
apply (drule (1) mp)
apply (erule impE)
apply ( subst BufAC_Asm_cong, assumption)
prefer 3 apply assumption
apply assumption
apply ( erule (1) BufAC_Asm_antiton [THEN antitonPD])
apply (subst BufAC_Asm_cong, assumption)
prefer 3 apply assumption
apply assumption
apply assumption
done

lemma BufAC_Cmt_iterate_all: "(x\<in>BufAC_Cmt) = (\<forall>n. x\<in>(BufAC_Cmt_F ^^ n) top)"
apply (unfold BufAC_Cmt_def)
apply (subst cont_BufAC_Cmt_F [THEN inf_continuous_gfp])
apply (fast)
done

(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
  BufAC_Cmt_2stream_monoP*)
lemma adm_BufAC: "f:BufEq ==> adm (%s. s:BufAC_Asm --> (s, f\<cdot>s):BufAC_Cmt)"
apply (rule flatstream_admI)
apply (subst BufAC_Cmt_iterate_all)
apply (drule BufAC_Cmt_2stream_monoP)
apply safe
apply (drule spec, erule exE)
apply (drule spec, erule impE)
apply  (erule BufAC_Asm_antiton [THEN antitonPD])
apply  (erule is_ub_thelub)
apply (tactic "smp_tac @{context} 3 1")
apply (drule is_ub_thelub)
apply (drule (1) mp)
apply (drule (1) mp)
apply (erule mp)
apply (drule BufAC_Cmt_iterate_all [THEN iffD1])
apply (erule spec)
done

(**** Buf_Eq_imp_AC by induction **********************************************)

(*adm_BufAC_Asm,BufAC_Asm_antiton,adm_non_BufAC_Asm,BufAC_Asm_cong,
  BufAC_Cmt_2stream_monoP,adm_BufAC,BufAC_Cmt_d_req*)
lemma Buf_Eq_imp_AC: "BufEq <= BufAC"
apply (unfold BufAC_def)
apply (rule subsetI)
apply (simp)
apply (rule allI)
apply (rule fstream_ind2)
back
apply (   erule adm_BufAC)
apply (  safe)
apply (   erule BufAC_Cmt_empty)
apply (  erule BufAC_Cmt_d)
apply ( drule BufAC_Asm_prefix2)
apply ( simp)
apply (fast intro: BufAC_Cmt_d_req BufAC_Asm_prefix2)
done

(**** new approach for admissibility, reduces itself to absurdity *************)

lemma adm_BufAC_Asm': "adm (\<lambda>x. x\<in>BufAC_Asm)"
apply (rule def_gfp_admI)
apply (rule BufAC_Asm_def [THEN eq_reflection])
apply (safe)
apply (unfold BufAC_Asm_F_def)
apply (safe)
apply (erule contrapos_np)
apply (drule fstream_exhaust_eq [THEN iffD1])
apply (clarsimp)
apply (drule (1) fstream_lub_lemma)
apply (clarify)
apply (erule_tac x="j" in all_dupE)
apply (simp)
apply (drule BufAC_Asm_d2)
apply (clarify)
apply (simp)
apply (rule disjCI)
apply (erule contrapos_np)
apply (drule fstream_exhaust_eq [THEN iffD1])
apply (clarsimp)
apply (drule (1) fstream_lub_lemma)
apply (clarsimp)
apply (simp only: ex_simps [symmetric] all_simps [symmetric])
apply (rule_tac x="Xa" in exI)
apply (rule allI)
apply (rotate_tac -1)
apply (erule_tac x="i" in allE)
apply (clarsimp)
apply (erule_tac x="jb" in allE)
apply (clarsimp)
apply (erule_tac x="jc" in allE)
apply (clarsimp dest!: BufAC_Asm_d3)
done

lemma adm_non_BufAC_Asm': "adm (\<lambda>u. u \<notin> BufAC_Asm)" (* uses antitonP *)
apply (rule def_gfp_adm_nonP)
apply (rule BufAC_Asm_def [THEN eq_reflection])
apply (unfold BufAC_Asm_F_def)
apply (safe)
apply (erule contrapos_np)
apply (drule fstream_exhaust_eq [THEN iffD1])
apply (clarsimp)
apply (frule fstream_prefix)
apply (clarsimp)
apply (frule BufAC_Asm_d2)
apply (clarsimp)
apply (rotate_tac -1)
apply (erule contrapos_pp)
apply (drule fstream_exhaust_eq [THEN iffD1])
apply (clarsimp)
apply (frule fstream_prefix)
apply (clarsimp)
apply (frule BufAC_Asm_d3)
apply (force)
done

lemma adm_BufAC': "f \<in> BufEq \<Longrightarrow> adm (\<lambda>u. u \<in> BufAC_Asm \<longrightarrow> (u, f\<cdot>u) \<in> BufAC_Cmt)"
apply (rule triv_admI)
apply (clarify)
apply (erule (1) Buf_Eq_imp_AC_lemma)
      (* this is what we originally aimed to show, using admissibilty :-( *)
done

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{Set Implementation by List}\<close>
theory ListSetImpl
imports "../spec/SetSpec" "../gen_algo/SetGA" "../../Lib/Dlist_add"
begin
text_raw \<open>\label{thy:ListSetImpl}\<close>

(*@impl Set
  @type 'a ls
  @abbrv ls,l
  Sets implemented by distinct lists. For efficient
  @{text "insert_dj"}-operations, use the version with explicit invariant (lsi).
*)

type_synonym
  'a ls = "'a dlist"

subsection "Definitions"

definition ls_\<alpha> :: "'a ls \<Rightarrow> 'a set" where "ls_\<alpha> l == set (list_of_dlist l)"

definition ls_basic_ops :: "('a,'a ls) set_basic_ops" where
  [icf_rec_def]: "ls_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = ls_\<alpha>,
    bset_op_invar = \<lambda>_. True,
    bset_op_empty = \<lambda>_. Dlist.empty,
    bset_op_memb = (\<lambda>x s. Dlist.member s x),
    bset_op_ins = Dlist.insert,
    bset_op_ins_dj = Dlist.insert,
    bset_op_delete = dlist_remove',
    bset_op_list_it = dlist_iteratei
    \<rparr>"

setup Locale_Code.open_block
interpretation ls_basic: StdBasicSet ls_basic_ops
  apply unfold_locales
  unfolding ls_basic_ops_def ls_\<alpha>_def[abs_def]
  apply (auto simp: dlist_member_empty Dlist.member_def List.member_def
    dlist_iteratei_correct
    dlist_remove'_correct set_dlist_remove1'
  )
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "ls_ops \<equiv> ls_basic.dflt_ops\<lparr>
  set_op_to_list := list_of_dlist
  \<rparr>"

setup Locale_Code.open_block
interpretation ls: StdSetDefs ls_ops .
interpretation ls: StdSet ls_ops
proof -
  interpret aux: StdSet ls_basic.dflt_ops
    by (rule ls_basic.dflt_ops_impl)

  show "StdSet ls_ops"
    unfolding ls_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf)
    apply (unfold_locales)
    apply (simp_all add: ls_\<alpha>_def)
    done
qed

interpretation ls: StdSet_no_invar ls_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup \<open>ICF_Tools.revert_abbrevs "ls"\<close>

lemma pi_ls[proper_it]:
  "proper_it' dlist_iteratei dlist_iteratei"
  apply (rule proper_it'I)
  unfolding dlist_iteratei_def
  by (intro icf_proper_iteratorI)

lemma pi_ls'[proper_it]:
  "proper_it' ls.iteratei ls.iteratei"
  apply (rule proper_it'I)
  unfolding ls.iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_ls: proper_it_loc dlist_iteratei dlist_iteratei
  apply unfold_locales by (rule pi_ls)

interpretation pi_ls': proper_it_loc ls.iteratei ls.iteratei
  apply unfold_locales by (rule pi_ls')

definition test_codegen where "test_codegen \<equiv> (
  ls.empty,
  ls.memb,
  ls.ins,
  ls.delete,
  ls.list_it,
  ls.sng,
  ls.isEmpty,
  ls.isSng,
  ls.ball,
  ls.bex,
  ls.size,
  ls.size_abort,
  ls.union,
  ls.union_dj,
  ls.diff,
  ls.filter,
  ls.inter,
  ls.subset,
  ls.equal,
  ls.disjoint,
  ls.disjoint_witness,
  ls.sel,
  ls.to_list,
  ls.from_list
)"

export_code test_codegen checking SML

end


(*  Title:       Executable Transitive Closures
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)

(*
Copyright 2012 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section \<open>A work-list algorithm for reflexive-transitive closures\<close>

theory RTrancl
imports "Regular-Sets.Regexp_Method"
begin

text \<open>In previous work \<^cite>\<open>"rtrancl_fin"\<close> we described a generic work-list
algorithm to compute reflexive-transitive closures for \emph{finite} relations:
given a finite relation $r$, it computed $@{term "r^*"}$.

In the following, we develop a similar, though different work-list algorithm
for reflexive-transitive closures, it computes @{term "r^* `` init"} for a given
relation $r$ and finite set @{term "init"}.
The main differences are that
\begin{itemize}
\item The relation $r$ does not have to be finite, only @{term "{b. (a,b) \<in> r^* }"} has to be finite
  for each $a$. Moreover, it is no longer required that $r$ is given
  explicitly as a list of pairs.
 Instead $r$ must be provided in the form of a function which computes
  for each element the
  set of one-step successors.
\item One can use a subsumption relation to indicate which elements to no longer
  have to be explored.
\end{itemize}

These new features have been essential to certify size-change termination
proofs \<^cite>\<open>"sct"\<close> where the transitive closure of all size-change graphs
has to be computed. Here, the relation is size-change graph composition.
\begin{itemize}
\item Given an initial set of size-change graphs with $n$ arguments,
  there are roughly $N := 3^{n^2}$ many potential size-change graphs that
  have to be considered as left-hand sides of the composition relation.
  Since the composition relation is even larger than $N$,
  an explicit representation of the composition relation would have been
  too expensive. However, using the new algorithm the number of generated
  graphs is usually far below the theoretical upper bound.
\item Subsumption was useful to generate even fewer elements.
\end{itemize}

\<close>

subsection \<open>The generic case\<close>

text \<open>
  Let $r$ be some finite relation.

  We present a standard work-list algorithm to compute all elements
  that are reachable from some initial set.
  The algorithm is generic in the sense that the
  underlying data structure can freely be chosen, you just have to provide
  certain operations like union, selection of an element.

  In contrast to \<^cite>\<open>"rtrancl_fin"\<close>, the algorithm does not demand that $r$ is finite
  and that $r$ is explicitly provided (e.g., as a list of pairs).
  Instead, it suffices that for every element, only finitely many
  elements can be reached via $r$, and $r$ can be provided as a function which
  computes for every element $a$ all one-step successors w.r.t.\ $r$.
  Hence, $r$ can in particular be any
  well-founded and finitely branching relation.

  The algorithm can further be parametrized by a subsumption relation
  which allows for early pruning.
\<close>

text \<open>In the following locales, $r$ is a relation of type @{typ "'a \<Rightarrow> 'a"},
  the successors of an element are represented by some collection
  type @{typ 'b} which size can be measured using the @{term size} function.
  The selection function @{term sel} is used to meant to split a non-empty
  collection into one element and a remaining collection. The union on
  @{typ 'b} is given by @{term un}.
\<close>

locale subsumption =
  fixes r :: "'a \<Rightarrow> 'b"
   and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   and set_of :: "'b \<Rightarrow> 'a set"
  assumes
       subsumes_refl: "\<And> a. subsumes a a"
   and subsumes_trans: "\<And> a b c. subsumes a b \<Longrightarrow> subsumes b c \<Longrightarrow> subsumes a c"
   and subsumes_step: "\<And> a b c. subsumes a b \<Longrightarrow> c \<in> set_of (r b) \<Longrightarrow> \<exists> d \<in> set_of (r a). subsumes d c"
begin
abbreviation R where "R \<equiv> { (a,b). b \<in> set_of (r a) }"
end

locale subsumption_impl = subsumption r subsumes set_of
  for r :: "'a \<Rightarrow> 'b"
  and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  and set_of :: "'b \<Rightarrow> 'a set" +
  fixes
      sel :: "'b \<Rightarrow> 'a \<times> 'b"
   and un :: "'b \<Rightarrow> 'b \<Rightarrow> 'b"
   and size :: "'b \<Rightarrow> nat"
  assumes set_of_fin: "\<And> b. finite (set_of b)"
   and sel: "\<And> b a c. set_of b \<noteq> {} \<Longrightarrow> sel b = (a,c) \<Longrightarrow> set_of b = insert a (set_of c) \<and> size b > size c"
   and un: "set_of (un a b) = set_of a \<union> set_of b"

locale relation_subsumption_impl = subsumption_impl r subsumes set_of sel un size
  for r subsumes set_of sel un size +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set_of (r a)}^*}"
begin

lemma finite_Rs: assumes init: "finite init"
  shows "finite (R^* `` init)"
proof -
  let ?R = "\<lambda> a. {b . (a,b) \<in> R^*}"
  let ?S = "{ ?R a | a . a \<in> init}"
  have id: "R^* `` init = \<Union> ?S" by auto
  show ?thesis unfolding id
  proof (rule)
    fix M
    assume "M \<in> ?S"
    then obtain a where M: "M = ?R a" by auto
    show "finite M" unfolding M by (rule rtrancl_fin)
  next
    show "finite {{b. (a, b) \<in> R^*} | a. a \<in> init}"
      using init by auto
  qed
qed

text \<open>a standard work-list algorithm with subsumption\<close>
function mk_rtrancl_main where
  "mk_rtrancl_main todo fin = (if set_of todo = {} then fin
      else (let (a,tod) = sel todo
             in (if (\<exists> b \<in> fin. subsumes b a) then mk_rtrancl_main tod fin
                 else mk_rtrancl_main (un (r a) tod) (insert a fin))))"
  by pat_completeness auto

termination mk_rtrancl_main
proof -
  let ?r1 = "\<lambda> (todo, fin). card (R^* `` (set_of todo) - fin)"
  let ?r2 = "\<lambda> (todo, fin). size todo"
  show ?thesis
  proof
    show "wf (measures [?r1,?r2])" by simp
  next
    fix todo fin pair tod a
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by simp
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((tod,fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_lesseq[OF _ measures_less], unfold split)
      from sel
      show "size tod < size todo" by simp
    next
      from sel have subset: "R^* `` set_of tod - fin \<subseteq> R^* `` set_of todo - fin" (is "?l \<subseteq> ?r") by auto
      show "card ?l \<le> card ?r"
        by (rule card_mono[OF _ subset], rule finite_Diff, rule finite_Rs[OF fin])
    qed
  next
    fix todo fin a tod pair
    assume nempty: "set_of todo \<noteq> {}" and pair1: "pair = sel todo" and pair2: "(a,tod) = pair" and nmem: "\<not> (\<exists> b \<in> fin. subsumes b a)"
    from pair1 pair2 have pair: "sel todo = (a,tod)" by auto
    from nmem subsumes_refl[of a] have nmem: "a \<notin> fin" by auto
    from set_of_fin have fin: "finite (set_of todo)" by auto
    note sel = sel[OF nempty pair]
    show "((un (r a) tod,insert a fin),(todo,fin)) \<in> measures [?r1,?r2]"
    proof (rule measures_less, unfold split,
        rule psubset_card_mono[OF finite_Diff[OF finite_Rs[OF fin]]])
      let ?l = "R^* `` set_of (un (r a) tod) - insert a fin"
      let ?r = "R^* `` set_of todo - fin"
      from sel have at: "a \<in> set_of todo" by auto
      have ar: "a \<in> ?r" using nmem at by auto
      show "?l \<subset> ?r"
      proof
        show "?l \<noteq> ?r" using ar by auto
      next
        have "R^* `` set_of (r a) \<subseteq> R^* `` set_of todo"
        proof
          fix b
          assume "b \<in> R^* `` set_of (r a)"
          then obtain c where cb: "(c,b) \<in> R^*" and ca: "c \<in> set_of (r a)" by blast
          hence ab: "(a,b) \<in> R O R^*" by auto
          have "(a,b) \<in> R^*"
            by (rule subsetD[OF _ ab], regexp)
          with at show "b \<in> R^* `` set_of todo" by auto
        qed
        thus "?l \<subseteq> ?r" using sel unfolding un by auto
      qed
    qed
  qed
qed

declare mk_rtrancl_main.simps[simp del]

lemma mk_rtrancl_main_sound: "set_of todo \<union> fin \<subseteq> R^* `` init \<Longrightarrow> mk_rtrancl_main todo fin \<subseteq> R^* `` init"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    show ?thesis unfolding simp using True 1(3) by auto
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by auto
    obtain a tod where selt: "sel todo = (a,tod)" by force
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric]]
    note IH2 = 1(2)[OF False refl selt[symmetric]]
    note simp = simp nempty if_False Let_def selt
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      hence "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      with IH1[OF True] 1(3) show ?thesis using sel by auto
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r a) tod) (insert a fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        from sel 1(3) have subset: "set_of todo \<union> insert a fin \<subseteq> R^* `` init" by auto
        {
          fix b
          assume b: "b \<in> set_of (r a)"
          hence ab: "(a,b) \<in> R" by auto
          from sel 1(3) have "a \<in> R^* `` init" by auto
          then obtain c where c: "c \<in> init" and ca: "(c,a) \<in> R^*" by blast
          from ca ab have cb: "(c,b) \<in> R^* O R" by auto
          have "(c,b) \<in> R^*"
            by (rule subsetD[OF _ cb], regexp)
          with c have "b \<in> R^* `` init" by auto
        }
        with subset
        show "set_of (un (r a) tod) \<union> (insert a fin) \<subseteq> R^* `` init"
          unfolding un using sel by auto
      qed
    qed
  qed
qed

lemma mk_rtrancl_main_complete:
  "\<lbrakk>\<And> a. a \<in> init \<Longrightarrow> \<exists> b. b \<in> set_of todo \<union> fin \<and> subsumes b a\<rbrakk>
  \<Longrightarrow> \<lbrakk> \<And> a b . a \<in> fin \<Longrightarrow> b \<in> set_of (r a) \<Longrightarrow> \<exists> c. c \<in> set_of todo \<union> fin \<and> subsumes c b\<rbrakk>
  \<Longrightarrow> c \<in> R^* `` init
  \<Longrightarrow> \<exists> b. b \<in> mk_rtrancl_main todo fin \<and> subsumes b c"
proof (induct todo fin rule: mk_rtrancl_main.induct)
  case (1 todo fin)
  from 1(5) have c: "c \<in> R^* `` init" .
  note finr = 1(4)
  note init = 1(3)
  note simp = mk_rtrancl_main.simps[of todo fin]
  show ?case
  proof (cases "set_of todo = {}")
    case True
    hence id: "mk_rtrancl_main todo fin = fin" unfolding simp by simp
    from c obtain a where a: "a \<in> init" and ac: "(a,c) \<in> R^*" by blast
    show ?thesis unfolding id using ac
    proof (induct rule: rtrancl_induct)
      case base
      from init[OF a] show ?case unfolding True by auto
    next
      case (step b c)
      from step(3) obtain d where d: "d \<in> fin" and db: "subsumes d b" by auto
      from step(2) have cb: "c \<in> set_of (r b)" by auto
      from subsumes_step[OF db cb] obtain a where a: "a \<in> set_of (r d)" and ac: "subsumes a c" by auto
      from finr[OF d a] obtain e where e: "e \<in> fin" and ea: "subsumes e a" unfolding True by auto
      from subsumes_trans[OF ea ac] e
      show ?case by auto
    qed
  next
    case False
    hence nempty: "(set_of todo = {}) = False" by simp
    obtain A tod where selt: "sel todo = (A,tod)" by force
    note simp = nempty simp if_False Let_def selt
    note sel = sel[OF False selt]
    note IH1 = 1(1)[OF False refl selt[symmetric] _ _ _ c]
    note IH2 = 1(2)[OF False refl selt[symmetric] _ _ _ c]
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b A")
      case True note oTrue = this
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main tod fin"
        unfolding simp by simp
      from True obtain b where b: "b \<in> fin" and ba: "subsumes b A" by auto
      show ?thesis unfolding id
      proof (rule IH1[OF True])
        fix a
        assume a: "a \<in> init"
        from init[OF a] obtain c where c: "c \<in> set_of todo \<union> fin" and ca: "subsumes c a" by blast
        show "\<exists> b. b \<in> set_of tod \<union> fin \<and> subsumes b a"
        proof (cases "c = A")
          case False
          thus ?thesis using c ca sel by auto
        next
          case True
          show ?thesis using b subsumes_trans[OF ba, of a] ca unfolding True[symmetric] by auto
        qed
      next
        fix a c
        assume a: "a \<in> fin" and c: "c \<in> set_of (r a)"
        from finr[OF a c] obtain e where e: "e \<in> set_of todo \<union> fin" and ec: "subsumes e c" by auto
        show "\<exists> d. d \<in> set_of tod \<union> fin \<and> subsumes d c"
        proof (cases "A = e")
          case False
          with e ec show ?thesis using sel by auto
        next
          case True
          from subsumes_trans[OF ba[unfolded True] ec]
          show ?thesis using b by auto
        qed
      qed
    next
      case False
      hence id: "mk_rtrancl_main todo fin = mk_rtrancl_main (un (r A) tod) (insert A fin)" unfolding simp by simp
      show ?thesis unfolding id
      proof (rule IH2[OF False])
        fix a
        assume a: "a \<in> init"
        from init[OF a]
        show "\<exists> b. b \<in> set_of (un (r A) (tod)) \<union> insert A fin \<and> subsumes b a"
          using sel unfolding un by auto
      next
        fix a b
        assume a: "a \<in> insert A fin" and b: "b \<in> set_of (r a)"
        show "\<exists> c. c \<in> set_of (un (r A) tod) \<union> insert A fin \<and> subsumes c b"
        proof (cases "a \<in> fin")
          case True
          from finr[OF True b] show ?thesis using sel unfolding un by auto
        next
          case False
          with a have a: "A = a" by simp
          show ?thesis unfolding a un using b subsumes_refl[of b] by blast
        qed
      qed
    qed
  qed
qed

definition mk_rtrancl where "mk_rtrancl init \<equiv> mk_rtrancl_main init {}"

lemma mk_rtrancl_complete: assumes a: "a \<in> R^* `` set_of init"
  shows "\<exists> b. b \<in> mk_rtrancl init \<and> subsumes b a"
  unfolding mk_rtrancl_def
proof (rule mk_rtrancl_main_complete[OF _ _ a])
  fix a
  assume a: "a \<in> set_of init"
  thus "\<exists> b. b \<in> set_of init \<union> {} \<and> subsumes b a" using subsumes_refl[of a] by blast
qed auto

lemma mk_rtrancl_no_subsumption: assumes "subsumes = (=)"
  shows "mk_rtrancl init = R^* `` set_of init"
  using mk_rtrancl_sound[of init] mk_rtrancl_complete[of _ init] assms
  by auto
end

subsection \<open>Instantiation using list operations\<close>

text \<open>It follows an implementation based on lists.
 Here, the working list algorithm is implemented outside the locale so that
 it can be used for code generation. In general, it is not terminating,
 therefore we use partial\_function instead of function.\<close>

partial_function(tailrec) mk_rtrancl_list_main where
 [code]:  "mk_rtrancl_list_main subsumes r todo fin = (case todo of [] \<Rightarrow> fin
     | Cons a tod \<Rightarrow>
             (if (\<exists> b \<in> set fin. subsumes b a) then mk_rtrancl_list_main subsumes r tod fin
                 else mk_rtrancl_list_main subsumes r (r a @ tod) (a # fin)))"

definition mk_rtrancl_list where
  "mk_rtrancl_list subsumes r init \<equiv> mk_rtrancl_list_main subsumes r init []"

locale subsumption_list = subsumption r subsumes set
  for r :: "'a \<Rightarrow> 'a list" and subsumes :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

locale relation_subsumption_list = subsumption_list r subsumes for r subsumes +
  assumes rtrancl_fin: "\<And> a. finite {b. (a,b) \<in> { (a,b) . b \<in> set (r a)}^*}"

abbreviation(input) sel_list where "sel_list x \<equiv> case x of Cons h t \<Rightarrow> (h,t)"

sublocale subsumption_list \<subseteq> subsumption_impl r subsumes set sel_list append length
proof(unfold_locales, rule finite_set)
  fix b a c
  assume "set b \<noteq> {}" and "sel_list b = (a,c)"
  thus "set b = insert a (set c) \<and> length c < length b"
    by (cases b, auto)
qed auto

sublocale relation_subsumption_list \<subseteq> relation_subsumption_impl r subsumes set sel_list append length
  by (unfold_locales, rule rtrancl_fin)

context relation_subsumption_list
begin

text \<open>The main equivalence proof between the generic work list algorithm
and the one operating on lists\<close>
lemma mk_rtrancl_list_main: "fin = set finl \<Longrightarrow> set (mk_rtrancl_list_main subsumes r todo finl) = mk_rtrancl_main todo fin"
proof (induct todo fin arbitrary: finl rule: mk_rtrancl_main.induct)
  case (1 todo fin finl)
  note simp = mk_rtrancl_list_main.simps[of _ _ todo finl] mk_rtrancl_main.simps[of todo fin]
  show ?case (is "?l = ?r")
  proof (cases todo)
    case Nil
    show ?thesis unfolding simp unfolding Nil 1(3) by simp
  next
    case (Cons a tod)
    show ?thesis
    proof (cases "\<exists> b \<in> fin. subsumes b a")
      case True
      from True have l: "?l = set (mk_rtrancl_list_main subsumes r tod finl)"
        unfolding simp unfolding Cons 1(3) by simp
      from True have r: "?r = mk_rtrancl_main tod fin"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(1)[OF _ refl _ True], insert 1(3) Cons, auto)
    next
      case False
      from False have l: "?l = set (mk_rtrancl_list_main subsumes r (r a @ tod) (a # finl))"
        unfolding simp unfolding Cons 1(3) by simp
      from False have r: "?r = mk_rtrancl_main (r a @ tod) (insert a fin)"
        unfolding simp unfolding Cons by auto
      show ?thesis unfolding l r
        by (rule 1(2)[OF _ refl _ False], insert 1(3) Cons, auto)
    qed
  qed
qed

lemma mk_rtrancl_list: "set (mk_rtrancl_list subsumes r init) = mk_rtrancl init"
  unfolding mk_rtrancl_list_def mk_rtrancl_def
  by (rule mk_rtrancl_list_main, simp)

end

end


section "Common Basis Theory"

theory Base_FDS
imports "HOL-Library.Pattern_Aliases"
begin

declare Let_def [simp]

text \<open>Lemma \<open>size_prod_measure\<close>, when declared with the \<open>measure_function\<close> attribute,
enables \<open>fun\<close> to prove termination of a larger class of functions automatically.
By default, \<open>fun\<close> only tries lexicographic combinations of the sizes of the parameters.
With \<open>size_prod_measure\<close> enabled it also tries measures based on the sum of the sizes
of different parameters.

To alert the reader whenever such a more subtle termination proof is taking place
the lemma is not enabled all the time but only when it is needed.
\<close>

lemma size_prod_measure:
  "is_measure f \<Longrightarrow> is_measure g \<Longrightarrow> is_measure (size_prod f g)"
by (rule is_measure_trivial)

end


section \<open> Relational Hoare calculus \<close>

theory utp_hoare
  imports
    utp_rel_laws
    utp_theory
begin

subsection \<open> Hoare Triple Definitions and Tactics \<close>

definition hoare_r :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> cond \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>\<^sub>u") where
"\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u = ((\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>r\<rceil>\<^sub>>) \<sqsubseteq> Q)"

declare hoare_r_def [upred_defs]

named_theorems hoare and hoare_safe

method hoare_split uses hr =
  ((simp add: assigns_comp)?, \<comment> \<open> Combine Assignments where possible \<close>
   (auto
    intro: hoare intro!: hoare_safe hr
    simp add: conj_comm conj_assoc usubst unrest))[1] \<comment> \<open> Apply Hoare logic laws \<close>

method hoare_auto uses hr = (hoare_split hr: hr; (rel_simp)?, auto?)

subsection \<open> Basic Laws \<close>

lemma hoare_meaning:
  "\<lbrace>P\<rbrace>S\<lbrace>Q\<rbrace>\<^sub>u = (\<forall> s s'. \<lbrakk>P\<rbrakk>\<^sub>e s \<and> \<lbrakk>S\<rbrakk>\<^sub>e (s, s') \<longrightarrow> \<lbrakk>Q\<rbrakk>\<^sub>e s')"
  by (rel_auto)

lemma hoare_assume: "\<lbrace>P\<rbrace>S\<lbrace>Q\<rbrace>\<^sub>u \<Longrightarrow> ?[P] ;; S = ?[P] ;; S ;; ?[Q]"
  by (rel_auto)

lemma hoare_r_conj [hoare_safe]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u; \<lbrace>p\<rbrace>Q\<lbrace>s\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<lbrace>r \<and> s\<rbrace>\<^sub>u"
  by rel_auto

lemma hoare_r_weaken_pre [hoare]:
  "\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u"
  "\<lbrace>q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>u"
  by rel_auto+

lemma hoare_r_conseq: "\<lbrakk> `p\<^sub>1 \<Rightarrow> p\<^sub>2`; \<lbrace>p\<^sub>2\<rbrace>S\<lbrace>q\<^sub>2\<rbrace>\<^sub>u; `q\<^sub>2 \<Rightarrow> q\<^sub>1` \<rbrakk> \<Longrightarrow> \<lbrace>p\<^sub>1\<rbrace>S\<lbrace>q\<^sub>1\<rbrace>\<^sub>u"
  by rel_auto

subsection \<open> Assignment Laws \<close>

lemma assigns_hoare_r [hoare_safe]: "`p \<Rightarrow> \<sigma> \<dagger> q` \<Longrightarrow> \<lbrace>p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>a\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma assigns_backward_hoare_r:
  "\<lbrace>\<sigma> \<dagger> p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>a\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma assigns_init_hoare [hoare_safe]:
  "\<lbrakk> vwb_lens x; x \<sharp> p; x \<sharp> v; \<lbrace>&x =\<^sub>u v \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>x := v ;; S\<lbrace>q\<rbrace>\<^sub>u"
  by (rel_auto)

lemma skip_hoare_r [hoare_safe]: "\<lbrace>p\<rbrace>II\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma skip_hoare_impl_r [hoare_safe]: "`p \<Rightarrow> q` \<Longrightarrow> \<lbrace>p\<rbrace>II\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

subsection \<open> Sequence Laws \<close>

lemma seq_hoare_r: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>s\<rbrace>\<^sub>u ; \<lbrace>s\<rbrace>Q\<^sub>2\<lbrace>r\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>r\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_invariant [hoare_safe]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>p\<rbrace>\<^sub>u ; \<lbrace>p\<rbrace>Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_stronger_pre_1 [hoare_safe]:
  "\<lbrakk> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1\<lbrace>p \<and> q\<rbrace>\<^sub>u ; \<lbrace>p \<and> q\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_stronger_pre_2 [hoare_safe]:
  "\<lbrakk> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1\<lbrace>p \<and> q\<rbrace>\<^sub>u ; \<lbrace>p \<and> q\<rbrace>Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p \<and> q\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>p\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_inv_r_2 [hoare]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>q\<rbrace>\<^sub>u ; \<lbrace>q\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma seq_hoare_inv_r_3 [hoare]: "\<lbrakk> \<lbrace>p\<rbrace>Q\<^sub>1\<lbrace>p\<rbrace>\<^sub>u ; \<lbrace>p\<rbrace>Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>Q\<^sub>1 ;; Q\<^sub>2\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

subsection \<open> Conditional Laws \<close>

lemma cond_hoare_r [hoare_safe]: "\<lbrakk> \<lbrace>b \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u ; \<lbrace>\<not>b \<and> p\<rbrace>T\<lbrace>q\<rbrace>\<^sub>u \<rbrakk> \<Longrightarrow> \<lbrace>p\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q\<rbrace>\<^sub>u"
  by rel_auto

lemma cond_hoare_r_wp:
  assumes "\<lbrace>p'\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u" and "\<lbrace>p''\<rbrace>T\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>(b \<and> p') \<or> (\<not>b \<and> p'')\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q\<rbrace>\<^sub>u"
  using assms by pred_simp

lemma cond_hoare_r_sp:
  assumes \<open>\<lbrace>b \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u\<close> and \<open>\<lbrace>\<not>b \<and> p\<rbrace>T\<lbrace>s\<rbrace>\<^sub>u\<close>
  shows \<open>\<lbrace>p\<rbrace>S \<triangleleft> b \<triangleright>\<^sub>r T\<lbrace>q \<or> s\<rbrace>\<^sub>u\<close>
  using assms by pred_simp

subsection \<open> Recursion Laws \<close>

lemma nu_hoare_r_partial:
  assumes induct_step:
    "\<And> st P. \<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p\<rbrace>F P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>\<nu> F \<lbrace>q\<rbrace>\<^sub>u"
  by (meson hoare_r_def induct_step lfp_lowerbound order_refl)

lemma mu_hoare_r:
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<And> st P. \<lbrace>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rbrace>F P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>\<mu> F \<lbrace>q\<rbrace>\<^sub>u"
  unfolding hoare_r_def
proof (rule mu_rec_total_utp_rule[OF WF M , of _ e ], goal_cases)
  case (1 st)
  then show ?case
    using induct_step[unfolded hoare_r_def, of "(\<lceil>p\<rceil>\<^sub>< \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> \<lceil>q\<rceil>\<^sub>>)" st]
    by (simp add: alpha)
qed

lemma mu_hoare_r':
  assumes WF: "wf R"
  assumes M:"mono F"
  assumes induct_step:
    "\<And> st P. \<lbrace>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>\<rbrace> P \<lbrace>q\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rbrace> F P \<lbrace>q\<rbrace>\<^sub>u"
  assumes I0: "`p' \<Rightarrow> p`"
  shows "\<lbrace>p'\<rbrace> \<mu> F \<lbrace>q\<rbrace>\<^sub>u"
  by (meson I0 M WF induct_step mu_hoare_r pre_str_hoare_r)

subsection \<open> Iteration Rules \<close>

lemma iter_hoare_r: "\<lbrace>P\<rbrace>S\<lbrace>P\<rbrace>\<^sub>u \<Longrightarrow> \<lbrace>P\<rbrace>S\<^sup>\<star>\<lbrace>P\<rbrace>\<^sub>u"
  by (rel_simp', metis (mono_tags, lifting) mem_Collect_eq rtrancl_induct)

lemma while_hoare_r [hoare_safe]:
  assumes "\<lbrace>p \<and> b\<rbrace>S\<lbrace>p\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while b do S od\<lbrace>\<not>b \<and> p\<rbrace>\<^sub>u"
  using assms
  by (simp add: while_top_def hoare_r_def, rule_tac lfp_lowerbound) (rel_auto)

lemma while_invr_hoare_r [hoare_safe]:
  assumes "\<lbrace>p \<and> b\<rbrace>S\<lbrace>p\<rbrace>\<^sub>u" "`pre \<Rightarrow> p`" "`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while b invr p do S od\<lbrace>post\<rbrace>\<^sub>u"
  by (metis assms hoare_r_conseq while_hoare_r while_inv_def)

lemma while_r_minimal_partial:
  assumes seq_step: "`p \<Rightarrow> invar`"
  assumes induct_step: "\<lbrace>invar\<and> b\<rbrace> C \<lbrace>invar\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while b do C od\<lbrace>\<not>b \<and> invar\<rbrace>\<^sub>u"
  using induct_step pre_str_hoare_r seq_step while_hoare_r by blast

lemma approx_chain:
  "(\<Sqinter>n::nat. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><) = \<lceil>p\<rceil>\<^sub><"
  by (rel_auto)

text \<open> Total correctness law for Hoare logic, based on constructive chains. This is limited to
  variants that have naturals numbers as their range. \<close>

lemma while_term_hoare_r:
  assumes "\<And> z::nat. \<lbrace>p \<and> b \<and> v =\<^sub>u \<guillemotleft>z\<guillemotright>\<rbrace>S\<lbrace>p \<and> v <\<^sub>u \<guillemotleft>z\<guillemotright>\<rbrace>\<^sub>u"
  shows "\<lbrace>p\<rbrace>while\<^sub>\<bottom> b do S od\<lbrace>\<not>b \<and> p\<rbrace>\<^sub>u"
proof -
  have "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
  proof (rule mu_refine_intro)

    from assms show "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<sqsubseteq> S ;; (\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>\<not> b \<and> p\<rceil>\<^sub>>) \<triangleleft> b \<triangleright>\<^sub>r II"
      by (rel_auto)

    let ?E = "\<lambda> n. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><"
    show "(\<lceil>p\<rceil>\<^sub>< \<and> (\<mu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)) = (\<lceil>p\<rceil>\<^sub>< \<and> (\<nu> X \<bullet> S ;; X \<triangleleft> b \<triangleright>\<^sub>r II))"
    proof (rule constr_fp_uniq[where E="?E"])

      show "(\<Sqinter>n. ?E(n)) = \<lceil>p\<rceil>\<^sub><"
        by (rel_auto)

      show "mono (\<lambda>X. S ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
        by (simp add: cond_mono monoI seqr_mono)

      show "constr (\<lambda>X. S ;; X \<triangleleft> b \<triangleright>\<^sub>r II) ?E"
      proof (rule constrI)

        show "chain ?E"
        proof (rule chainI)
          show "\<lceil>p \<and> v <\<^sub>u \<guillemotleft>0\<guillemotright>\<rceil>\<^sub>< = false"
            by (rel_auto)
          show "\<And>i. \<lceil>p \<and> v <\<^sub>u \<guillemotleft>Suc i\<guillemotright>\<rceil>\<^sub>< \<sqsubseteq> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>i\<guillemotright>\<rceil>\<^sub><"
            by (rel_auto)
        qed

        from assms
        show "\<And>X n. (S ;; X \<triangleleft> b \<triangleright>\<^sub>r II \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n + 1\<guillemotright>\<rceil>\<^sub><) =
                     (S ;; (X \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n\<guillemotright>\<rceil>\<^sub><) \<triangleleft> b \<triangleright>\<^sub>r II \<and> \<lceil>p \<and> v <\<^sub>u \<guillemotleft>n + 1\<guillemotright>\<rceil>\<^sub><)"
          apply (rel_auto)
          using less_antisym less_trans apply blast
          done
      qed
    qed
  qed

  thus ?thesis
    by (simp add: hoare_r_def while_bot_def)
qed

lemma while_vrt_hoare_r [hoare_safe]:
  assumes "\<And> z::nat. \<lbrace>p \<and> b \<and> v =\<^sub>u \<guillemotleft>z\<guillemotright>\<rbrace>S\<lbrace>p \<and> v <\<^sub>u \<guillemotleft>z\<guillemotright>\<rbrace>\<^sub>u" "`pre \<Rightarrow> p`" "`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while b invr p vrt v do S od\<lbrace>post\<rbrace>\<^sub>u"
  apply (rule hoare_r_conseq[OF assms(2) _ assms(3)])
  apply (simp add: while_vrt_def)
  apply (rule while_term_hoare_r[where v="v", OF assms(1)])
  done

text \<open> General total correctness law based on well-founded induction \<close>

lemma while_wf_hoare_r:
  assumes WF: "wf R"
  assumes I0: "`pre \<Rightarrow> p`"
  assumes induct_step:"\<And> st. \<lbrace>b \<and> p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rbrace>Q\<lbrace>p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>\<rbrace>\<^sub>u"
  assumes PHI:"`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while\<^sub>\<bottom> b invr p do Q od\<lbrace>post\<rbrace>\<^sub>u"
unfolding hoare_r_def while_inv_bot_def while_bot_def
proof (rule pre_weak_rel[of _ "\<lceil>p\<rceil>\<^sub><" ])
  from I0 show "`\<lceil>pre\<rceil>\<^sub>< \<Rightarrow> \<lceil>p\<rceil>\<^sub><`"
    by rel_auto
  show "(\<lceil>p\<rceil>\<^sub>< \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> X \<bullet> Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
  proof (rule mu_rec_total_utp_rule[where e=e, OF WF])
    show "Monotonic (\<lambda>X. Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
      by (simp add: closure)
    have induct_step': "\<And> st. (\<lceil>b \<and> p \<and>  e =\<^sub>u \<guillemotleft>st\<guillemotright> \<rceil>\<^sub>< \<Rightarrow> (\<lceil>p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<rceil>\<^sub>> )) \<sqsubseteq> Q"
      using induct_step by rel_auto
    with PHI
    show "\<And>st. (\<lceil>p\<rceil>\<^sub>< \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> Q ;; (\<lceil>p\<rceil>\<^sub>< \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<triangleleft> b \<triangleright>\<^sub>r II"
      by (rel_auto)
  qed
qed

subsection \<open> Frame Rules \<close>

text \<open> Frame rule: If starting $S$ in a state satisfying $p establishes q$ in the final state, then
  we can insert an invariant predicate $r$ when $S$ is framed by $a$, provided that $r$ does not
  refer to variables in the frame, and $q$ does not refer to variables outside the frame. \<close>

lemma frame_hoare_r:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace>a:[P]\<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms
  by (rel_auto, metis)

lemma frame_strong_hoare_r [hoare_safe]:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>p \<and> r\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace>a:[S]\<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

lemma frame_hoare_r' [hoare_safe]:
  assumes "vwb_lens a" "a \<sharp> r" "a \<natural> q" "\<lbrace>r \<and> p\<rbrace>S\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>r \<and> p\<rbrace>a:[S]\<lbrace>r \<and> q\<rbrace>\<^sub>u"
  using assms
  by (simp add: frame_strong_hoare_r utp_pred_laws.inf.commute)

lemma antiframe_hoare_r:
  assumes "vwb_lens a" "a \<natural> r" "a \<sharp> q" "\<lbrace>p\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace> a:\<lbrakk>P\<rbrakk> \<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

lemma antiframe_strong_hoare_r:
  assumes "vwb_lens a" "a \<natural> r" "a \<sharp> q" "\<lbrace>p \<and> r\<rbrace>P\<lbrace>q\<rbrace>\<^sub>u"
  shows "\<lbrace>p \<and> r\<rbrace> a:\<lbrakk>P\<rbrakk> \<lbrace>q \<and> r\<rbrace>\<^sub>u"
  using assms by (rel_auto, metis)

end