(*  Title:       Instances of Schneider's generalized protocol of clock synchronization
    Author:      Damián Barsotti <damian at hal.famaf.unc.edu.ar>, 2006
    Maintainer:  Damián Barsotti <damian at hal.famaf.unc.edu.ar>
*)

header {* Interactive Convergence Algorithms (ICA) *}

theory ICAInstance imports Complex_Main begin

text {* This algorithm is presented in \cite{lamport_cs}. *}

text {* A proof of the three properties can be found in
\cite{shankar92mechanical}. *}

subsection {* Model of the system *}

text {* The main ideas for the formalization of the system were
obtained from \cite{shankar92mechanical}.  *}

subsubsection {* Types in the formalization *}

text {* The election of the basics types was based on
\cite{shankar92mechanical}. There, the process are natural numbers and
the real time and the clock readings are reals. *}

type_synonym process = nat
type_synonym time = real       -- "real time"
type_synonym Clocktime = real  -- "time of the clock readings (clock time)"

subsubsection {* Some constants *}

text{* Here we define some parameters of the algorithm that we use:
the number of process and the fix value that is used to discard the
processes whose clocks differ more than this amount from the own one
(see \cite{shankar92mechanical}). The defined constants must satisfy
this axiom (if $np = 0$ we have a division by cero in the definition
of the convergence function).  *}

axiomatization
  np :: nat      -- "Number of processes" and
  \<Delta> :: Clocktime -- "Fix value to discard processes" where
  constants_ax: "0 <= \<Delta> \<and> np > 0"

text {* We define also the set of process that the algorithm
manage. This definition exist only for readability matters. *}

definition
PR :: "process set" where
[simp]: "PR = {..<np}"

subsubsection {* Convergence function *}

text {* This functions is called ``Egocentric Average''
(\cite{schneider87understanding})*}

text {* In this algorithm each process has an array where it store the
clocks readings from the others processes (including itself). We
formalise that as a function from processes to clock time as
\cite{shankar92mechanical}. *}

text {* First we define an auxiliary function. It takes a function of
clock readings and two processes, and return de reading of the second
process if the difference of the readings is grater than @{term \<Delta>},
otherwise it returns the reading of the first one. *}

definition
  fiX :: "[(process \<Rightarrow> Clocktime), process, process] \<Rightarrow> Clocktime" where
  "fiX f p l = (if \<bar>f p - f l\<bar> <= \<Delta> then (f l) else (f p))"

text {* And finally the convergence function. This is defined with the
builtin generalized summation over a set constructor of Isabelle.
Also we had to use the overloaded @{term real} function to typecast de
number @{term np}. *}

definition
  (* The averaging function to calculate clock adjustment *)
  cfni :: "[process, (process \<Rightarrow> Clocktime)] \<Rightarrow> Clocktime" where
  "cfni p f = (\<Sum> l\<in>{..<np}. fiX f p l) / (real np)"

subsection {* Translation Invariance property.*}

text {*We first need to prove this auxiliary lemma.*}

