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

    Copyright (C) 2005 - 2022  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>Order relations - introduction\<close>

theory Order_ZF imports Fol1

begin

text\<open>This theory file considers various notion related to order. We redefine
  the notions of a preorder, directed set, total order, linear order and partial order to have the
  same terminology as Wikipedia (I found it very consistent across different
  areas of math). We also define and study the notions of intervals and bounded
  sets. We show the inclusion relations between the intervals with endpoints
  being in certain order. We also show that union of bounded sets are bounded.
  This allows to show in \<open>Finite_ZF.thy\<close> that finite sets are bounded.\<close>

subsection\<open>Definitions\<close>

text\<open>In this section we formulate the definitions related to order
  relations.\<close>

text\<open>A relation $r$ is ''total'' on a set $X$ if for all elements
  $a,b$ of $X$ we have $a$ is in relation with $b$ or $b$ is in relation
  with $a$. An example is the $\leq $ relation on numbers.
\<close>

definition
  IsTotal (infixl "{is total on}" 65) where
  "r {is total on} X \<equiv> (\<forall>a\<in>X.\<forall>b\<in>X. \<langle> a,b\<rangle> \<in> r \<or> \<langle> b,a\<rangle> \<in> r)"

text\<open>A relation $r$ is a partial order on $X$ if it is reflexive on $X$
  (i.e. $\langle x,x \rangle$ for every $x\in X$), antisymmetric
  (if $\langle x, y\rangle \in r $ and $\langle y, x\rangle \in r $, then
  $x=y$) and transitive $\langle x, y\rangle \in r $ and
  $\langle y, z\rangle \in r $ implies $\langle x, z\rangle \in r $).
\<close>

definition
  "IsPartOrder(X,r) \<equiv> refl(X,r) \<and> antisym(r) \<and> trans(r)"

text\<open>A relation that is reflexive and transitive is called a \<open>preorder\<close>.\<close>

definition
  "IsPreorder(X,r) \<equiv> refl(X,r) \<and> trans(r)"

text\<open>We say that a relation $r$ up-directs a set
  if every two-element subset of $X$ has an upper bound. \<close>

definition
  UpDirects ("_ {up-directs} _" 90)
  where "r {up-directs} X \<equiv> X\<noteq>0 \<and> (\<forall>x\<in>X.\<forall>y\<in>X.\<exists>z\<in>X. \<langle>x,z\<rangle> \<in> r \<and> \<langle>y,z\<rangle> \<in> r)"

text\<open>Analogously we say that a relation $r$ down-directs a set
  if every two-element subset of $X$ has a lower bound. \<close>

definition
  DownDirects ("_ {down-directs} _" 90)
  where "r {down-directs} X \<equiv> X\<noteq>0 \<and> (\<forall>x\<in>X.\<forall>y\<in>X.\<exists>z\<in>X. \<langle>z,x\<rangle> \<in> r \<and> \<langle>z,y\<rangle> \<in> r)"

text\<open>Typically the notion that is actually defined is the notion of a \<open>directed set\<close>.
  or an \<open>upward directed set\<close>, rather than $r$ down-directs $X$ (or $r$ up-directs $X$).
  This is a nonempty set $X$ together which a preorder $r$
  such that $r$ up-directs $X$. We set that up in separate definitions as we sometimes want to
  use an upward or downward directed set with a partial order rather than a preorder. \<close>

definition
  "IsUpDirectedSet(X,r) \<equiv>  IsPreorder(X,r) \<and> (r {up-directs} X)"

text\<open>We define the notion of a \<open>downward directed set\<close> analogously.\<close>

definition
  "IsDownDirectedSet(X,r) \<equiv> IsPreorder(X,r) \<and> (r {down-directs} X)"

text\<open>We define a linear order as a binary relation that is antisymmetric,
  transitive and total. Note that this terminology is different than the
  one used the standard Order.thy file.\<close>

definition
  "IsLinOrder(X,r) \<equiv> antisym(r) \<and> trans(r) \<and> (r {is total on} X)"

text\<open>A set is bounded above if there is that is an upper
  bound for it,  i.e. there are some $u$ such that
  $\langle x, u\rangle \in r$ for all $x\in A$.
  In addition, the empty set is defined as bounded.\<close>

definition
  "IsBoundedAbove(A,r) \<equiv> ( A=0 \<or> (\<exists>u. \<forall>x\<in>A. \<langle> x,u\<rangle> \<in> r))"

text\<open>We define sets bounded below analogously.\<close>

definition
  "IsBoundedBelow(A,r) \<equiv> (A=0 \<or> (\<exists>l. \<forall>x\<in>A. \<langle> l,x\<rangle> \<in> r))"

text\<open>A set is bounded if it is bounded below and above.\<close>

definition
  "IsBounded(A,r) \<equiv> (IsBoundedAbove(A,r) \<and> IsBoundedBelow(A,r))"

text\<open>The notation for the definition of an interval may be mysterious for some
  readers, see lemma \<open>Order_ZF_2_L1\<close> for more intuitive notation.\<close>

definition
  "Interval(r,a,b) \<equiv> r``{a} \<inter> r-``{b}"

text\<open>We also define the maximum (the greater of) two elemnts
  in the obvious way.\<close>

definition
  "GreaterOf(r,a,b) \<equiv> (if \<langle> a,b\<rangle> \<in> r then b else a)"

text\<open>The definition a a minimum (the smaller of) two elements.\<close>

definition
  "SmallerOf(r,a,b) \<equiv> (if \<langle> a,b\<rangle> \<in> r then a else b)"

text\<open>We say that a set has a maximum if it has an element that is
  not smaller that any other one. We show that
  under some conditions this element of the set is unique (if exists).\<close>

definition
  "HasAmaximum(r,A) \<equiv> \<exists>M\<in>A.\<forall>x\<in>A. \<langle>x,M\<rangle> \<in> r"

text\<open>A similar definition what it means that a set has a minimum.\<close>

definition
  "HasAminimum(r,A) \<equiv> \<exists>m\<in>A.\<forall>x\<in>A. \<langle>m,x\<rangle> \<in> r"

text\<open>Definition of the maximum of a set.\<close>

definition
  "Maximum(r,A) \<equiv> THE M. M\<in>A \<and> (\<forall>x\<in>A. \<langle>x,M\<rangle> \<in> r)"

text\<open>Definition of a minimum of a set.\<close>

definition
  "Minimum(r,A) \<equiv> THE m. m\<in>A \<and> (\<forall>x\<in>A. \<langle>m,x\<rangle> \<in> r)"

text\<open>The supremum of a set $A$ is defined as the minimum of the set of
  upper bounds, i.e. the set
  $\{u.\forall_{a\in A} \langle a,u\rangle \in r\}=\bigcap_{a\in A} r\{a\}$.
   Recall that in Isabelle/ZF
  \<open>r-``(A)\<close> denotes the inverse image of the set $A$ by relation $r$
  (i.e. \<open>r-``(A)\<close>=$\{ x: \langle x,y\rangle\in r$ for some $y\in A\}$).\<close>

definition
  "Supremum(r,A) \<equiv> Minimum(r,\<Inter>a\<in>A. r``{a})"

text\<open> The notion of "having a supremum" is the same as the set of upper bounds having a
  minimum, but having it a a separate notion does simplify notattion in soma cases.
  The definition is written in terms of
  images of singletons $\{ x\}$ under relation. To understand this formulation note
  that the set of upper bounds of a set $A\subseteq X$ is
  $\bigcap_{x\in A}\{ y\in X | \langle x,y\rangle \in r \}$, which is the same
  as $\bigcap_{x\in A} r(\{ x \})$, where $r(\{ x \})$ is the image of the singleton $\{ x\}$ under
  relation $r$. \<close>

definition
  "HasAsupremum(r,A) \<equiv> HasAminimum(r,\<Inter>a\<in>A. r``{a})"

text\<open> The notion of "having an infimum" is the same as the set of lower bounds having a
  maximum. \<close>

definition
  "HasAnInfimum(r,A) \<equiv> HasAmaximum(r,\<Inter>a\<in>A. r-``{a})"

text\<open>Infimum is defined analogously.\<close>

definition
  "Infimum(r,A) \<equiv> Maximum(r,\<Inter>a\<in>A. r-``{a})"

text\<open>We define a relation to be complete if every nonempty bounded
  above set has a supremum.\<close>

definition
  IsComplete ("_ {is complete}") where
  "r {is complete} \<equiv>
  \<forall>A. IsBoundedAbove(A,r) \<and> A\<noteq>0 \<longrightarrow> HasAminimum(r,\<Inter>a\<in>A. r``{a})"

text\<open>If a relation down-directs a set, then a larger one does as well.\<close>

lemma down_dir_mono: assumes "r {down-directs} X" "r\<subseteq>R"
  shows "R {down-directs} X" using assms unfolding DownDirects_def
  by blast

text\<open>If a relation up-directs a set, then a larger one does as well.\<close>

lemma up_dir_mono: assumes "r {up-directs} X" "r\<subseteq>R"
  shows "R {up-directs} X" using assms unfolding UpDirects_def
  by blast

text\<open>The essential condition to show that a total relation is reflexive.\<close>

lemma Order_ZF_1_L1: assumes "r {is total on} X" and "a\<in>X"
  shows "\<langle>a,a\<rangle> \<in> r" using assms IsTotal_def by auto

text\<open>A total relation is reflexive.\<close>

lemma total_is_refl:
  assumes "r {is total on} X"
  shows "refl(X,r)" using assms Order_ZF_1_L1 refl_def by simp

text\<open>A linear order is partial order.\<close>

lemma Order_ZF_1_L2: assumes "IsLinOrder(X,r)"
  shows "IsPartOrder(X,r)"
  using assms IsLinOrder_def IsPartOrder_def refl_def Order_ZF_1_L1
  by auto

text\<open>Partial order that is total is linear.\<close>

lemma Order_ZF_1_L3:
  assumes "IsPartOrder(X,r)" and "r {is total on} X"
  shows "IsLinOrder(X,r)"
  using assms IsPartOrder_def IsLinOrder_def
  by simp

text\<open>Relation that is total on a set is total on any subset.\<close>

lemma Order_ZF_1_L4: assumes "r {is total on} X" and "A\<subseteq>X"
  shows "r {is total on} A"
  using assms IsTotal_def by auto

text\<open>We can restrict a partial order relation to the domain. \<close>

lemma part_ord_restr: assumes "IsPartOrder(X,r)"
  shows "IsPartOrder(X,r \<inter> X\<times>X)"
  using assms unfolding IsPartOrder_def refl_def antisym_def trans_def by auto

text\<open> We can restrict a total order relation to the domain. \<close>

lemma total_ord_restr: assumes "r {is total on} X"
  shows "(r \<inter> X\<times>X) {is total on} X"
  using assms unfolding IsTotal_def by auto

text\<open>A linear relation is linear on any subset and we can restrict it to any subset.\<close>

lemma ord_linear_subset: assumes  "IsLinOrder(X,r)" and "A\<subseteq>X"
  shows  "IsLinOrder(A,r)" and  "IsLinOrder(A,r \<inter> A\<times>A)"
proof -
  from assms show "IsLinOrder(A,r)" using IsLinOrder_def Order_ZF_1_L4 by blast
  then have "IsPartOrder(A,r \<inter> A\<times>A)" and "(r \<inter> A\<times>A) {is total on} A"
    using Order_ZF_1_L2 part_ord_restr total_ord_restr unfolding IsLinOrder_def
    by auto
  then show "IsLinOrder(A,r \<inter> A\<times>A)" using Order_ZF_1_L3 by simp
qed

text\<open>If the relation is total, then every set is a union of those elements
  that are nongreater than a given one and nonsmaller than a given one.\<close>

lemma Order_ZF_1_L5:
  assumes "r {is total on} X" and "A\<subseteq>X" and "a\<in>X"
  shows "A = {x\<in>A. \<langle>x,a\<rangle> \<in> r} \<union> {x\<in>A. \<langle>a,x\<rangle> \<in> r}"
  using assms IsTotal_def by auto

text\<open>A technical fact about reflexive relations.\<close>

lemma refl_add_point:
  assumes "refl(X,r)" and "A \<subseteq> B \<union> {x}" and "B \<subseteq> X" and
  "x \<in> X" and "\<forall>y\<in>B. \<langle>y,x\<rangle> \<in> r"
  shows "\<forall>a\<in>A. \<langle>a,x\<rangle> \<in> r"
  using assms refl_def by auto

subsection\<open>Intervals\<close>

text\<open>In this section we discuss intervals.\<close>

text\<open>The next lemma explains the notation of the definition of an interval.\<close>

lemma Order_ZF_2_L1:
  shows "x \<in> Interval(r,a,b) \<longleftrightarrow> \<langle> a,x\<rangle> \<in> r \<and> \<langle> x,b\<rangle> \<in> r"
  using Interval_def by auto