lemma trans_inv':
"(\<Sum> l\<in>{..<np'}. fiX (\<lambda> y. f y + x) p l) =
        (\<Sum> l\<in>{..<np'}. fiX f p l) + real np' * x"
apply (induct_tac np')
apply (auto simp add: cfni_def  fiX_def real_of_nat_Suc
       distrib_right lessThan_Suc)
done

theorem trans_inv:
"\<forall> p f x . cfni p (\<lambda> y. f y + x) = cfni p f + x"
apply (auto simp add: cfni_def trans_inv' distrib_right
       divide_inverse  constants_ax)
done

subsection {* Precision Enhancement property *}

text {* An informal proof of this theorem can be found in
\cite{shankar92mechanical} *}

subsubsection {* Auxiliary lemmas *}

lemma finitC:
  "C \<subseteq> PR \<Longrightarrow> finite C"
proof-
  assume "C \<subseteq> PR"
  thus ?thesis using finite_subset by auto
qed

lemma finitnpC:
  "finite (PR - C)"
proof-
  show ?thesis  using finite_Diff by auto
qed

text {* The next lemmas are about arithmetic properties of the
generalized summation over a set constructor. *}

lemma sum_abs_triangle_ineq:
"finite S \<Longrightarrow>
  \<bar>\<Sum>l\<in>S. (f::'a \<Rightarrow> 'b::linordered_idom) l\<bar> <= (\<Sum>l\<in>S. \<bar>f l\<bar>)"
  (is "... \<Longrightarrow> ?P S")
  by (rule setsum_abs)

lemma sum_le:
  "\<lbrakk>finite S ; \<forall> r\<in>S. f r <= b \<rbrakk>
  \<Longrightarrow>
  (\<Sum>l\<in>S. f l) <= real (card S) * b"
  (is "\<lbrakk> finite S ; \<forall> r\<in>S. f r <= b \<rbrakk> \<Longrightarrow> ?P S")
proof(induct S rule: finite_induct)
  show "?P {}" by simp
next
  fix F x
  assume  finit: "finite F" and xnotinF: "x \<notin> F" and
          HI1: "\<forall>r\<in>F. f r \<le> b \<Longrightarrow> setsum f F \<le> real (card F) * b"
          and HI2: "\<forall>r\<in>insert x F. f r \<le> b"
  from HI1 HI2 and finit and xnotinF
  have "setsum f (insert x F) <= b + real (card F) * b"
    by auto
  also
  have "... = real (Suc (card  F)) * b"
    by (simp add: distrib_right  real_of_nat_Suc)
  also
  from   finit xnotinF have "...= real (card (insert x F)) * b"
    by simp
  finally
  show "?P (insert x F)" .
qed

lemma sum_np_eq:
assumes
  hC: "C \<subseteq> PR"
shows
  "(\<Sum>l\<in>{..<np}. f l) = (\<Sum>l\<in>C. f l) + (\<Sum>l\<in>({..<np}-C). f l)"
proof-
  note finitC[where C=C]
  moreover
  note finitnpC[where C=C]
  moreover
  have "C \<inter> ({..<np}-C) = {}" by auto
  moreover
  from hC have "C \<union> ({..<np}-C) = {..<np}" by auto
  ultimately
  show ?thesis
    using setsum.union_disjoint[where A=C and B="{..<np} - C"]
    by auto
qed

lemma abs_sum_np_ineq:
assumes
  hC: "C \<subseteq> PR"
shows
  "\<bar>(\<Sum>l\<in>{..<np}. (f::nat \<Rightarrow> real) l)\<bar> <=
     (\<Sum>l\<in>C. \<bar>f l\<bar>) + (\<Sum>l\<in>({..<np}-C). \<bar>f l\<bar>)"
    (is "?abs_sum <= ?sumC + ?sumnpC")
proof-
  from hC and sum_np_eq[where f=f]
  have "?abs_sum = \<bar>(\<Sum>l\<in>C. f l) + (\<Sum>l\<in>({..<np}-C). f l)\<bar>"
    (is "?abs_sum = \<bar>?sumC' + ?sumnpC'\<bar>")
    by simp
  also
  from abs_triangle_ineq
  have "...<= \<bar>?sumC'\<bar> + \<bar>?sumnpC'\<bar>" .
  also
  have "... <=  ?sumC + ?sumnpC "
  proof-
    from hC finitC sum_abs_triangle_ineq
    have "\<bar>?sumC'\<bar> <= ?sumC" by blast
    moreover
    from finitnpC and
           sum_abs_triangle_ineq[where f=f and S="PR-C"]
    have "\<bar>?sumnpC'\<bar> <= ?sumnpC"
      by force
    ultimately
    show ?thesis by arith
  qed
  finally
  show ?thesis .
qed

text {* The next lemmas are about the existence of bounds that are
necesary in order to prove the Precicion Enhancement theorem. *}

lemma fiX_ubound:
  "fiX f p l <= f p + \<Delta>"
proof(cases "\<bar>f p - f l\<bar> \<le> \<Delta>")
  assume asm: "\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f l" by (simp add: fiX_def)
  also
  from asm have "f l <= f p + \<Delta>" by arith
  finally
  show ?thesis by arith
next
  assume asm: "\<not>\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f p" by (simp add: fiX_def)
  also
  from asm and  constants_ax have "f p <= f p + \<Delta>" by arith
  finally
  show ?thesis by arith
qed

lemma fiX_lbound:
  "f p - \<Delta> <= fiX f p l"
proof(cases "\<bar>f p - f l\<bar> \<le> \<Delta>")
  assume asm: "\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f l" by (simp add: fiX_def)
  also
  from asm have "f p - \<Delta> <= f l" by arith
  finally
  show ?thesis by arith
next
  assume asm: "\<not>\<bar>f p - f l\<bar> \<le> \<Delta>"
  with  constants_ax have "f p - \<Delta> <= f p" by arith
  also
  from asm have "f p = fiX f p l" by (simp add: fiX_def)
  finally
  show ?thesis by arith
qed

lemma abs_fiX_bound: "\<bar>fiX f p l - f p \<bar> <= \<Delta>"
proof-
(*
from constants_ax and fiX_lbound and fiX_ubound show ?thesis by arith
*)
have "f p - \<Delta> <= fiX f p l \<and> fiX f p l <= f p + \<Delta> \<longrightarrow> ?thesis"
by arith
with fiX_lbound  fiX_ubound show ?thesis by blast
qed

lemma abs_dif_fiX_bound_C_aux1:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - fiX g q r\<bar> <= x + y"
proof(cases "\<bar>f p - f r\<bar> \<le> \<Delta>")
  case True
  note outer_IH = True
  show ?thesis
  proof(cases "\<bar>g q - g r\<bar> \<le> \<Delta>")
    case True
    show ?thesis
    proof -
      from hpC and hby1 have "0<=y" by force
      with hrC and hbx have "\<bar> f r - g r \<bar> <= x + y" by auto
      with outer_IH and True show ?thesis
        by (auto simp add: fiX_def)
    qed
  next
    case False
    show ?thesis
    proof -
      from outer_IH and False
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f r - g q\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f r - f q + f q - g q \<bar>" by simp
      also
      have "... <= \<bar> f r - f q \<bar> + \<bar> f q - g q \<bar>"
        by arith
      also
      from hbx hby1 hpC hqC hrC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  qed
next
  case False
  note outer_IH = False
  show ?thesis
  proof(cases "\<bar>g q - g r\<bar> \<le> \<Delta>")
    case True
    show ?thesis
    proof -
      from outer_IH and True
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f p - g r\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f p - f r + f r - g r \<bar>" by simp
      also
      from abs_triangle_ineq[where a = "f p - f r" and
                                   b = "f r - g r"]
      have "... <= \<bar> f p - f r \<bar> + \<bar> f r - g r \<bar>"
        by auto
      also
      from hbx hby1 hpC hrC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  next
    case False
    show ?thesis
    proof -
      from outer_IH and False
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f p - g q\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f p - f q + f q - g q \<bar>" by simp
      also
      from abs_triangle_ineq[where a = "f p - f q" and
                                   b = "f q - g q"]
      have "... <= \<bar> f p - f q \<bar> + \<bar> f q - g q \<bar>"
        by auto
      also
      from hbx hby1 hpC hqC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  qed
qed

lemma abs_dif_fiX_bound_C_aux2:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "y <= \<Delta> \<longrightarrow> \<bar>fiX f p r - fiX g q r\<bar> <= x"
proof
  assume hyd: "y<=\<Delta>"
  show "\<bar>fiX f p r - fiX g q r\<bar> <= x"
  proof-
    from hpC and hrC and hby1 and hyd have "\<bar>f p - f r\<bar> \<le> \<Delta>"
      by force
    moreover
    from hqC and hrC and hby2 and hyd have "\<bar>g q - g r\<bar> \<le> \<Delta>"
      by force
    moreover
    from hrC and hbx have "\<bar> f r - g r \<bar> <= x " by auto
    ultimately
    show ?thesis
      by (auto simp add: fiX_def)
  qed
qed

lemma abs_dif_fiX_bound_C:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - fiX g q r\<bar> <=
                     x + (if (y <= \<Delta>) then 0 else y)"
proof (cases "y <= \<Delta>")
  case True
  with abs_dif_fiX_bound_C_aux2 and
    hbx and hby1 and hby2 and hpC and hqC and hrC
  have "\<bar>fiX f p r - fiX g q r\<bar> <= x " by blast
  with True show "?thesis" by simp
next
  case False
  with abs_dif_fiX_bound_C_aux1 and
    hbx and hby1 and hby2 and hpC and hqC and hrC
  have "\<bar>fiX f p r - fiX g q r\<bar> <= x + y" by blast
  with False show "?thesis" by simp
qed

subsubsection {* Main theorem *}

theorem prec_enh:
assumes
  hC: "C \<subseteq> PR" and
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfni p f - cfni q g \<bar> <=
  (real (card C) * (x + (if (y <= \<Delta>) then 0 else y)) +
    real (card ({..<np} - C)) * (2 * \<Delta> + x + y)) / real np"
       (is "\<bar> ?dif_div_np \<bar> <= ?B")
proof-
  have "\<bar>(\<Sum>l\<in>{..<np}. fiX f p l ) -
                    (\<Sum>l\<in>{..<np}. fiX g q l)\<bar> =
    \<bar>(\<Sum>l\<in>{..<np}. fiX f p l -fiX g q l)\<bar>"
    (is "\<bar>?dif\<bar> = \<bar>?dif'\<bar>" )
    by (simp add: setsum_subtractf)
  also
  from abs_sum_np_ineq hC
  have " ... <=
      (\<Sum>l\<in>C. \<bar>fiX f p l - fiX g q l\<bar>) +
      (\<Sum>l\<in>({..<np}-C). \<bar>fiX f p l - fiX g q l\<bar>)"
    (is " \<bar>?dif'\<bar> <= ?boundC' + ?boundnpC'" )
    by simp
  also
  have "... <=
    real (card C) * (x + (if (y <= \<Delta>) then 0 else y))+
    real (card ({..<np}-C)) * (2 * \<Delta> + x + y)"
    (is " ... <= ?boundC + ?boundnpC" )
  proof-
    have " ?boundC' <= ?boundC"
    proof -
      from abs_dif_fiX_bound_C and
        hbx and hby1 and hby2 and  hpC and hqC
      have "\<forall>r\<in>C.
        \<bar>fiX f p r - fiX g q r\<bar> <= x +
                         (if (y <= \<Delta>) then 0 else y)"
        by blast
      thus ?thesis using sum_le[where S=C] and finitC[OF hC]
        by force
    qed
    moreover
    have "?boundnpC' <= ?boundnpC"
    proof -
      from abs_dif_fiX_bound and
        hbx and hby1 and  hpC and hqC
      have "\<forall>r\<in>({..<np}-C). \<bar>fiX f p r - fiX g q r\<bar> <= 2 * \<Delta> + x + y"
        by blast
      with finitnpC
      show ?thesis
        by (auto intro: sum_le)
    qed
    ultimately
    show ?thesis by arith
  qed
  finally
  have bound: "\<bar>?dif\<bar> <= ?boundC + ?boundnpC" .
  thus ?thesis
  proof-
    have "?dif_div_np = ?dif / real np"
      by (simp add: cfni_def divide_inverse algebra_simps)
    hence "\<bar> cfni p f - cfni q g \<bar> = \<bar>?dif\<bar> / real np"
      by force
    with bound show "?thesis"
      by (auto simp add: cfni_def divide_inverse constants_ax)
  qed
qed

subsection {* Accuracy Preservation property *}

text {* First, a simple lemma about an arithmetic propertie of the
generalized summation over a set constructor. *}

lemma sum_div_card:
"(\<Sum>l\<in>{..<n::nat}. f l) + q * real n=
  (\<Sum>l\<in>{..<n}. f l + q )"
  (is "?Sl n = ?Sr n")
proof (induct n)
case 0 thus ?case by simp
next
case (Suc n)
thus ?case
  by (auto simp: real_of_nat_Suc distrib_left lessThan_Suc)
qed

text {* Next, some lemmas about bounds that are used in the proof of Accuracy Preservation *}

lemma bound_aux_C:
assumes
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - f q\<bar> <= x"
proof (cases "\<bar> f p - f r \<bar> <= \<Delta>")
  case True
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f r - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hqC hrC have "... <= x" by blast
  finally
  show ?thesis .
next
  case False
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f p - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hpC hqC have "... <= x" by blast
  finally
  show ?thesis .
qed

lemma bound_aux:
assumes
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows
  "\<bar>fiX f p r - f q\<bar> <= x + \<Delta>"
proof (cases "\<bar> f p - f r \<bar> <= \<Delta>")
  case True
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f r - f q \<bar>"
    by (simp add: fiX_def)
  also
  have "... = \<bar> (f r - f p) + (f p - f q) \<bar>"
    by arith
  also
  have "... <= \<bar> f p - f r \<bar> + \<bar> f p - f q \<bar>"
    by arith
  also
  from True have "... <= \<Delta> + \<bar> f p - f q \<bar>" by arith
  also
  from hby hpC hqC have "... <= \<Delta> + x" by simp
  finally
  show ?thesis by simp
next
  case False
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f p - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hpC hqC have "... <= x" by blast
  finally
  show ?thesis using constants_ax by arith
qed

subsubsection {* Main theorem *}

lemma accur_pres:
assumes
  hC: "C \<subseteq> PR" and
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfni p f - f q \<bar> <=
  (real (card C) * x + real (card ({..<np} - C)) * (x + \<Delta>))/
                  real np"
  (is "?abs1 <= (?bC + ?bnpC)/real np")
proof-
from abs_sum_np_ineq and hC have
  "\<bar>\<Sum>l\<in>{..<np}. fiX f p l  - f q \<bar> <=
    (\<Sum>l\<in>C. \<bar> fiX f p l  - f q \<bar>) +
            (\<Sum>l\<in>({..<np}-C). \<bar> fiX f p l  - f q \<bar>)"
  by simp
also
have
  "... <= real (card C) * x +
            real (card ({..<np} - C)) * (x + \<Delta>)"
  proof-
    have "(\<Sum>l\<in>C. \<bar> fiX f p l  - f q \<bar>) <=
                    real (card C) * x"
    proof-
      from bound_aux_C and
        hby and  hpC and hqC
      have "\<forall>r\<in>C.
        \<bar>fiX f p r - f q\<bar> <= x"
        by blast
      thus ?thesis using sum_le[where S=C] and finitC[OF hC]
        by force
    qed
    moreover
    have " (\<Sum>l\<in>({..<np}-C). \<bar> fiX f p l  - f q \<bar>) <=
                real (card ({..<np} - C)) * (x + \<Delta>)"
    proof -
      from bound_aux and
        hby and  hpC and hqC
      have "\<forall>r\<in>({..<np}-C).
        \<bar>fiX f p r - f q\<bar> <= x + \<Delta>"
        by blast
      thus ?thesis using sum_le[where S="{..<np}-C"]
        and finitnpC
        by force
    qed
    ultimately
    show ?thesis by arith
  qed
  finally
  have bound: "\<bar>\<Sum>l\<in>{..<np}. fiX f p l - f q\<bar>
  \<le> real (card C) * x + real (card ({..<np} - C)) * (x + \<Delta>)"
    .
  thus
    ?thesis
  proof-
    from constants_ax have
      res: "inverse (real np) * real np = 1"
      by auto
    have
      "(cfni p f - f q) * real np =
      (\<Sum>l\<in>{..<np}. fiX f p l) * real np / real np - f q * real np"
      by (simp add: cfni_def algebra_simps)
    also
    have "... =
      (\<Sum>l\<in>{..<np}. fiX f p l) - f q * real np"
      by simp
    also
    from sum_div_card[where f="fiX f p" and n=np and q="- f q"]
    have "... = (\<Sum>l\<in>{..<np}. fiX f p l - f q)"
      by simp
    finally
    have
      "(cfni p f - f q) * real np = (\<Sum>l\<in>{..<np}. fiX f p l - f q)"
      .
-- cambia
    hence
      "(cfni p f - f q) * real np / real np =
      (\<Sum>l\<in>{..<np}. fiX f p l - f q)/ real np"
      by auto
    with constants_ax have
      "(cfni p f - f q) =
      (\<Sum>l\<in>{..<np}. fiX f p l - f q) / real np"
    by simp
    hence "\<bar> cfni p f - f q \<bar> =
      \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q) / real np \<bar>"
      by simp
    also have
      "... = \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q)\<bar> / real np "
      by auto
    finally have "\<bar> cfni p f - f q \<bar> =
      \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q)\<bar> / real np "
      .
    with bound show "?thesis"
      by (auto simp add: cfni_def divide_inverse constants_ax)
  qed
qed

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_50
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun count :: "Nat => Nat list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 xs) =
     (if x y z2 then S (count y xs) else count y xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

theorem property0 :
  "((count y (isort z)) = (count y z))"
  oops

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

header {* Verification of Heap Sort *}

theory Heap
imports RemoveMax
begin

subsection {* Defining tree and properties of heap *}

datatype 'a Tree = "E" | "T" 'a "'a Tree" "'a Tree"

text{*With {\em E} is represented empty tree and with {\em T\ \ \ 'a\ \ \ 'a
  Tree\ \ \ 'a Tree} is represented a node whose root element is of
type {\em 'a} and its left and right branch is also a tree of
type {\em 'a}. *}

primrec size :: "'a Tree \<Rightarrow> nat" where
  "size E = 0"
| "size (T v l r) = 1 + size l + size r"

text{* Definition of the function that makes a multiset from the given tree: *}

primrec multiset where
  "multiset E = {#}"
| "multiset (T v l r) = multiset l + {#v#} + multiset r"

primrec val where
 "val (T v _ _) = v"

text{* Definition of the function that has the value {\em True} if the tree is
heap, otherwise it is {\em False}: *}

fun is_heap :: "'a::linorder Tree \<Rightarrow> bool" where
  "is_heap E = True"
| "is_heap (T v E E) = True"
| "is_heap (T v E r) = (v \<ge> val r \<and> is_heap r)"
| "is_heap (T v l E) = (v \<ge> val l \<and> is_heap l)"
| "is_heap (T v l r) = (v \<ge> val r \<and> is_heap r \<and> v \<ge> val l \<and> is_heap l)"

lemma heap_top_geq:
  assumes "a \<in># multiset t" "is_heap t"
  shows "val t \<ge> a"
using assms
by (induct t rule: is_heap.induct)  (auto split: split_if_asm)

lemma heap_top_max:
  assumes "t \<noteq> E" "is_heap t"
  shows "val t = Max (set_of (multiset t))"
proof (rule Max_eqI[symmetric])
  fix y
  assume "y \<in> set_of (multiset t)"
  thus "y \<le> val t"
    using heap_top_geq[of t y] `is_heap t`
    by simp
next
  show "val t \<in> set_of (multiset t)"
    using `t \<noteq> E`
    by (cases t) auto
qed simp

text{* The next step is to define function {\em remove\_max}, but the
question is weather implementation of {\em remove\_max} depends on
implementation of the functions {\em is\_heap} and {\em multiset}. The
answer is negative. This suggests that another step of refinement
could be added before definition of function {\em
  remove\_max}. Additionally, there are other reasons why this should
be done, for example, function {\em remove\_max} could be implemented
in functional or in imperative manner.
*}

locale Heap =  Collection empty is_empty of_list  multiset for
  empty :: "'b" and
  is_empty :: "'b \<Rightarrow> bool" and
  of_list :: "'a::linorder list \<Rightarrow> 'b" and
  multiset :: "'b \<Rightarrow> 'a::linorder multiset" +
  fixes as_tree :: "'b \<Rightarrow> 'a::linorder Tree"
  -- {* This function is not very important, but it is needed in order to avoide problems with types and to detect that observed object is a tree.*}
  fixes remove_max :: "'b \<Rightarrow> 'a \<times> 'b"
  assumes multiset: "multiset l = Heap.multiset (as_tree l)"
  assumes is_heap_of_list: "is_heap (as_tree (of_list i))"
  assumes as_tree_empty: "as_tree t = E \<longleftrightarrow> is_empty t"
  assumes remove_max_multiset':
  "\<lbrakk>\<not> is_empty l; (m, l') = remove_max l\<rbrakk> \<Longrightarrow> multiset l' + {#m#} = multiset l"
  assumes remove_max_is_heap:
  "\<lbrakk>\<not> is_empty l; is_heap (as_tree l); (m, l') = remove_max l\<rbrakk> \<Longrightarrow>
  is_heap (as_tree l')"
  assumes remove_max_val:
  "\<lbrakk> \<not> is_empty t; (m, t') = remove_max t\<rbrakk> \<Longrightarrow> m = val (as_tree t)"

text{* It is very easy to prove that locale {\em Heap} is sublocale of locale {\em RemoveMax} *}

sublocale Heap <
  RemoveMax empty is_empty of_list multiset remove_max "\<lambda> t. is_heap (as_tree t)"
proof
  fix x
  show "is_heap (as_tree (of_list x))"
    by (rule is_heap_of_list)
next
  fix l m l'
  assume "\<not> is_empty l" "(m, l') = remove_max l"
  thus "multiset l' + {#m#} = multiset l"
    by (rule remove_max_multiset')
next
  fix l m l'
  assume "\<not> is_empty l" "is_heap (as_tree l)" "(m, l') = remove_max l"
  thus "is_heap (as_tree l')"
    by (rule remove_max_is_heap)
next
  fix l m l'
  assume "\<not> is_empty l" "is_heap (as_tree l)" "(m, l') = remove_max l"
  thus "m = Max (set l)"
    unfolding set_def
    using heap_top_max[of "as_tree l"] remove_max_val[of l m l']
    using multiset is_empty_inj as_tree_empty
    by auto
qed

primrec in_tree where
  "in_tree v E = False"
| "in_tree v (T v' l r) \<longleftrightarrow> v = v' \<or> in_tree v l \<or> in_tree v r"

lemma is_heap_max:
  assumes "in_tree v t" "is_heap t"
  shows "val t \<ge> v"
using assms
apply (induct t rule:is_heap.induct)
by auto

end


(* Title:      Relation Algebra
   Author:     Alasdair Armstrong, Simon Foster, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Functions\<close>

theory Relation_Algebra_Functions
  imports Relation_Algebra_Vectors Relation_Algebra_Tests
begin

subsection \<open>Functions\<close>

text \<open>This section collects the most important properties of functions. Most
of them can be found in the books by Maddux and by Schmidt and Str\"ohlein. The
main material is on partial and total functions, injections, surjections,
bijections.\<close>

(* Perhaps this material should be reorganised so that related theorems are
grouped together ... *)

context relation_algebra
begin

definition is_p_fun :: "'a \<Rightarrow> bool"
  where "is_p_fun x \<equiv> x\<^sup>\<smile> ; x \<le> 1'"

definition is_total :: "'a \<Rightarrow> bool"
  where "is_total x \<equiv> 1' \<le> x ; x\<^sup>\<smile>"

definition is_map :: "'a \<Rightarrow> bool"
  where "is_map x \<equiv> is_p_fun x \<and> is_total x"

definition is_inj :: "'a \<Rightarrow> bool"
  where "is_inj x \<equiv> x ; x\<^sup>\<smile> \<le> 1'"

definition is_sur :: "'a \<Rightarrow> bool"
  where "is_sur x \<equiv> 1' \<le> x\<^sup>\<smile> ; x"

text \<open>We distinguish between partial and total bijections. As usual we call
the latter just bijections.\<close>

definition is_p_bij :: "'a \<Rightarrow> bool"
  where "is_p_bij x \<equiv> is_p_fun x \<and> is_inj x \<and> is_sur x"

definition is_bij :: "'a \<Rightarrow> bool"
  where "is_bij x \<equiv> is_map x \<and> is_inj x \<and> is_sur x"

text \<open>Our first set of lemmas relates the various concepts.\<close>

lemma inj_p_fun: "is_inj x \<longleftrightarrow> is_p_fun (x\<^sup>\<smile>)"
by (metis conv_invol is_inj_def is_p_fun_def)

lemma p_fun_inj: "is_p_fun x \<longleftrightarrow> is_inj (x\<^sup>\<smile>)"
by (metis conv_invol inj_p_fun)

lemma sur_total: "is_sur x \<longleftrightarrow> is_total (x\<^sup>\<smile>)"
by (metis conv_invol is_sur_def is_total_def)

lemma total_sur: "is_total x \<longleftrightarrow> is_sur (x\<^sup>\<smile>)"
by (metis conv_invol sur_total)

lemma bij_conv: "is_bij x  \<longleftrightarrow> is_bij (x\<^sup>\<smile>)"
by (metis is_bij_def inj_p_fun is_map_def p_fun_inj sur_total total_sur)

text \<open>Next we show that tests are partial injections.\<close>

lemma test_is_inj_fun: "is_test x \<Longrightarrow> (is_p_fun x \<and> is_inj x)"
by (metis is_inj_def p_fun_inj test_comp test_eq_conv is_test_def)

text \<open>Next we show composition properties.\<close>

lemma p_fun_comp:
  assumes "is_p_fun x" and "is_p_fun y"
  shows "is_p_fun (x ; y)"
proof (unfold is_p_fun_def)
  have "(x ; y)\<^sup>\<smile> ; x ; y = y\<^sup>\<smile> ; x\<^sup>\<smile> ; x ; y"
    by (metis conv_contrav mult.assoc)
  also have "... \<le> y\<^sup>\<smile> ; y"
    by (metis assms(1) is_p_fun_def mult_double_iso mult.right_neutral mult.assoc)
  finally show "(x ; y)\<^sup>\<smile> ; (x ; y) \<le> 1'"
    by (metis assms(2) order_trans is_p_fun_def mult.assoc)
qed

lemma p_fun_mult_var: "x\<^sup>\<smile> ; x \<le> 1' \<Longrightarrow> (x \<cdot> y)\<^sup>\<smile> ; (x \<cdot> y) \<le> 1'"
by (metis conv_times inf_le1 mult_isol_var order_trans)

lemma inj_compose:
  assumes "is_inj x" and "is_inj y"
  shows "is_inj (x ; y)"
by (metis assms conv_contrav inj_p_fun p_fun_comp)

lemma inj_mult_var: "x\<^sup>\<smile> ; x \<le> 1' \<Longrightarrow> (x \<cdot> y)\<^sup>\<smile> ; (x \<cdot> y) \<le> 1'"
by (metis p_fun_mult_var)

lemma total_comp:
  assumes "is_total x" and "is_total y"
  shows "is_total (x ; y)"
by (metis assms inf_top_left le_iff_inf mult.assoc mult.right_neutral one_conv ra_2 is_total_def)

lemma total_add_var: "1' \<le> x\<^sup>\<smile> ; x  \<Longrightarrow> 1' \<le> (x + y)\<^sup>\<smile> ; (x + y)"
by (metis local.conv_add local.inf.absorb2 local.inf.coboundedI1 local.join_interchange local.le_sup_iff)

lemma sur_comp:
  assumes "is_sur x" and "is_sur y"
  shows "is_sur (x ; y)"
by (metis assms conv_contrav sur_total total_comp)

lemma sur_sum_var: "1' \<le> x\<^sup>\<smile> ; x \<Longrightarrow> 1' \<le> (x + y)\<^sup>\<smile> ; (x + y)"
by (metis total_add_var)

lemma map_comp:
  assumes "is_map x" and "is_map y"
  shows "is_map (x ; y)"
by (metis assms is_map_def p_fun_comp total_comp)

lemma bij_comp:
  assumes "is_bij x" and "is_bij y"
  shows "is_bij (x ; y)"
by (metis assms is_bij_def inj_compose map_comp sur_comp)

text \<open>We now show that (partial) functions, unlike relations, distribute over
meets from the left.\<close>

lemma p_fun_distl: "is_p_fun x \<Longrightarrow> x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
proof -
  assume "is_p_fun x"
  hence "x ; (z \<cdot> ((x\<^sup>\<smile> ; x) ; y)) \<le> x ; (z \<cdot> y)"
    by (metis is_p_fun_def inf_le1 le_infI le_infI2 mult_isol mult_isor mult_onel)
  hence  "x ; y \<cdot> x ; z \<le> x ; (z \<cdot> y)"
    by (metis inf.commute mult.assoc order_trans modular_1_var)
  thus "x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
    by (metis eq_iff inf.commute le_infI mult_subdistl)
qed

lemma map_distl: "is_map x \<Longrightarrow> x ; (y \<cdot> z) = x ; y \<cdot> x ; z"
by (metis is_map_def p_fun_distl)

text \<open>Next we prove simple properties of functions which arise in equivalent
definitions of those concepts.\<close>

lemma p_fun_zero: "is_p_fun x \<Longrightarrow> x ; y \<cdot> x ; -y = 0"
by (metis annir inf_compl_bot p_fun_distl)

lemma total_one: "is_total x \<Longrightarrow> x ; 1 = 1"
by (metis conv_invol conv_one inf_top_left le_iff_inf mult.right_neutral one_conv ra_2 is_total_def)

lemma total_1: "is_total x \<Longrightarrow> (\<forall>y. y ; x = 0 \<longrightarrow> y = 0)"
by (metis conv_invol conv_zero inf_bot_left inf_top_left peirce total_one)

lemma surj_one: "is_sur x \<Longrightarrow> 1 ; x = 1"
by (metis conv_contrav conv_invol conv_one sur_total total_one)

lemma surj_1: "is_sur x \<Longrightarrow> (\<forall>y. x ; y = 0 \<longrightarrow> y = 0)"
by (metis comp_res_aux compl_bot_eq conv_contrav conv_one inf.commute inf_top_right surj_one)

lemma bij_is_maprop:
  assumes "is_bij x" and "is_map x"
  shows "x\<^sup>\<smile> ; x  = 1' \<and> x ; x\<^sup>\<smile> = 1'"
by (metis assms is_bij_def eq_iff is_inj_def is_map_def is_p_fun_def is_sur_def is_total_def)

text\<open>We now provide alternative definitions for functions. These can be found
in Schmidt and Str\"ohlein's book.\<close>

lemma p_fun_def_var: "is_p_fun x \<longleftrightarrow> x ; -(1') \<le> -x"
by (metis conv_galois_1 double_compl galois_aux inf.commute is_p_fun_def)

lemma total_def_var_1: "is_total x \<longleftrightarrow> x ; 1 = 1"
by (metis inf_top_right le_iff_inf one_conv total_one is_total_def)

lemma total_def_var_2: "is_total x \<longleftrightarrow> -x \<le> x ; -(1')"
by (metis total_def_var_1 distrib_left sup_compl_top mult.right_neutral galois_aux3)

lemma sur_def_var1: "is_sur x \<longleftrightarrow> 1 ; x = 1"
by (metis conv_contrav conv_one sur_total surj_one total_def_var_1)

lemma sur_def_var2: "is_sur x \<longleftrightarrow> -x \<le> -(1') ; x"
by (metis sur_total total_def_var_2 conv_compl conv_contrav conv_e conv_iso)

lemma inj_def_var1: "is_inj x \<longleftrightarrow> -(1') ; x \<le> -x"
by (metis conv_galois_2 double_compl galois_aux inf.commute is_inj_def)

lemma is_maprop: "is_map x \<longleftrightarrow> x ; -(1') = -x"
by (metis eq_iff is_map_def p_fun_def_var total_def_var_2)

text \<open>Finally we prove miscellaneous properties of functions.\<close>

lemma ss_422iii: "is_p_fun y \<Longrightarrow> (x \<cdot> z ; y\<^sup>\<smile>) ; y = x ; y \<cdot> z"
(* by (smt antisym comp_assoc inf_commute maddux_17 meet_iso mult_isol mult_oner mult_subdistr_var order_trans is_p_fun_def) *)
proof (rule antisym)
  assume "is_p_fun y"
  show "x ; y \<cdot> z \<le> (x \<cdot> z ; y\<^sup>\<smile>) ; y"
    by (metis maddux_17)
  have "(x \<cdot> z ; y\<^sup>\<smile>) ; y \<le> x ; y \<cdot> (z ; (y\<^sup>\<smile> ; y))"
    by (metis mult_subdistr_var mult.assoc)
  also have "\<dots> \<le> x ; y \<cdot> z ; 1'"
    by (metis \<open>is_p_fun y\<close> inf_absorb2 inf_le1 le_infI le_infI2 mult_subdistl is_p_fun_def)
  finally show "(x \<cdot> z ; y\<^sup>\<smile>) ; y \<le> x ; y \<cdot> z"
    by (metis mult.right_neutral)
qed

lemma p_fun_compl: "is_p_fun x \<Longrightarrow> x ; -y \<le> -(x; y)"
by (metis annir galois_aux inf.commute inf_compl_bot p_fun_distl)

lemma ss_422v: "is_p_fun x \<Longrightarrow> x ; -y = x ; 1 \<cdot> -(x ; y)"
by (metis inf.commute inf_absorb2 inf_top_left maddux_23 p_fun_compl)

text \<open>The next property is a Galois connection.\<close>

lemma ss43iii: "is_map x \<longleftrightarrow> (\<forall>y. x ; -y = -(x ; y))"
by standard (metis inf_top_left is_map_def ss_422v total_one, metis is_maprop mult.right_neutral)

text \<open>Next we prove a lemma from Schmidt and Str\"ohlein's book and some of
its consequences. We show the proof in detail since the textbook proof uses
Tarski's rule which we omit.\<close>

lemma ss423: "is_map x \<Longrightarrow> y ; x \<le> z \<longleftrightarrow> y \<le> z ; x\<^sup>\<smile>"
proof
  assume "is_map x" and "y ; x \<le> z"
  hence "y \<le> y ; x ; x\<^sup>\<smile>"
    by (metis is_map_def mult_1_right mult.assoc mult_isol is_total_def)
  thus "y \<le> z ; x\<^sup>\<smile>"
    by (metis \<open>y ; x \<le> z\<close> mult_isor order_trans)
next
  assume "is_map x" and "y \<le> z ; x\<^sup>\<smile>"
  hence "y ; x \<le> z ; x\<^sup>\<smile> ; x"
    by (metis mult_isor)
  also have "\<dots> \<le> z ; 1'"
    by (metis \<open>is_map x\<close> is_map_def mult.assoc mult_isol is_p_fun_def)
  finally show "y ; x \<le> z"
    by (metis mult_1_right)
qed

lemma ss424i: "is_total x \<longleftrightarrow> (\<forall>y. -(x ; y) \<le> x ; -y)"
by (metis galois_aux3 distrib_left sup_compl_top total_def_var_1)

lemma ss434ii: "is_p_fun x \<longleftrightarrow> (\<forall>y. x ; -y \<le> -(x ; y))"
by (metis mult.right_neutral p_fun_compl p_fun_def_var)

lemma is_maprop1: "is_map x \<Longrightarrow> (y \<le> x ; z ; x\<^sup>\<smile> \<longleftrightarrow> y ; x \<le> x ; z)"
by (metis ss423)

lemma is_maprop2: "is_map x \<Longrightarrow> (y ; x \<le> x ; z \<longleftrightarrow> x\<^sup>\<smile> ; y; x \<le> z)"
by standard (metis galois_aux2 inf_commute mult.assoc schroeder_1 ss43iii, metis conv_contrav conv_invol conv_iso mult.assoc ss423)

lemma is_maprop3: "is_map x \<Longrightarrow> (x\<^sup>\<smile> ; y; x \<le> z \<longleftrightarrow> x\<^sup>\<smile> ; y \<le> z ; x\<^sup>\<smile>)"
by (metis ss423)

lemma p_fun_sur_id [simp]:
  assumes "is_p_fun x" and "is_sur x"
  shows "x\<^sup>\<smile> ; x = 1'"
by (metis assms eq_iff is_p_fun_def is_sur_def)

lemma total_inj_id [simp]:
  assumes "is_total x" and "is_inj x"
  shows "x ; x\<^sup>\<smile> = 1'"
by (metis assms conv_invol inj_p_fun p_fun_sur_id sur_total)

lemma bij_inv_1 [simp]: "is_bij x \<Longrightarrow> x ; x\<^sup>\<smile> = 1'"
by (metis bij_is_maprop is_bij_def)

lemma bij_inv_2 [simp]: "is_bij x \<Longrightarrow> x\<^sup>\<smile> ; x = 1'"
by (metis bij_is_maprop is_bij_def)

lemma bij_inv_comm: "is_bij x \<Longrightarrow> x ; x\<^sup>\<smile> = x\<^sup>\<smile> ; x"
by (metis bij_inv_1 bij_inv_2)

lemma is_bijrop: "is_bij x \<Longrightarrow> (y = x ; z \<longleftrightarrow> z = x\<^sup>\<smile> ; y)"
by (metis bij_inv_1 bij_inv_2 mult.assoc mult.left_neutral)

lemma inj_map_monomorph: "\<lbrakk>is_inj x; is_map x\<rbrakk> \<Longrightarrow> (\<forall>y z. y ; x = z ; x \<longrightarrow> y = z)"
by (metis is_map_def mult.assoc mult.right_neutral total_inj_id)

lemma sur_map_epimorph: "\<lbrakk>is_sur x; is_map x\<rbrakk> \<Longrightarrow> (\<forall>y z. x ; y = x ; z \<longrightarrow> y = z)"
by (metis eq_iff mult.assoc mult.left_neutral ss423 is_sur_def)

subsection \<open>Points and Rectangles\<close>

text \<open>Finally here is a section on points and rectangles. This is only a
beginning.\<close>

definition is_point :: "'a \<Rightarrow> bool"
  where "is_point x \<equiv> is_vector x \<and> is_inj x \<and> x \<noteq> 0"

definition is_rectangle :: "'a \<Rightarrow> bool"
  where "is_rectangle x \<equiv> x ; 1 ; x \<le> x"

lemma rectangle_eq [simp]: "is_rectangle x \<longleftrightarrow> x ; 1 ; x = x"
by (metis conv_one dedekind eq_iff inf_top_left mult.assoc one_idem_mult is_rectangle_def)

subsection \<open>Antidomain\<close>

text\<open>This section needs to be linked with domain semirings. We essentially
prove the antidomain semiring axioms. Then we have the abstract properties at
our disposition.\<close>

definition antidom :: "'a \<Rightarrow> 'a" ("a")
  where "a x = 1' \<cdot> (-(x ; 1))"

definition dom :: "'a \<Rightarrow> 'a" ("d")
  where "d x = a (a x)"

lemma antidom_test_comp [simp]: "a x = tc (x ; 1)"
by (metis antidom_def tc_def)

lemma dom_def_aux: "d x = 1' \<cdot> x ; 1"
by (metis antidom_test_comp dom_def double_compl inf_top_left mult.left_neutral one_compl ra_1 tc_def)

lemma dom_def_aux_var: "d x = 1' \<cdot> x ; x\<^sup>\<smile>"
by (metis dom_def_aux one_conv)

lemma antidom_dom [simp]: "a (d x) = a x"
by (metis antidom_test_comp dom_def_aux inf_top_left mult.left_neutral ra_1)

lemma dom_antidom [simp]: "d (a x) = a x"
by (metis antidom_dom dom_def)

lemma dom_verystrict: "d x = 0 \<longleftrightarrow> x = 0"
using dom_def_aux_var local.schroeder_2 by force

lemma a_1 [simp]: "a x ; x = 0"
by (metis antidom_test_comp galois_aux2 maddux_20 mult.left_neutral one_compl ra_1 tc_def)

lemma a_2: "a (x ; y) = a (x ; d y)"
by (metis antidom_test_comp dom_def_aux inf_top_left mult.assoc mult.left_neutral ra_1)

lemma a_3 [simp]: "a x + d x = 1'"
by (metis antidom_def aux4 dom_def_aux double_compl)

lemma test_domain: "x = d x \<longleftrightarrow> x \<le> 1'"
apply standard
 apply (metis dom_def_aux inf_le1)
apply (metis dom_def_aux inf.commute mult.right_neutral test_1 is_test_def)
done

text \<open>At this point we have all the necessary ingredients to prove that
relation algebras form Boolean domain semirings. However, we omit a formal
proof since we haven't formalized the latter.\<close>

lemma dom_one: "x ; 1 = d x ; 1"
by (metis dom_def_aux inf_top_left mult.left_neutral ra_1)

lemma test_dom: "is_test (d x)"
by (metis dom_def_aux inf_le1 is_test_def)

lemma p_fun_dom: "is_p_fun (d x)"
by (metis test_dom test_is_inj_fun)

lemma inj_dom: "is_inj (d x)"
by (metis test_dom test_is_inj_fun)

lemma total_alt_def: "is_total x \<longleftrightarrow> (d x) = 1'"
by (metis dom_def_aux_var le_iff_inf is_total_def)

end (* relation_algebra *)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BubSortSorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun bubble :: "Nat list => (bool, (Nat list)) pair" where
  "bubble (nil2) = pair2 False (nil2)"
| "bubble (cons2 y (nil2)) = pair2 False (cons2 y (nil2))"
| "bubble (cons2 y (cons2 y2 xs)) =
     (if le y y2 then
        (case bubble (cons2 y2 xs) of
           pair2 b22 ys22 => pair2 b22 (cons2 y ys22))
        else
        (case bubble (cons2 y xs) of
           pair2 b2 ys2 => pair2 True (cons2 y2 ys2)))"

(*fun did not finish the proof*)
function bubsort :: "Nat list => Nat list" where
  "bubsort x =
   (case bubble x of pair2 b1 ys => (if b1 then bubsort ys else x))"
  by pat_completeness auto

theorem property0 :
  "ordered (bubsort xs)"
  oops

end


chapter \<open>Case Study: Single and Multi-Mutator Garbage Collection Algorithms\<close>

section \<open>Formalization of the Memory\<close>

theory Graph imports Main begin

datatype node = Black | White

type_synonym nodes = "node list"
type_synonym edge = "nat \<times> nat"
type_synonym edges = "edge list"

consts Roots :: "nat set"

definition Proper_Roots :: "nodes \<Rightarrow> bool" where
  "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"

definition Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool" where
  "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"

definition BtoW :: "(edge \<times> nodes) \<Rightarrow> bool" where
  "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"

definition Blacks :: "nodes \<Rightarrow> nat set" where
  "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"

definition Reach :: "edges \<Rightarrow> nat set" where
  "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
              \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
              \<or> x\<in>Roots}"

text\<open>Reach: the set of reachable nodes is the set of Roots together with the
nodes reachable from some Root by a path represented by a list of
  nodes (at least two since we traverse at least one edge), where two
consecutive nodes correspond to an edge in E.\<close>

subsection \<open>Proofs about Graphs\<close>

lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
declare Graph_defs [simp]

subsubsection\<open>Graph 1\<close>

lemma Graph1_aux [rule_format]:
  "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
  \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
  (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
  \<longrightarrow> M!(path!0) = Black"
apply(induct_tac "path")
 apply force
apply clarify
apply simp
apply(case_tac "list")
 apply force
apply simp
apply(rename_tac lista)
apply(rotate_tac -2)
apply(erule_tac x = "0" in all_dupE)
apply simp
apply clarify
apply(erule allE , erule (1) notE impE)
apply simp
apply(erule mp)
apply(case_tac "lista")
 apply force
apply simp
apply(erule mp)
apply clarify
apply(erule_tac x = "Suc i" in allE)
apply force
done

lemma Graph1:
  "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
  \<Longrightarrow> Reach E\<subseteq>Blacks M"
apply (unfold Reach_def)
apply simp
apply clarify
apply(erule disjE)
 apply clarify
 apply(rule conjI)
  apply(subgoal_tac "0< length path - Suc 0")
   apply(erule allE , erule (1) notE impE)
   apply force
  apply simp
 apply(rule Graph1_aux)
apply auto
done

subsubsection\<open>Graph 2\<close>

lemma Ex_first_occurrence [rule_format]:
  "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))"
apply(rule nat_less_induct)
apply clarify
apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
apply auto
done

lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
apply(rule_tac x = "l - n" in exI)
apply arith
done

lemma Ex_last_occurrence:
  "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
apply(drule Compl_lemma)
apply clarify
apply(erule Ex_first_occurrence)
done

lemma Graph2:
  "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
 apply(rule_tac x = "path" in exI)
 apply simp
 apply clarify
 apply(erule allE , erule (1) notE impE)
 apply clarify
 apply(rule_tac x = "j" in exI)
 apply(case_tac "j=R")
  apply(erule_tac x = "Suc i" in allE)
  apply simp
 apply (force simp add:nth_list_update)
apply simp
apply(erule exE)
apply(subgoal_tac "z \<le> length path - Suc 0")
 prefer 2 apply arith
apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
 apply assumption
apply clarify
apply simp
apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
apply simp
apply(case_tac "length path - (length path - Suc m)")
 apply arith
apply simp
apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
 prefer 2 apply arith
apply clarify
apply(case_tac "i")
 apply(force simp add: nth_list_update)
apply simp
apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
 prefer 2 apply arith
apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
 prefer 2 apply arith
apply simp
apply(erule_tac x = "length path - Suc m + nata" in allE)
apply simp
apply clarify
apply(rule_tac x = "j" in exI)
apply(case_tac "R=j")
 prefer 2 apply force
apply simp
apply(drule_tac t = "path ! (length path - Suc m)" in sym)
apply simp
apply(case_tac " length path - Suc 0 < m")
 apply(subgoal_tac "(length path - Suc m)=0")
  prefer 2 apply arith
 apply(simp del: diff_is_0_eq)
 apply(subgoal_tac "Suc nata\<le>nat")
 prefer 2 apply arith
 apply(drule_tac n = "Suc nata" in Compl_lemma)
 apply clarify
 subgoal using [[linarith_split_limit = 0]] by force
apply(drule leI)
apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
 apply(erule_tac x = "m - (Suc nata)" in allE)
 apply(case_tac "m")
  apply simp
 apply simp
apply simp
done

subsubsection\<open>Graph 3\<close>

declare min.absorb1 [simp] min.absorb2 [simp]

lemma Graph3:
  "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
apply (unfold Reach_def)
apply clarify
apply simp
apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
\<comment> \<open>the changed edge is part of the path\<close>
 apply(erule exE)
 apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
 apply clarify
 apply(erule disjE)
\<comment> \<open>T is NOT a root\<close>
  apply clarify
  apply(rule_tac x = "(take m path)@patha" in exI)
  apply(subgoal_tac "\<not>(length path\<le>m)")
   prefer 2 apply arith
  apply(simp)
  apply(rule conjI)
   apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
    prefer 2 apply arith
   apply(simp add: nth_append)
  apply(rule conjI)
   apply(case_tac "m")
    apply force
   apply(case_tac "path")
    apply force
   apply force
  apply clarify
  apply(case_tac "Suc i\<le>m")
   apply(erule_tac x = "i" in allE)
   apply simp
   apply clarify
   apply(rule_tac x = "j" in exI)
   apply(case_tac "Suc i<m")
    apply(simp add: nth_append)
    apply(case_tac "R=j")
     apply(simp add: nth_list_update)
     apply(case_tac "i=m")
      apply force
     apply(erule_tac x = "i" in allE)
     apply force
    apply(force simp add: nth_list_update)
   apply(simp add: nth_append)
   apply(subgoal_tac "i=m - 1")
    prefer 2 apply arith
   apply(case_tac "R=j")
    apply(erule_tac x = "m - 1" in allE)
    apply(simp add: nth_list_update)
   apply(force simp add: nth_list_update)
  apply(simp add: nth_append)
  apply(rotate_tac -4)
  apply(erule_tac x = "i - m" in allE)
  apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
    prefer 2 apply arith
   apply simp
\<comment> \<open>T is a root\<close>
 apply(case_tac "m=0")
  apply force
 apply(rule_tac x = "take (Suc m) path" in exI)
 apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
  prefer 2 apply arith
 apply clarsimp
 apply(erule_tac x = "i" in allE)
 apply simp
 apply clarify
 apply(case_tac "R=j")
  apply(force simp add: nth_list_update)
 apply(force simp add: nth_list_update)
\<comment> \<open>the changed edge is not part of the path\<close>
apply(rule_tac x = "path" in exI)
apply simp
apply clarify
apply(erule_tac x = "i" in allE)
apply clarify
apply(case_tac "R=j")
 apply(erule_tac x = "i" in allE)
 apply simp
apply(force simp add: nth_list_update)
done

subsubsection\<open>Graph 4\<close>

lemma Graph4:
  "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
  \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
  (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
\<comment> \<open>there exist a black node in the path to T\<close>
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply(case_tac "j<I")
  apply(erule_tac x = "j" in allE)
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

declare min.absorb1 [simp del] min.absorb2 [simp del]

subsubsection \<open>Graph 5\<close>

lemma Graph5:
  "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
    R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
   \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
apply (unfold Reach_def)
apply simp
apply(erule disjE)
 prefer 2 apply force
apply clarify
\<comment> \<open>there exist a black node in the path to T\<close>
apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
 apply(erule exE)
 apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
 apply clarify
 apply(case_tac "ma")
  apply force
 apply simp
 apply(case_tac "length path")
  apply force
 apply simp
 apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply clarify
 apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> P i" and x = "nat" for P in allE)
 apply simp
 apply(case_tac "j\<le>R")
  apply(drule le_imp_less_or_eq [of _ R])
  apply(erule disjE)
   apply(erule allE , erule (1) notE impE)
   apply force
  apply force
 apply(rule_tac x = "j" in exI)
 apply(force  simp add: nth_list_update)
apply simp
apply(rotate_tac -1)
apply(erule_tac x = "length path - 1" in allE)
apply(case_tac "length path")
 apply force
apply force
done

subsubsection \<open>Other lemmas about graphs\<close>

lemma Graph6:
 "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
apply (unfold Proper_Edges_def)
 apply(force  simp add: nth_list_update)
done

lemma Graph7:
 "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
apply (unfold Proper_Edges_def)
apply force
done

lemma Graph8:
 "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
apply (unfold Proper_Roots_def)
apply force
done

text\<open>Some specific lemmata for the verification of garbage collection algorithms.\<close>

lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
 apply(force simp add: nth_list_update)
done

lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
apply(induct_tac "M")
apply auto
apply(case_tac "i")
apply auto
done

lemma Graph11 [rule_format (no_asm)]:
  "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(rule psubsetI)
 apply(force simp add: nth_list_update)
apply safe
apply(erule_tac c = "j" in equalityCE)
apply auto
done

lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(force simp add: nth_list_update)
done

lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
apply (unfold Blacks_def)
apply(erule psubset_subset_trans)
apply(force simp add: nth_list_update)
done

declare Graph_defs [simp del]

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_bin_plus
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun toNat :: "Bin => int" where
"toNat (One) = 1"
| "toNat (ZeroAnd xs) = (toNat xs) + (toNat xs)"
| "toNat (OneAnd ys) = (1 + (toNat ys)) + (toNat ys)"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

theorem property0 :
  "((toNat (plus x y)) = ((toNat x) + (toNat y)))"
  oops

end


theory BoolosATP2 imports Main
begin

typedecl i
consts
 e :: "i"  (* one *)
 s :: "i\<Rightarrow>i"  (* successor function *)
 F :: "i\<Rightarrow>i\<Rightarrow>i"  (* binary function; axiomatised below as Ackermann function *)
 D :: "i\<Rightarrow>bool"  (* arbitrary uninterpreted unary predicate *)

axiomatization where
    A1: "\<forall>n. F n e = s e"  (* Axiom for Ackermann function F *)
and A2: "\<forall>y. F e (s y) = s (s (F e y))"  (* Axiom for Ackermann function F *)
and A3: "\<forall>x y. F (s x) (s y) = F x (F (s x) y)"  (* Axiom for Ackermann function F *)
and A4: "D e"  (* D holds for one *)
and A5: "\<forall>x. D x \<longrightarrow> D (s x)" (* if D holds for x it also holds for the successor of x *)

lemma "D (F (s (s (s (s e)))) (s (s (s (s e)))))" sledgehammer oops (* no proof; hopeless! *)

definition isIndSet where (* X is inductive (over e and s) *)
  "isIndSet \<equiv> \<lambda>X. (X e) \<and> (\<forall>x. X x \<longrightarrow> X (s x))"
definition P where (* P(x,y) iff F(x,y) is in smallest inductive set (over e and s) *)
  "P \<equiv> \<lambda>x y. (\<lambda>z. (\<forall>X::i\<Rightarrow>bool. isIndSet X \<longrightarrow> X z)) (F x y)"

lemma "D (F (s (s (s (s e)))) (s (s (s (s e)))))"  (* ATPs can now proof this: using the Defs *)
  sledgehammer  (* proof found *)
  by (metis A1 A2 A3 A4 A5 P_def isIndSet_def)     (* proof reconstruction succeeds *)
end