text\<open>Since there are some problems with applying the above lemma
  (seems that simp and auto don't handle equivalence very well), we
  split \<open>Order_ZF_2_L1\<close> into two lemmas.\<close>

lemma Order_ZF_2_L1A: assumes "x \<in> Interval(r,a,b)"
  shows "\<langle> a,x\<rangle> \<in> r"  "\<langle> x,b\<rangle> \<in> r"
  using assms  Order_ZF_2_L1 by auto

text\<open> \<open>Order_ZF_2_L1\<close>, implication from right to left.\<close>

lemma Order_ZF_2_L1B: assumes "\<langle> a,x\<rangle> \<in> r"  "\<langle> x,b\<rangle> \<in> r"
  shows "x \<in> Interval(r,a,b)"
  using assms Order_ZF_2_L1 by simp

text\<open>If the relation is reflexive, the endpoints belong to the interval.\<close>

lemma Order_ZF_2_L2: assumes "refl(X,r)"
  and "a\<in>X"  "b\<in>X" and "\<langle> a,b\<rangle> \<in> r"
  shows
  "a \<in> Interval(r,a,b)"
  "b \<in> Interval(r,a,b)"
  using assms refl_def Order_ZF_2_L1 by auto

text\<open>Under the assumptions of \<open>Order_ZF_2_L2\<close>, the interval is
  nonempty.\<close>

lemma Order_ZF_2_L2A: assumes "refl(X,r)"
  and "a\<in>X"  "b\<in>X" and "\<langle> a,b\<rangle> \<in> r"
  shows "Interval(r,a,b) \<noteq> 0"
proof -
  from assms have "a \<in> Interval(r,a,b)"
    using Order_ZF_2_L2 by simp
  then show "Interval(r,a,b) \<noteq> 0" by auto
qed

text\<open>If $a,b,c,d$ are in this order, then $[b,c]\subseteq [a,d]$. We
  only need trasitivity for this to be true.\<close>

lemma Order_ZF_2_L3:
  assumes A1: "trans(r)" and A2:"\<langle> a,b\<rangle>\<in>r"  "\<langle> b,c\<rangle>\<in>r"  "\<langle> c,d\<rangle>\<in>r"
shows "Interval(r,b,c) \<subseteq> Interval(r,a,d)"
proof
  fix x assume A3: "x \<in> Interval(r, b, c)"
  note A1
  moreover from A2 A3 have "\<langle> a,b\<rangle> \<in> r \<and> \<langle> b,x\<rangle> \<in> r" using Order_ZF_2_L1A
    by simp
  ultimately have T1: "\<langle> a,x\<rangle> \<in> r" by (rule Fol1_L3)
  note A1
  moreover from A2 A3 have "\<langle> x,c\<rangle> \<in> r \<and> \<langle> c,d\<rangle> \<in> r" using Order_ZF_2_L1A
    by simp
  ultimately have "\<langle> x,d\<rangle> \<in> r" by (rule Fol1_L3)
  with T1 show "x \<in> Interval(r,a,d)" using Order_ZF_2_L1B
    by simp
qed

text\<open>For reflexive and antisymmetric relations the interval with equal
  endpoints consists only of that endpoint.\<close>

lemma Order_ZF_2_L4:
  assumes A1: "refl(X,r)" and A2: "antisym(r)" and A3: "a\<in>X"
  shows "Interval(r,a,a) = {a}"
proof
  from A1 A3 have "\<langle> a,a\<rangle> \<in> r" using refl_def by simp
  with A1 A3 show "{a} \<subseteq> Interval(r,a,a)" using Order_ZF_2_L2 by simp
  from A2 show "Interval(r,a,a) \<subseteq> {a}" using Order_ZF_2_L1A Fol1_L4
    by fast
qed

text\<open>For transitive relations the endpoints have to be in the relation for
  the interval to be nonempty.\<close>

lemma Order_ZF_2_L5: assumes A1: "trans(r)" and A2: "\<langle> a,b\<rangle> \<notin> r"
  shows "Interval(r,a,b) = 0"
proof -
  { assume "Interval(r,a,b)\<noteq>0" then obtain x where "x \<in> Interval(r,a,b)"
    by auto
  with A1 A2 have False using Order_ZF_2_L1A Fol1_L3 by fast
  } thus ?thesis by auto
qed

text\<open>If a relation is defined on a set, then intervals are subsets of that
  set.\<close>

lemma Order_ZF_2_L6: assumes A1: "r \<subseteq> X\<times>X"
  shows "Interval(r,a,b) \<subseteq> X"
  using assms Interval_def by auto

subsection\<open>Bounded sets\<close>

text\<open>In this section we consider properties of bounded sets.\<close>

text\<open>For reflexive relations singletons are bounded.\<close>

lemma Order_ZF_3_L1: assumes "refl(X,r)" and "a\<in>X"
  shows "IsBounded({a},r)"
  using assms refl_def IsBoundedAbove_def IsBoundedBelow_def
    IsBounded_def by auto

text\<open>Sets that are bounded above are contained in the domain of
  the relation.\<close>

lemma Order_ZF_3_L1A: assumes "r \<subseteq> X\<times>X"
  and "IsBoundedAbove(A,r)"
  shows "A\<subseteq>X" using assms IsBoundedAbove_def by auto

text\<open>Sets that are bounded below are contained in the domain of
  the relation.\<close>

lemma Order_ZF_3_L1B: assumes "r \<subseteq> X\<times>X"
  and "IsBoundedBelow(A,r)"
  shows "A\<subseteq>X" using assms IsBoundedBelow_def by auto

text\<open>For a total relation, the greater of two elements,
  as defined above, is indeed greater of any of the two.\<close>

lemma Order_ZF_3_L2: assumes "r {is total on} X"
  and "x\<in>X" "y\<in>X"
  shows
  "\<langle>x,GreaterOf(r,x,y)\<rangle> \<in> r"
  "\<langle>y,GreaterOf(r,x,y)\<rangle> \<in> r"
  "\<langle>SmallerOf(r,x,y),x\<rangle> \<in> r"
  "\<langle>SmallerOf(r,x,y),y\<rangle> \<in> r"
  using assms IsTotal_def Order_ZF_1_L1 GreaterOf_def SmallerOf_def
  by auto

text\<open>If $A$ is bounded above by $u$, $B$ is bounded above by $w$,
  then $A\cup B$ is bounded above by the greater of $u,w$.\<close>

lemma Order_ZF_3_L2B:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "u\<in>X" "w\<in>X"
  and A4: "\<forall>x\<in>A. \<langle> x,u\<rangle> \<in> r" "\<forall>x\<in>B. \<langle> x,w\<rangle> \<in> r"
  shows "\<forall>x\<in>A\<union>B. \<langle>x,GreaterOf(r,u,w)\<rangle> \<in> r"
proof
  let ?v = "GreaterOf(r,u,w)"
  from A1 A3 have T1: "\<langle> u,?v\<rangle> \<in> r" and T2: "\<langle> w,?v\<rangle> \<in> r"
    using Order_ZF_3_L2 by auto
  fix x assume A5: "x\<in>A\<union>B" show "\<langle>x,?v\<rangle> \<in> r"
  proof -
    { assume "x\<in>A"
    with A4 T1 have "\<langle> x,u\<rangle> \<in> r \<and> \<langle> u,?v\<rangle> \<in> r" by simp
    with A2 have "\<langle>x,?v\<rangle> \<in> r" by (rule Fol1_L3) }
  moreover
  { assume "x\<notin>A"
    with A5 A4 T2 have "\<langle> x,w\<rangle> \<in> r \<and> \<langle> w,?v\<rangle> \<in> r" by simp
    with A2 have "\<langle>x,?v\<rangle> \<in> r" by (rule Fol1_L3) }
  ultimately show ?thesis by auto
  qed
qed

text\<open>For total and transitive relation the union of two sets bounded
  above is bounded above.\<close>

lemma Order_ZF_3_L3:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "IsBoundedAbove(A,r)" "IsBoundedAbove(B,r)"
  and A4: "r \<subseteq> X\<times>X"
  shows "IsBoundedAbove(A\<union>B,r)"
proof -
  { assume "A=0 \<or> B=0"
    with A3 have "IsBoundedAbove(A\<union>B,r)" by auto }
  moreover
  { assume "\<not> (A = 0 \<or> B = 0)"
    then have T1: "A\<noteq>0" "B\<noteq>0" by auto
    with A3 obtain u w where D1: "\<forall>x\<in>A. \<langle> x,u\<rangle> \<in> r" "\<forall>x\<in>B. \<langle> x,w\<rangle> \<in> r"
      using IsBoundedAbove_def by auto
    let ?U = "GreaterOf(r,u,w)"
    from T1 A4 D1 have "u\<in>X" "w\<in>X" by auto
    with A1 A2 D1 have "\<forall>x\<in>A\<union>B.\<langle> x,?U\<rangle> \<in> r"
      using Order_ZF_3_L2B by blast
    then have "IsBoundedAbove(A\<union>B,r)"
      using IsBoundedAbove_def by auto }
  ultimately show ?thesis by auto
qed

text\<open>For total and transitive relations if a set $A$ is bounded above then
  $A\cup \{a\}$ is bounded above.\<close>

lemma Order_ZF_3_L4:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "IsBoundedAbove(A,r)" and A4: "a\<in>X" and A5: "r \<subseteq> X\<times>X"
  shows "IsBoundedAbove(A\<union>{a},r)"
proof -
  from A1 have "refl(X,r)"
    using total_is_refl by simp
  with assms show ?thesis using
    Order_ZF_3_L1 IsBounded_def Order_ZF_3_L3 by simp
qed

text\<open>If $A$ is bounded below by $l$, $B$ is bounded below by $m$,
  then $A\cup B$ is bounded below by the smaller of $u,w$.\<close>

lemma Order_ZF_3_L5B:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "l\<in>X" "m\<in>X"
  and A4: "\<forall>x\<in>A. \<langle> l,x\<rangle> \<in> r" "\<forall>x\<in>B. \<langle> m,x\<rangle> \<in> r"
  shows "\<forall>x\<in>A\<union>B. \<langle>SmallerOf(r,l,m),x\<rangle> \<in> r"
proof
  let ?k = "SmallerOf(r,l,m)"
  from A1 A3 have T1: "\<langle> ?k,l\<rangle> \<in> r" and T2: "\<langle> ?k,m\<rangle> \<in> r"
    using Order_ZF_3_L2 by auto
  fix x assume A5: "x\<in>A\<union>B" show "\<langle>?k,x\<rangle> \<in> r"
  proof -
    { assume "x\<in>A"
      with A4 T1 have "\<langle> ?k,l\<rangle> \<in> r \<and> \<langle> l,x\<rangle> \<in> r" by simp
      with A2 have "\<langle>?k,x\<rangle> \<in> r" by (rule Fol1_L3) }
    moreover
    { assume "x\<notin>A"
      with A5 A4 T2 have "\<langle> ?k,m\<rangle> \<in> r \<and> \<langle> m,x\<rangle> \<in> r" by simp
      with A2 have "\<langle>?k,x\<rangle> \<in> r" by (rule Fol1_L3) }
    ultimately show ?thesis by auto
  qed
qed

text\<open>For total and transitive relation the union of two sets bounded
  below is bounded below.\<close>

lemma Order_ZF_3_L6:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "IsBoundedBelow(A,r)" "IsBoundedBelow(B,r)"
  and A4: "r \<subseteq> X\<times>X"
  shows "IsBoundedBelow(A\<union>B,r)"
proof -
  { assume "A=0 \<or> B=0"
    with A3 have ?thesis by auto }
  moreover
  { assume "\<not> (A = 0 \<or> B = 0)"
    then have T1: "A\<noteq>0" "B\<noteq>0" by auto
    with A3 obtain l m where D1: "\<forall>x\<in>A. \<langle> l,x\<rangle> \<in> r" "\<forall>x\<in>B. \<langle> m,x\<rangle> \<in> r"
      using IsBoundedBelow_def by auto
    let ?L = "SmallerOf(r,l,m)"
    from T1 A4 D1 have T1: "l\<in>X" "m\<in>X" by auto
    with A1 A2 D1 have "\<forall>x\<in>A\<union>B.\<langle> ?L,x\<rangle> \<in> r"
      using Order_ZF_3_L5B by blast
    then have "IsBoundedBelow(A\<union>B,r)"
      using IsBoundedBelow_def by auto }
  ultimately show ?thesis by auto
qed

text\<open>For total and transitive relations if a set $A$ is bounded below then
  $A\cup \{a\}$ is bounded below.\<close>

lemma Order_ZF_3_L7:
  assumes A1: "r {is total on} X" and A2: "trans(r)"
  and A3: "IsBoundedBelow(A,r)" and A4: "a\<in>X" and A5: "r \<subseteq> X\<times>X"
  shows "IsBoundedBelow(A\<union>{a},r)"
proof -
  from A1 have "refl(X,r)"
    using total_is_refl by simp
  with assms show ?thesis using
    Order_ZF_3_L1 IsBounded_def Order_ZF_3_L6 by simp
qed

text\<open>For total and transitive relations unions of two bounded sets are
  bounded.\<close>

theorem Order_ZF_3_T1:
  assumes "r {is total on} X" and "trans(r)"
  and "IsBounded(A,r)" "IsBounded(B,r)"
  and "r \<subseteq> X\<times>X"
  shows "IsBounded(A\<union>B,r)"
  using assms Order_ZF_3_L3 Order_ZF_3_L6 Order_ZF_3_L7 IsBounded_def
  by simp

text\<open>For total and transitive relations if a set $A$ is bounded then
  $A\cup \{a\}$ is bounded.\<close>

lemma Order_ZF_3_L8:
  assumes "r {is total on} X" and "trans(r)"
  and "IsBounded(A,r)" and "a\<in>X" and "r \<subseteq> X\<times>X"
  shows "IsBounded(A\<union>{a},r)"
  using assms total_is_refl Order_ZF_3_L1 Order_ZF_3_T1 by blast

text\<open>A sufficient condition for a set to be bounded below.\<close>

lemma Order_ZF_3_L9: assumes A1: "\<forall>a\<in>A. \<langle>l,a\<rangle> \<in> r"
  shows "IsBoundedBelow(A,r)"
proof -
  from A1 have "\<exists>l. \<forall>x\<in>A. \<langle>l,x\<rangle> \<in> r"
    by auto
  then show "IsBoundedBelow(A,r)"
    using IsBoundedBelow_def by simp
qed

text\<open>A sufficient condition for a set to be bounded above.\<close>

lemma Order_ZF_3_L10: assumes A1: "\<forall>a\<in>A. \<langle>a,u\<rangle> \<in> r"
  shows "IsBoundedAbove(A,r)"
proof -
  from A1 have "\<exists>u. \<forall>x\<in>A. \<langle>x,u\<rangle> \<in> r"
    by auto
  then show "IsBoundedAbove(A,r)"
    using IsBoundedAbove_def by simp
qed

text\<open>Intervals are bounded.\<close>
(*proof that uses Order_ZF_3_L9 and Order_ZF_3_L10 and is not shorter *)
lemma Order_ZF_3_L11: shows
  "IsBoundedAbove(Interval(r,a,b),r)"
  "IsBoundedBelow(Interval(r,a,b),r)"
  "IsBounded(Interval(r,a,b),r)"
proof -
  { fix x assume "x \<in> Interval(r,a,b)"
    then have "\<langle> x,b\<rangle> \<in> r"  "\<langle> a,x\<rangle> \<in> r"
      using Order_ZF_2_L1A by auto
  } then have
      "\<exists>u. \<forall>x\<in>Interval(r,a,b). \<langle> x,u\<rangle> \<in> r"
      "\<exists>l. \<forall>x\<in>Interval(r,a,b). \<langle> l,x\<rangle> \<in> r"
    by auto
  then show
    "IsBoundedAbove(Interval(r,a,b),r)"
    "IsBoundedBelow(Interval(r,a,b),r)"
    "IsBounded(Interval(r,a,b),r)"
    using IsBoundedAbove_def IsBoundedBelow_def IsBounded_def
    by auto
qed

text\<open>A subset of a set that is bounded below is bounded below.\<close>

lemma Order_ZF_3_L12: assumes A1: "IsBoundedBelow(A,r)" and A2: "B\<subseteq>A"
  shows "IsBoundedBelow(B,r)"
proof -
  { assume "A = 0"
    with assms have "IsBoundedBelow(B,r)"
      using IsBoundedBelow_def by auto }
  moreover
  { assume "A \<noteq> 0"
    with A1 have "\<exists>l. \<forall>x\<in>A. \<langle>l,x\<rangle> \<in> r"
      using IsBoundedBelow_def by simp
    with A2 have "\<exists>l.\<forall>x\<in>B. \<langle>l,x\<rangle> \<in> r" by auto
    then have "IsBoundedBelow(B,r)" using IsBoundedBelow_def
      by auto }
  ultimately show "IsBoundedBelow(B,r)" by auto
qed

text\<open>A subset of a set that is bounded above is bounded above.\<close>

lemma Order_ZF_3_L13: assumes A1: "IsBoundedAbove(A,r)" and A2: "B\<subseteq>A"
  shows "IsBoundedAbove(B,r)"
proof -
  { assume "A = 0"
    with assms have "IsBoundedAbove(B,r)"
      using IsBoundedAbove_def by auto }
  moreover
  { assume "A \<noteq> 0"
    with A1 have "\<exists>u. \<forall>x\<in>A. \<langle>x,u\<rangle> \<in> r"
      using IsBoundedAbove_def by simp
    with A2 have "\<exists>u.\<forall>x\<in>B. \<langle>x,u\<rangle> \<in> r" by auto
    then have "IsBoundedAbove(B,r)" using IsBoundedAbove_def
      by auto }
  ultimately show "IsBoundedAbove(B,r)" by auto
qed

text\<open>If for every element of $X$ we can find one in $A$
  that is greater, then the $A$ can not be bounded above.
  Works for relations that are total, transitive and antisymmetric,
  (i.e. for linear order relations).\<close>

lemma Order_ZF_3_L14:
  assumes A1: "r {is total on} X"
  and A2: "trans(r)" and A3: "antisym(r)"
  and A4: "r \<subseteq> X\<times>X" and A5: "X\<noteq>0"
  and A6: "\<forall>x\<in>X. \<exists>a\<in>A. x\<noteq>a \<and> \<langle>x,a\<rangle> \<in> r"
  shows "\<not>IsBoundedAbove(A,r)"
proof -
  { from A5 A6 have I: "A\<noteq>0" by auto
    moreover assume "IsBoundedAbove(A,r)"
    ultimately obtain u where II: "\<forall>x\<in>A. \<langle> x,u\<rangle> \<in> r"
      using IsBounded_def IsBoundedAbove_def by auto
    with A4 I have "u\<in>X" by auto
    with A6 obtain b where "b\<in>A" and III: "u\<noteq>b" and "\<langle>u,b\<rangle> \<in> r"
      by auto
    with II have "\<langle>b,u\<rangle> \<in> r"  "\<langle>u,b\<rangle> \<in> r" by auto
    with A3 have "b=u" by (rule Fol1_L4)
    with III have False by simp
  } thus "\<not>IsBoundedAbove(A,r)" by auto
qed

text\<open>The set of elements in a set $A$ that are nongreater than
  a given element is bounded above.\<close>

lemma Order_ZF_3_L15: shows "IsBoundedAbove({x\<in>A. \<langle>x,a\<rangle> \<in> r},r)"
  using IsBoundedAbove_def by auto

text\<open>If $A$ is bounded below, then the set of elements in a set $A$
  that are nongreater than a given element is bounded.\<close>

lemma Order_ZF_3_L16: assumes A1: "IsBoundedBelow(A,r)"
  shows "IsBounded({x\<in>A. \<langle>x,a\<rangle> \<in> r},r)"
proof -
  { assume "A=0"
    then have "IsBounded({x\<in>A. \<langle>x,a\<rangle> \<in> r},r)"
      using IsBoundedBelow_def IsBoundedAbove_def IsBounded_def
      by auto }
  moreover
  { assume "A\<noteq>0"
    with A1 obtain l where I: "\<forall>x\<in>A. \<langle>l,x\<rangle> \<in> r"
      using IsBoundedBelow_def by auto
    then have "\<forall>y\<in>{x\<in>A. \<langle>x,a\<rangle> \<in> r}. \<langle>l,y\<rangle> \<in> r" by simp
    then have "IsBoundedBelow({x\<in>A. \<langle>x,a\<rangle> \<in> r},r)"
      by (rule Order_ZF_3_L9)
    then have "IsBounded({x\<in>A. \<langle>x,a\<rangle> \<in> r},r)"
      using Order_ZF_3_L15 IsBounded_def by simp }
  ultimately show ?thesis by blast
qed

end


subsection\<open>HC, SC, and ND\<close>
theory HCSCND
imports HCSC SCND NDHC
begin

theorem HCSCND:
  defines "hc F \<equiv> AX10 \<turnstile>\<^sub>H F"
  defines "nd F \<equiv> {} \<turnstile> F"
  defines "sc F \<equiv> {#} \<Rightarrow> {# F #}"
  shows "hc F \<longleftrightarrow> nd F" and "nd F \<longleftrightarrow> sc F" and "sc F \<longleftrightarrow> hc F"
using HCSC[where F=F and \<Gamma>=Mempty, simplified]
      SCND[where \<Gamma>=Mempty and \<Delta>="{#F#}"] ND.ND.CC[where F=F and \<Gamma>="{}"]
      NDHC[where \<Gamma>="{}" and F=F]
by(simp_all add: assms) blast+

end


section {*L\_ATS\_Derivation\_Map*}
theory
  L_ATS_Derivation_Map

imports
  PRJ_06_06__PRE

begin

locale ATS_Derivation_Map =
  GL:
  ATS
  "TSstructure1 :: 'TSstructure1 \<Rightarrow> bool"
  "configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "initial_configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "step_labels1 :: 'TSstructure1 \<Rightarrow> 'label1 set"
  "step_relation1 :: 'TSstructure1 \<Rightarrow> 'conf1 \<Rightarrow> 'label1 \<Rightarrow> 'conf1 \<Rightarrow> bool"
  +
  GR:
  ATS
  "TSstructure2 :: 'TSstructure2 \<Rightarrow> bool"
  "configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "initial_configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "step_labels2 :: 'TSstructure2 \<Rightarrow> 'label2 set"
  "step_relation2 :: 'TSstructure2 \<Rightarrow> 'conf2 \<Rightarrow> 'label2 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  for
    TSstructure1 configurations1 initial_configurations1 step_labels1 step_relation1 TSstructure2 configurations2 initial_configurations2 step_labels2 step_relation2
    +
  fixes TSstructure_rel :: "'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> bool"

context ATS_Derivation_Map begin

definition der_map :: "
  'TSstructure1
  \<Rightarrow> 'TSstructure2
  \<Rightarrow> ('TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'label1 \<Rightarrow> 'label2)
  \<Rightarrow> ('TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2)
  \<Rightarrow> ('label1, 'conf1)derivation
  \<Rightarrow> ('label2, 'conf2)derivation"
  where
    "der_map G1 G2 fe fc d =
  (\<lambda>n. case d n of None \<Rightarrow> None | Some (pair e c) \<Rightarrow>
  Some (pair (case e of None \<Rightarrow> None | Some e' \<Rightarrow> Some(fe G1 G2 e')) (fc G1 G2 c)))"

definition der_map_preserves_steps :: "
  ('TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'label1 \<Rightarrow> 'label2)
  \<Rightarrow> ('TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2)
  \<Rightarrow> bool"
  where
    "der_map_preserves_steps fe fc =
  (\<forall>G1 G2 c1 e c2.
  TSstructure1 G1
  \<longrightarrow> TSstructure_rel G1 G2
  \<longrightarrow> TSstructure2 G2
  \<longrightarrow> step_relation1 G1 c1 e c2
  \<longrightarrow> step_relation2 G2 (fc G1 G2 c1) (fe G1 G2 e) (fc G1 G2 c2))"

lemma der_map_preserves_derivation: "
  TSstructure1 G1
  \<Longrightarrow> TSstructure_rel G1 G2
  \<Longrightarrow> TSstructure2 G2
  \<Longrightarrow> GL.derivation G1 d
  \<Longrightarrow> der_map_preserves_steps fe fc
  \<Longrightarrow> GR.derivation G2 (der_map G1 G2 fe fc d)"
  apply(simp (no_asm) add: GR.derivation_def)
  apply(clarsimp)
  apply(rename_tac i)(*strict*)
  apply(case_tac i)
   apply(rename_tac i)(*strict*)
   apply(clarsimp)
   apply(simp add: GL.derivation_def)
   apply(erule_tac
      x="0"
      in allE)
   apply(clarsimp)
   apply(simp add: der_map_def)
   apply(case_tac "d 0")
    apply(clarsimp)
   apply(rename_tac a)(*strict*)
   apply(clarsimp)
   apply(case_tac a)
   apply(rename_tac a option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac option b)(*strict*)
   apply(case_tac option)
    apply(rename_tac option b)(*strict*)
    apply(clarsimp)
   apply(rename_tac option b a)(*strict*)
   apply(clarsimp)
  apply(rename_tac i nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat)(*strict*)
  apply(case_tac "der_map G1 G2 fe fc d (Suc nat)")
   apply(rename_tac nat)(*strict*)
   apply(clarsimp)
  apply(rename_tac nat a)(*strict*)
  apply(case_tac "d (Suc nat)")
   apply(rename_tac nat a)(*strict*)
   apply(simp add: der_map_def)
  apply(rename_tac nat a aa)(*strict*)
  apply(subgoal_tac "X" for X)
   apply(rename_tac nat a aa)(*strict*)
   prefer 2
   apply(rule_tac
      n="nat"
      and m="Suc nat"
      in GL.step_detail_before_some_position)
     apply(rename_tac nat a aa)(*strict*)
     apply(force)
    apply(rename_tac nat a aa)(*strict*)
    apply(force)
   apply(rename_tac nat a aa)(*strict*)
   apply(force)
  apply(rename_tac nat a aa)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat a e1 e2 c1 c2)(*strict*)
  apply(case_tac a)
  apply(rename_tac nat a e1 e2 c1 c2 option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 option b)(*strict*)
  apply(simp add: der_map_def)
  apply(case_tac option)
   apply(rename_tac nat e1 e2 c1 c2 option b)(*strict*)
   apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2 option b a)(*strict*)
  apply(clarsimp)
  apply(rename_tac nat e1 e2 c1 c2)(*strict*)
  apply(simp add: der_map_preserves_steps_def)
  done

definition der_map_preserves_configurations_initial :: "
  ('TSstructure1\<Rightarrow>'TSstructure2\<Rightarrow>'conf1\<Rightarrow>'conf2)
  \<Rightarrow>bool"
  where
    "der_map_preserves_configurations_initial fc =
  (\<forall>G1 G2 c.
  TSstructure1 G1
  \<longrightarrow> TSstructure_rel G1 G2
  \<longrightarrow> TSstructure2 G2
  \<longrightarrow> c \<in> initial_configurations1 G1
  \<longrightarrow> (fc G1 G2 c) \<in> initial_configurations2 G2)"

theorem der_map_preserves_derivation_initial: "
  TSstructure1 G1
  \<Longrightarrow> TSstructure_rel G1 G2
  \<Longrightarrow> TSstructure2 G2
  \<Longrightarrow> GL.derivation_initial G1 d
  \<Longrightarrow> der_map_preserves_steps fe fc
  \<Longrightarrow> der_map_preserves_configurations_initial fc
  \<Longrightarrow> GR.derivation_initial G2 (der_map G1 G2 fe fc d)"
  apply(rule GR.derivation_initialI)
   apply(rule der_map_preserves_derivation)
       apply(force)
      apply(force)
     apply(force)
    apply(rule GL.derivation_initial_is_derivation)
    apply(force)
   apply(force)
  apply(simp add: der_map_def)
  apply(clarsimp)
  apply(rename_tac c)(*strict*)
  apply(simp add: get_configuration_def)
  apply(case_tac "d 0")
   apply(rename_tac c)(*strict*)
   apply(clarsimp)
  apply(rename_tac c a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac c a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac option b)(*strict*)
  apply(case_tac option)
   apply(rename_tac option b)(*strict*)
   apply(clarsimp)
   apply(rename_tac b)(*strict*)
   apply(simp add: GL.derivation_initial_def)
   apply(clarsimp)
   apply(simp add: der_map_preserves_configurations_initial_def)
  apply(rename_tac option b a)(*strict*)
  apply(force)
  done

end

end


(*  Title:      HOL/TLA/Stfun.thy
    Author:     Stephan Merz
    Copyright:  1998 University of Munich
*)

section {* States and state functions for TLA as an "intensional" logic *}

theory Stfun
imports Intensional
begin

typedecl state
instance state :: world ..

type_synonym 'a stfun = "state => 'a"
type_synonym stpred  = "bool stfun"

consts
  (* Formalizing type "state" would require formulas to be tagged with
     their underlying state space and would result in a system that is
     much harder to use. (Unlike Hoare logic or Unity, TLA has quantification
     over state variables, and therefore one usually works with different
     state spaces within a single specification.) Instead, "state" is just
     an anonymous type whose only purpose is to provide "Skolem" constants.
     Moreover, we do not define a type of state variables separate from that
     of arbitrary state functions, again in order to simplify the definition
     of flexible quantification later on. Nevertheless, we need to distinguish
     state variables, mainly to define the enabledness of actions. The user
     identifies (tuples of) "base" state variables in a specification via the
     "meta predicate" basevars, which is defined here.
  *)
  stvars    :: "'a stfun => bool"

syntax
  "_PRED"   :: "lift => 'a"                          ("PRED _")
  "_stvars" :: "lift => bool"                        ("basevars _")

translations
  "PRED P"   =>  "(P::state => _)"
  "_stvars"  ==  "CONST stvars"

defs
  (* Base variables may be assigned arbitrary (type-correct) values.
     Note that vs may be a tuple of variables. The correct identification
     of base variables is up to the user who must take care not to
     introduce an inconsistency. For example, "basevars (x,x)" would
     definitely be inconsistent.
  *)
  basevars_def:  "stvars vs == range vs = UNIV"

lemma basevars: "!!vs. basevars vs ==> EX u. vs u = c"
  apply (unfold basevars_def)
  apply (rule_tac b = c and f = vs in rangeE)
   apply auto
  done

lemma base_pair1: "!!x y. basevars (x,y) ==> basevars x"
  apply (simp (no_asm) add: basevars_def)
  apply (rule equalityI)
   apply (rule subset_UNIV)
  apply (rule subsetI)
  apply (drule_tac c = "(xa, arbitrary) " in basevars)
  apply auto
  done

lemma base_pair2: "!!x y. basevars (x,y) ==> basevars y"
  apply (simp (no_asm) add: basevars_def)
  apply (rule equalityI)
   apply (rule subset_UNIV)
  apply (rule subsetI)
  apply (drule_tac c = "(arbitrary, xa) " in basevars)
  apply auto
  done

lemma base_pair: "!!x y. basevars (x,y) ==> basevars x & basevars y"
  apply (rule conjI)
  apply (erule base_pair1)
  apply (erule base_pair2)
  done

(* Since the unit type has just one value, any state function can be
   regarded as "base". The following axiom can sometimes be useful
   because it gives a trivial solution for "basevars" premises.
*)
lemma unit_base: "basevars (v::unit stfun)"
  apply (unfold basevars_def)
  apply auto
  done

lemma baseE: "[| basevars v; !!x. v x = c ==> Q |] ==> Q"
  apply (erule basevars [THEN exE])
  apply blast
  done

(* -------------------------------------------------------------------------------
   The following shows that there should not be duplicates in a "stvars" tuple:
*)

lemma "!!v. basevars (v::bool stfun, v) ==> False"
  apply (erule baseE)
  apply (subgoal_tac "(LIFT (v,v)) x = (True, False)")
   prefer 2
   apply assumption
  apply simp
  done

end


theory Foldl3_FoldlImpl_Proofs
imports "$HETS_LIB/Isabelle/MainHC"
begin

datatype 'a List = nil | cons 'a "'a List"

consts
"foldl" :: "'b => (('b => ('a => 'b option)) => ('a List => 'b option))"   ( "foldl" )
"snoc" :: "'a List => ('a => 'a List)"   ( "snoc" )
lemma case_List_SomeProm [simp]:" (case caseVar of nil => Some (n)
   | cons a list => Some (c a list)
) =
Some (case caseVar of nil => n
   | cons a list => c a list
)"
apply (case_tac caseVar)
apply (auto)
done

axioms
ga_List: "True"
Ax2: "apt (apt (Some snoc) (Some nil)) (Some x) = apt (apt (Some cons) (Some x)) (Some nil)"
Ax3: "apt (apt (Some snoc) (apt (apt (Some cons) (Some y)) (Some l))) (Some x) = apt (apt (Some cons) (Some y)) (apt (apt (Some snoc) (Some l)) (Some x))"
Ax4: "app (apt (apt (Some foldl) (Some z)) (Some f)) (Some nil) = (Some z)"
Ax5: "app (apt (apt (Some foldl) (Some z)) (Some f)) (apt (apt (Some cons) (Some x)) (Some l)) = app (apt (apt (Some foldl) (app (apt (Some f) (Some z)) (Some x))) (Some f)) (Some l)"

(*replaced first apt by app in Ax4, snd app by apt in Ax5*)
lemmas ga_List' = ga_List [simplified]
lemmas Ax2' = Ax2 [simplified]
lemmas Ax3' = Ax3 [simplified]
lemmas Ax4' = Ax4 [simplified]
lemmas Ax5' = Ax5 [simplified]
thm Ax5'

declare ga_List' [simp]
declare ga_List [simp]
declare Ax2' [simp]
declare Ax2 [simp]
declare Ax3' [simp]
declare Ax3 [simp]
declare Ax4' [simp]
declare Ax4 [simp]
declare Ax5' [simp]
declare Ax5 [simp]

theorem ga_List1: "True"
apply (auto)
done

theorem Ax21: "apt (apt (Some snoc) (Some nil)) (Some x) = apt (apt (Some cons) (Some x)) (Some nil)"
apply (auto)
done

theorem Ax31: "apt (apt (Some snoc) (apt (apt (Some cons) (Some y)) (Some l))) (Some x) = apt (apt (Some cons) (Some y)) (apt (apt (Some snoc) (Some l)) (Some x))"
apply (auto)
done

theorem Ax41: "app (apt (apt (Some foldl) (Some z)) (Some f)) (Some nil) = (Some z)"
(* Replaced first apt by app *)
apply (auto)
done

theorem Ax51: "app (apt (apt (Some foldl) (Some z)) (Some f)) (apt (apt (Some snoc) (Some l)) (Some x)) = app (apt (Some f) (app (apt (apt (Some foldl) (Some z)) (Some f)) (Some l))) (Some x)"
(* replaced first apt in apt apt apt by app, 2 times; snd app on rhs by apt *)
apply (rule_tac x=z in spec)
apply (simp)
apply (induct l)
apply (auto)
apply (case_tac "f xa x")

apply (simp)
apply (simp)
apply (case_tac "f xa a")

apply (auto)
done

end


section \<open>Implementation\<close>

text \<open>This section presents the implementation of the algorithm.\<close>

theory Implementation
  imports Preliminaries
begin

subsection \<open>Protocol messages\<close>

text \<open>The
proven-safe core of the protocol works by sending messages as described here. The remainder of the
protocol may send other messages too, and may drop, reorder or duplicate any of these messages, but
must not send these messages itself to ensure safety. Another way of thinking of these messages is
to consider them as ``fire-and-forget'' RPC invocations that, on receipt, call some local method, maybe
update the receiving node's state, and maybe yield some further messages. The @{type nat} parameter to each
message refers to a slot number.\<close>

datatype TermOption = NO_TERM | SomeTerm Term

instantiation TermOption :: linorder
begin

fun less_TermOption :: "TermOption \<Rightarrow> TermOption \<Rightarrow> bool"
  where "t < NO_TERM = False"
  | "NO_TERM < SomeTerm t = True"
  | "SomeTerm t\<^sub>1 < SomeTerm t\<^sub>2 = (t\<^sub>1 < t\<^sub>2)"

definition less_eq_TermOption :: "TermOption \<Rightarrow> TermOption \<Rightarrow> bool"
  where "(t\<^sub>1 :: TermOption) \<le> t\<^sub>2 \<equiv> t\<^sub>1 = t\<^sub>2 \<or> t\<^sub>1 < t\<^sub>2"

instance proof
  fix x y z :: TermOption
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" unfolding less_eq_TermOption_def apply auto
    using less_TermOption.elims apply fastforce
    by (metis less_TermOption.elims(2) less_TermOption.simps(3) less_not_sym)

  show "x \<le> x" by (simp add: less_eq_TermOption_def)

  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z" unfolding less_eq_TermOption_def apply auto
    by (metis TermOption.distinct(1) TermOption.inject dual_order.strict_trans less_TermOption.elims(2) less_TermOption.elims(3))

  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y" unfolding less_eq_TermOption_def apply auto
    using \<open>(x < y) = (x \<le> y \<and> \<not> y \<le> x)\<close> less_eq_TermOption_def by blast

  show "x \<le> y \<or> y \<le> x" unfolding less_eq_TermOption_def apply auto
    by (metis TermOption.distinct(1) TermOption.inject less_TermOption.elims(3) neqE)
qed

end

lemma NO_TERM_le [simp]: "NO_TERM \<le> t" by (cases t, simp_all add: less_eq_TermOption_def)
lemma le_NO_TERM [simp]: "(t \<le> NO_TERM) = (t = NO_TERM)" by (cases t, simp_all add: less_eq_TermOption_def)
lemma le_SomeTerm [simp]: "(SomeTerm t\<^sub>1 \<le> SomeTerm t\<^sub>2) = (t\<^sub>1 \<le> t\<^sub>2)" by (auto simp add: less_eq_TermOption_def)

datatype Message
  = StartJoin Term
  | Vote Slot Term TermOption
  | ClientValue Value
  | PublishRequest Slot Term Value
  | PublishResponse Slot Term
  | ApplyCommit Slot Term
  | CatchUpRequest
  | CatchUpResponse Slot "Node set" ClusterState
  | DiscardJoinVotes
  | Reboot

text \<open>Some prose descriptions of these messages follows, in order to give a bit more of an
intuitive understanding of their purposes.\<close>

text \<open>The message @{term "StartJoin t"} may be sent by any node to attempt to start a master
election in the given term @{term t}.\<close>

text \<open>The message @{term "Vote i t a"} may be sent by a node in response
to a @{term StartJoin} message. It indicates that the sender knows all committed values for slots
strictly below @{term i}, and that the sender will no longer vote (i.e. send an @{term
PublishResponse}) in any term prior to @{term t}. The field @{term a} is either @{term
None} or @{term "Some t'"}. In the former case this indicates that
the node has not yet sent any @{term PublishResponse} message in slot @{term i}, and in the latter
case it indicates that the largest term in which it has previously sent an @{term PublishResponse}
message is @{term t'}.  All
nodes must avoid sending a @{term Vote} message to two different masters in the same term.\<close>

text \<open>The message @{term "ClientValue x"} may be sent by any node and indicates an attempt to
reach consensus on the value @{term x}.\<close>

text \<open>The message @{term "PublishRequest i t v"} may be sent by the elected master of term
@{term t} to request the other master-eligible nodes to vote for value @{term v} to be committed in
slot @{term i}.\<close>

text \<open>The message @{term "PublishResponse i t"} may be sent by node in response to
the corresponding @{term PublishRequest} message, indicating that the sender votes for the value
proposed by the master of term @{term t} to be committed in slot @{term i}.\<close>

text \<open>The message @{term "ApplyCommit i t"} indicates that the value proposed by the master of
term @{term t} in slot @{term i} received a quorum of votes and is therefore committed.\<close>

text \<open>The message @{term Reboot} may be sent by any node to represent the restart of a node, which
loses any ephemeral state.\<close>

text \<open>The abstract model of Zen keeps track of the set of all messages that have ever been
sent, and asserts that this set obeys certain invariants, listed below. Further below, it will be
shown that these invariants imply that each slot obeys the @{term oneSlot} invariants above and
hence that each slot cannot see inconsistent committed values.\<close>

datatype Destination = Broadcast | OneNode Node

record RoutedMessage =
  sender :: Node
  destination :: Destination
  payload :: Message

text \<open>It will be useful to be able to choose the optional term with the greater term,
so here is a function that does that.\<close>

subsection \<open>Node implementation\<close>

text \<open>Each node holds the following local data.\<close>

record TermValue =
  tvTerm :: Term
  tvValue :: Value

record NodeData =
  currentNode :: Node
  currentTerm :: Term
  (* committed state *)
  firstUncommittedSlot :: Slot
  currentVotingNodes :: "Node set"
  currentClusterState :: ClusterState
  (* accepted state *)
  lastAcceptedData :: "TermValue option"
  (* election state *)
  joinVotes :: "Node set"
  electionWon :: bool
  (* publish state *)
  publishPermitted :: bool
  publishVotes :: "Node set"

definition lastAcceptedValue :: "NodeData \<Rightarrow> Value"
  where "lastAcceptedValue nd \<equiv> tvValue (THE lad. lastAcceptedData nd = Some lad)"

definition lastAcceptedTerm :: "NodeData \<Rightarrow> TermOption"
  where "lastAcceptedTerm nd \<equiv> case lastAcceptedData nd of None \<Rightarrow> NO_TERM | Some lad \<Rightarrow> SomeTerm (tvTerm lad)"

definition isQuorum :: "NodeData \<Rightarrow> Node set \<Rightarrow> bool"
  where "isQuorum nd q \<equiv> q \<in> majorities (currentVotingNodes nd)"

lemma lastAcceptedValue_joinVotes_update[simp]: "lastAcceptedValue (joinVotes_update f nd) = lastAcceptedValue nd" by (simp add: lastAcceptedValue_def)
lemma lastAcceptedTerm_joinVotes_update[simp]: "lastAcceptedTerm (joinVotes_update f nd) = lastAcceptedTerm nd" by (simp add: lastAcceptedTerm_def)

lemma lastAcceptedValue_electionWon_update[simp]: "lastAcceptedValue (electionWon_update f nd) = lastAcceptedValue nd" by (simp add: lastAcceptedValue_def)
lemma lastAcceptedTerm_electionWon_update[simp]: "lastAcceptedTerm (electionWon_update f nd) = lastAcceptedTerm nd" by (simp add: lastAcceptedTerm_def)

text \<open>This method publishes a value via a @{term PublishRequest} message.\<close>

definition publishValue :: "Value \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "publishValue x nd \<equiv>
        if electionWon nd \<and> publishPermitted nd
              then ( nd \<lparr> publishPermitted := False \<rparr>
                   , Some (PublishRequest
                             (firstUncommittedSlot nd)
                             (currentTerm nd) x) )
              else (nd, None)"

text \<open>This method updates the node's current term (if necessary) and discards any data associated
with the previous term.\<close>

definition ensureCurrentTerm :: "Term \<Rightarrow> NodeData \<Rightarrow> NodeData"
  where
    "ensureCurrentTerm t nd \<equiv>
        if t \<le> currentTerm nd
            then nd
            else nd
              \<lparr> joinVotes := {}
              , currentTerm := t
              , electionWon := False
              , publishPermitted := True
              , publishVotes := {} \<rparr>"

text \<open>This method updates the node's state on receipt of a vote (a @{term Vote}) in an election.\<close>

definition addElectionVote :: "Node \<Rightarrow> Slot => TermOption \<Rightarrow> NodeData \<Rightarrow> NodeData"
  where
    "addElectionVote s i a nd \<equiv> let newVotes = insert s (joinVotes nd)
      in nd \<lparr> joinVotes := newVotes
            , electionWon := isQuorum nd newVotes \<rparr>"

text \<open>Clients request the cluster to achieve consensus on certain values using the @{term ClientValue}
message which is handled as follows.\<close>

definition handleClientValue :: "Value \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handleClientValue x nd \<equiv> if lastAcceptedTerm nd = NO_TERM then publishValue x nd else (nd, None)"

text \<open>A @{term StartJoin} message is checked for acceptability and then handled by updating the
node's term and yielding a @{term Vote} message as follows.\<close>

definition handleStartJoin :: "Term \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handleStartJoin t nd \<equiv>
        if currentTerm nd < t
          then ( ensureCurrentTerm t nd
               , Some (Vote (firstUncommittedSlot nd)
                                     t
                                    (lastAcceptedTerm nd)))
          else (nd, None)"

text \<open>A @{term Vote} message is checked for acceptability and then handled as follows, perhaps
yielding a @{term PublishRequest} message.\<close>

definition handleVote :: "Node \<Rightarrow> Slot \<Rightarrow> Term \<Rightarrow> TermOption \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handleVote s i t a nd \<equiv>
         if t = currentTerm nd
             \<and> (i < firstUncommittedSlot nd
                \<or> (i = firstUncommittedSlot nd \<and> a \<le> lastAcceptedTerm nd))
          then let nd1 = addElectionVote s i a nd
               in (if lastAcceptedTerm nd = NO_TERM then (nd1, None) else publishValue (lastAcceptedValue nd1) nd1)
          else (nd, None)"

text \<open>A @{term PublishRequest} message is checked for acceptability and then handled as follows,
yielding a @{term PublishResponse} message.\<close>

definition handlePublishRequest :: "Slot \<Rightarrow> Term \<Rightarrow> Value \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handlePublishRequest i t x nd \<equiv>
          if i = firstUncommittedSlot nd
                \<and> t = currentTerm nd
          then ( nd \<lparr> lastAcceptedData := Some \<lparr> tvTerm = t, tvValue = x \<rparr> \<rparr>
               , Some (PublishResponse i t))
          else (nd, None)"

text \<open>This method sends an @{term ApplyCommit} message if a quorum of votes has been received.\<close>

definition commitIfQuorate :: "NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "commitIfQuorate nd = (nd, if isQuorum nd (publishVotes nd)
                                  then Some (ApplyCommit (firstUncommittedSlot nd) (currentTerm nd)) else None)"

text \<open>A @{term PublishResponse} message is checked for acceptability and handled as follows. If
this message, together with the previously-received messages, forms a quorum of votes then the
value is committed, yielding an @{term ApplyCommit} message.\<close>

definition handlePublishResponse :: "Node \<Rightarrow> Slot \<Rightarrow> Term \<Rightarrow> NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handlePublishResponse s i t nd \<equiv>
        if i = firstUncommittedSlot nd \<and> t = currentTerm nd
        then commitIfQuorate (nd \<lparr> publishVotes := insert s (publishVotes nd) \<rparr>)
        else (nd, None)"

text \<open>This method updates the node's state when a value is committed.\<close>

definition applyAcceptedValue :: "NodeData \<Rightarrow> NodeData"
  where
    "applyAcceptedValue nd \<equiv> case lastAcceptedValue nd of
        NoOp \<Rightarrow> nd
      | Reconfigure votingNodes \<Rightarrow> nd
          \<lparr> currentVotingNodes := set votingNodes
          , electionWon := joinVotes nd \<in> majorities (set votingNodes) \<rparr>
      | ClusterStateDiff diff \<Rightarrow> nd \<lparr> currentClusterState := diff (currentClusterState nd) \<rparr>"

text \<open>An @{term ApplyCommit} message is applied to the current node's state, updating its configuration
and \texttt{ClusterState} via the @{term applyValue} method. It yields no messages.\<close>

definition handleApplyCommit :: "Slot \<Rightarrow> Term \<Rightarrow> NodeData \<Rightarrow> NodeData"
  where
    "handleApplyCommit i t nd \<equiv>
        if i = firstUncommittedSlot nd \<and> lastAcceptedTerm nd = SomeTerm t
          then (applyAcceptedValue nd)
                     \<lparr> firstUncommittedSlot := i + 1
                     , lastAcceptedData := None
                     , publishPermitted := True
                     , publishVotes := {} \<rparr>
          else nd"

definition handleCatchUpRequest :: "NodeData \<Rightarrow> (NodeData * Message option)"
  where
    "handleCatchUpRequest nd = (nd, Some (CatchUpResponse (firstUncommittedSlot nd)
                                              (currentVotingNodes nd) (currentClusterState nd)))"

definition handleCatchUpResponse :: "Slot \<Rightarrow> Node set \<Rightarrow> ClusterState \<Rightarrow> NodeData \<Rightarrow> NodeData"
  where
    "handleCatchUpResponse i conf cs nd \<equiv>
      if firstUncommittedSlot nd < i
        then nd \<lparr> firstUncommittedSlot := i
                , publishPermitted := True
                , publishVotes := {}
                , currentVotingNodes := conf
                , currentClusterState := cs
                , lastAcceptedData := None
                , joinVotes := {}
                , electionWon := False \<rparr>
        else nd"

text \<open>A @{term Reboot} message simulates the effect of a reboot, discarding any ephemeral state but
preserving the persistent state. It yields no messages.\<close>

definition handleReboot :: "NodeData \<Rightarrow> NodeData"
  where
    "handleReboot nd \<equiv>
      \<lparr> currentNode = currentNode nd
      , currentTerm = currentTerm nd
      , firstUncommittedSlot = firstUncommittedSlot nd
      , currentVotingNodes = currentVotingNodes nd
      , currentClusterState = currentClusterState nd
      , lastAcceptedData = lastAcceptedData nd
      , joinVotes = {}
      , electionWon = False
      , publishPermitted = False
      , publishVotes = {} \<rparr>"

text \<open>A @{term DiscardJoinVotes} message discards the votes received by a node. It yields
no messages.\<close>

definition handleDiscardJoinVotes :: "NodeData \<Rightarrow> NodeData"
  where
  "handleDiscardJoinVotes nd \<equiv> nd \<lparr> electionWon := False, joinVotes := {} \<rparr>"

text \<open>This function dispatches incoming messages to the appropriate handler method, and
routes any responses to the appropriate places. In particular, @{term Vote} messages
(sent by the @{term handleStartJoin} method) and
@{term PublishResponse} messages (sent by the @{term handlePublishRequest} method) are
only sent to a single node, whereas all other responses are broadcast to all nodes.\<close>

definition ProcessMessage :: "NodeData \<Rightarrow> RoutedMessage \<Rightarrow> (NodeData * RoutedMessage option)"
  where
    "ProcessMessage nd msg \<equiv>
      let respondTo =
          (\<lambda> d (nd, mmsg). case mmsg of
               None \<Rightarrow> (nd, None)
             | Some msg \<Rightarrow> (nd,
                 Some \<lparr> sender = currentNode nd, destination = d,
                             payload = msg \<rparr>));
          respondToSender = respondTo (OneNode (sender msg));
          respondToAll    = respondTo Broadcast
      in
        if destination msg \<in> { Broadcast, OneNode (currentNode nd) }
        then case payload msg of
          StartJoin t
              \<Rightarrow> respondToSender (handleStartJoin t nd)
          | Vote i t a
              \<Rightarrow> respondToAll (handleVote (sender msg) i t a nd)
          | ClientValue x
              \<Rightarrow> respondToAll (handleClientValue x nd)
          | PublishRequest i t x
              \<Rightarrow> respondToSender (handlePublishRequest i t x nd)
          | PublishResponse i t
              \<Rightarrow> respondToAll (handlePublishResponse (sender msg) i t nd)
          | ApplyCommit i t
              \<Rightarrow> (handleApplyCommit i t nd, None)
          | CatchUpRequest
              \<Rightarrow> respondToSender (handleCatchUpRequest nd)
          | CatchUpResponse i conf cs
              \<Rightarrow> (handleCatchUpResponse i conf cs nd, None)
          | DiscardJoinVotes
              \<Rightarrow> (handleDiscardJoinVotes nd, None)
          | Reboot
              \<Rightarrow> (handleReboot nd, None)
        else (nd, None)"

text \<open>Nodes are initialised to this state. The data required is the initial configuration, @{term Q\<^sub>0}
and the initial \texttt{ClusterState}, here shown as @{term "ClusterState 0"}.\<close>

definition initialNodeState :: "Node \<Rightarrow> NodeData"
  where "initialNodeState n =
      \<lparr> currentNode = n
      , currentTerm = 0
      , firstUncommittedSlot = 0
      , currentVotingNodes = V\<^sub>0
      , currentClusterState = CS\<^sub>0
      , lastAcceptedData = None
      , joinVotes = {}
      , electionWon = False
      , publishPermitted = False
      , publishVotes = {} \<rparr>"
(* Note: publishPermitted could be True initially, but in the actual implementation we call the
same constructor whether we're starting up from afresh or recovering from a reboot, and the value
is really unimportant as we need to run an election in a new term before becoming master anyway,
so it's hard to justify putting any effort into calculating different values for these two cases.
Instead just set it to False initially.*)

end