(*  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>
*)

section \<open>Interactive Convergence Algorithms (ICA)\<close>

theory ICAInstance imports Complex_Main begin

text \<open>This algorithm is presented in \cite{lamport_cs}.\<close>

text \<open>A proof of the three properties can be found in
\cite{shankar92mechanical}.\<close>

subsection \<open>Model of the system\<close>

text \<open>The main ideas for the formalization of the system were
obtained from \cite{shankar92mechanical}.\<close>

subsubsection \<open>Types in the formalization\<close>

text \<open>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.\<close>

type_synonym process = nat
type_synonym time = real       \<comment> \<open>real time\<close>
type_synonym Clocktime = real  \<comment> \<open>time of the clock readings (clock time)\<close>

subsubsection \<open>Some constants\<close>

text\<open>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).\<close>

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

text \<open>We define also the set of process that the algorithm
manage. This definition exist only for readability matters.\<close>

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

subsubsection \<open>Convergence function\<close>

text \<open>This functions is called ``Egocentric Average''
(\cite{schneider87understanding})\<close>

text \<open>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}.\<close>

text \<open>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.\<close>

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 \<open>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}.\<close>

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 \<open>Translation Invariance property.\<close>

text \<open>We first need to prove this auxiliary lemma.\<close>

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 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 \<open>Precision Enhancement property\<close>

text \<open>An informal proof of this theorem can be found in
\cite{shankar92mechanical}\<close>

subsubsection \<open>Auxiliary lemmas\<close>

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 \<open>The next lemmas are about arithmetic properties of the
generalized summation over a set constructor.\<close>

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 sum_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> sum 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 "sum f (insert x F) <= b + real (card F) * b"
    by auto
  also
  have "... = real (Suc (card  F)) * b"
    by (simp add: distrib_right  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 sum.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 \<open>The next lemmas are about the existence of bounds that are
necesary in order to prove the Precicion Enhancement theorem.\<close>

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 \<open>Main theorem\<close>

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: sum_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 \<open>Accuracy Preservation property\<close>

text \<open>First, a simple lemma about an arithmetic propertie of the
generalized summation over a set constructor.\<close>

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: of_nat_Suc distrib_left lessThan_Suc)
qed

text \<open>Next, some lemmas about bounds that are used in the proof of Accuracy Preservation\<close>

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 \<open>Main theorem\<close>

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)"
      .
\<comment> \<open>cambia\<close>
    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


(*  Title:      HOL/Nitpick_Examples/Core_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's functional core.
*)

section \<open>Examples Featuring Nitpick's Functional Core\<close>

theory Core_Nits
imports MainRLT
begin

nitpick_params [verbose, card = 1-6, unary_ints, max_potential = 0,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

subsection \<open>Curry in a Hurry\<close>

lemma "(\<lambda>f x y. (curry o case_prod) f x y) = (\<lambda>f x y. (\<lambda>x. x) f x y)"
nitpick [card = 1-12, expect = none]
by auto

lemma "(\<lambda>f p. (case_prod o curry) f p) = (\<lambda>f p. (\<lambda>x. x) f p)"
nitpick [card = 1-12, expect = none]
by auto

lemma "case_prod (curry f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "curry (case_prod f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "case_prod (\<lambda>x y. f (x, y)) = f"
nitpick [card = 1-12, expect = none]
by auto

subsection \<open>Representations\<close>

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y = y"
nitpick [expect = none]
by auto

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [card 'a = 25, card 'b = 24, expect = genuine]
nitpick [card = 1-10, mono, expect = none]
oops

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y \<noteq> y"
nitpick [card = 1, expect = genuine]
oops

lemma "P (\<lambda>x. x)"
nitpick [card = 1, expect = genuine]
oops

lemma "{(a::'a\<times>'a, b::'b)}\<inverse> = {(b, a)}"
nitpick [card = 1-12, expect = none]
by auto

lemma "fst (a, b) = a"
nitpick [card = 1-20, expect = none]
by auto

lemma "\<exists>P. P = Id"
nitpick [card = 1-20, expect = none]
by auto

lemma "(a::'a\<Rightarrow>'b, a) \<in> Id\<^sup>*"
nitpick [card = 1-2, expect = none]
by auto

lemma "(a::'a\<times>'a, a) \<in> Id\<^sup>* \<union> {(a, b)}\<^sup>*"
nitpick [card = 1-4, expect = none]
by auto

lemma "(a, a) \<in> Id"
nitpick [card = 1-50, expect = none]
by (auto simp: Id_def)

lemma "((a::'a, b::'a), (a, b)) \<in> Id"
nitpick [card = 1-10, expect = none]
by (auto simp: Id_def)

lemma "(x::'a\<times>'a) \<in> UNIV"
nitpick [card = 1-50, expect = none]
sorry

lemma "{} = A - A"
nitpick [card = 1-100, expect = none]
by auto

lemma "g = Let (A \<or> B)"
nitpick [card = 1, expect = none]
nitpick [card = 12, expect = genuine]
oops

lemma "(let a_or_b = A \<or> B in a_or_b \<or> \<not> a_or_b)"
nitpick [expect = none]
by auto

lemma "A \<subseteq> B"
nitpick [card = 100, expect = genuine]
oops

lemma "A = {b}"
nitpick [card = 100, expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [card = 50, expect = genuine]
oops

lemma "(a::'a\<times>'a, a::'a\<times>'a) \<in> R"
nitpick [card = 1, expect = genuine]
nitpick [card = 10, expect = genuine]
nitpick [card = 5, dont_box, expect = genuine]
oops

lemma "f (g::'a\<Rightarrow>'a) = x"
nitpick [card = 3, dont_box, expect = genuine]
nitpick [card = 8, expect = genuine]
oops

lemma "f (a, b) = x"
nitpick [card = 10, expect = genuine]
oops

lemma "f (a, a) = f (c, d)"
nitpick [card = 10, expect = genuine]
oops

lemma "(x::'a) = (\<lambda>a. \<lambda>b. \<lambda>c. if c then a else b) x x True"
nitpick [card = 1-10, expect = none]
by auto

lemma "\<exists>F. F a b = G a b"
nitpick [card = 2, expect = none]
by auto

lemma "f = case_prod"
nitpick [card = 2, expect = genuine]
oops

lemma "(A::'a\<times>'a, B::'a\<times>'a) \<in> R \<Longrightarrow> (A, B) \<in> R"
nitpick [card = 15, expect = none]
by auto

lemma "(A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R) \<Longrightarrow>
       A = B \<or> (A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R)"
nitpick [card = 1-25, expect = none]
by auto

lemma "f = (\<lambda>x::'a\<times>'b. x)"
nitpick [card = 8, expect = genuine]
oops

subsection \<open>Quantifiers\<close>

lemma "x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x. x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x::'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1, expect = genuine]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<exists>x::'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1-15, expect = none]
by auto

lemma "\<exists>x y::'a \<Rightarrow> bool. x = y"
nitpick [card = 1-15, expect = none]
by auto

lemma "\<forall>x. \<exists>y. f x y = f x (g x)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u w) w (h u)"
nitpick [card = 3, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w y) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u w) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u::'a \<times> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<times> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u::'a \<times> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<times> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>u::'a \<Rightarrow> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<Rightarrow> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, dont_box, expect = none]
sorry

lemma "\<forall>u::'a \<Rightarrow> 'b. \<exists>v::'c. \<forall>w::'d. \<exists>x::'e \<Rightarrow> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>x. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2-5, expect = none]
oops

lemma "\<forall>x::'a\<times>'b. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2, expect = none]
oops

lemma "\<forall>x. if (\<exists>y. x = y) then True else False"
nitpick [expect = none]
sorry

lemma "(\<exists>x::'a. \<forall>y. P x y) \<or> (\<exists>x::'a \<times> 'a. \<forall>y. P y x)"
nitpick [card 'a = 1, expect = genuine]
oops

lemma "\<exists>x. if x = y then (\<forall>y. y = x \<or> y \<noteq> x)
           else (\<forall>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "\<exists>x. if x = y then (\<exists>y. y = x \<or> y \<noteq> x)
           else (\<exists>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x::'a \<times> 'b. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

subsection \<open>Schematic Variables\<close>

schematic_goal "x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<forall>x. x = ?x"
nitpick [expect = genuine]
oops

schematic_goal "\<exists>x. x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<exists>x::'a \<Rightarrow> 'b. x = ?x"
nitpick [expect = none]
by auto

schematic_goal "\<forall>x. ?x = ?y"
nitpick [expect = none]
by auto

schematic_goal "\<exists>x. ?x = ?y"
nitpick [expect = none]
by auto

subsection \<open>Known Constants\<close>

lemma "x \<equiv> Pure.all \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
nitpick [card = 1, box "('a \<Rightarrow> prop) \<Rightarrow> prop", expect = genuine]
nitpick [card = 6, expect = genuine]
oops

lemma "\<And>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<And>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop True"
nitpick [expect = none]
by auto

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop False"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Pure.all P \<equiv> Pure.all (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x \<equiv> (\<equiv>) \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
oops

lemma "P x \<equiv> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x \<equiv> Q x \<Longrightarrow> P x = Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x = Q x \<Longrightarrow> P x \<equiv> Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "x \<equiv> (\<Longrightarrow>) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "I \<equiv> (\<lambda>x. x) \<Longrightarrow> ((\<Longrightarrow>) x) \<equiv> (\<lambda>y. ((\<Longrightarrow>) x (I y)))"
nitpick [expect = none]
by auto

lemma "P x \<Longrightarrow> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "True \<Longrightarrow> True" "False \<Longrightarrow> True" "False \<Longrightarrow> False"
nitpick [expect = none]
by auto

lemma "True \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "x = Not"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Not = (\<lambda>x. Not (I x))"
nitpick [expect = none]
by auto

lemma "x = True"
nitpick [expect = genuine]
oops

lemma "x = False"
nitpick [expect = genuine]
oops

lemma "x = undefined"
nitpick [expect = genuine]
oops

lemma "(False, ()) = undefined \<Longrightarrow> ((), False) = undefined"
nitpick [expect = genuine]
oops

lemma "undefined = undefined"
nitpick [expect = none]
by auto

lemma "f undefined = f undefined"
nitpick [expect = none]
by auto

lemma "f undefined = g undefined"
nitpick [card = 33, expect = genuine]
oops

lemma "\<exists>!x. x = undefined"
nitpick [card = 15, expect = none]
by auto

lemma "x = All \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<forall>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<forall>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "All (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "All (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "x = Ex \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<exists>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<exists>x. f x y = f y x"
nitpick [expect = none]
oops

lemma "Ex (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f y x) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "Ex (\<lambda>x. f x y \<noteq> f x y) = False"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Ex P = Ex (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> y = x"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> f x = f y"
nitpick [expect = none]
by auto

lemma "x = y \<and> y = z \<Longrightarrow> x = z"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<and>) = (\<lambda>x. (\<and>) (I x))"
      "I = (\<lambda>x. x) \<Longrightarrow> (\<and>) = (\<lambda>x y. x \<and> (I y))"
nitpick [expect = none]
by auto

lemma "(a \<and> b) = (\<not> (\<not> a \<or> \<not> b))"
nitpick [expect = none]
by auto

lemma "a \<and> b \<Longrightarrow> a" "a \<and> b \<Longrightarrow> b"
nitpick [expect = none]
by auto

lemma "(\<longrightarrow>) = (\<lambda>x. (\<longrightarrow>) x)" "((\<longrightarrow>) ) = (\<lambda>x y. x \<longrightarrow> y)"
nitpick [expect = none]
by auto

lemma "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
nitpick [expect = none]
by auto

lemma "(if a then b else c) = (THE d. (a \<longrightarrow> (d = b)) \<and> (\<not> a \<longrightarrow> (d = c)))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x::'a\<Rightarrow>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x::'a\<Rightarrow>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y::'a\<Rightarrow>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y::'a\<Rightarrow>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x::'a\<times>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x::'a\<times>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y::'a\<times>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y::'a\<times>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "I = (\<lambda>x. x) \<Longrightarrow> fst = (\<lambda>x. fst (I x))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = snd (y, x)"
nitpick [expect = none]
by auto

lemma "(x, x) \<in> Id"
nitpick [expect = none]
by auto

lemma "(x, y) \<in> Id \<Longrightarrow> x = y"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Id = {x. I x \<in> Id}"
nitpick [expect = none]
by auto

lemma "{} = {x. False}"
nitpick [expect = none]
by (metis empty_def)

lemma "x \<in> {}"
nitpick [expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [expect = genuine]
oops

lemma "{a, b} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a} = {b}"
nitpick [expect = genuine]
oops

lemma "{a} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a, b, c} = {c, b, a}"
nitpick [expect = none]
by auto

lemma "UNIV = {x. True}"
nitpick [expect = none]
by (simp only: UNIV_def)

lemma "x \<in> UNIV \<longleftrightarrow> True"
nitpick [expect = none]
by (simp only: UNIV_def mem_Collect_eq)

lemma "x \<notin> UNIV"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<in>) = (\<lambda>x. ((\<in>) (I x)))"
nitpick [expect = none]
apply (rule ext)
apply (rule ext)
by simp

lemma "insert = (\<lambda>x y. insert x (y \<union> y))"
nitpick [expect = none]
by simp

lemma "I = (\<lambda>x. x) \<Longrightarrow> trancl = (\<lambda>x. trancl (I x))"
nitpick [card = 1-2, expect = none]
by auto

lemma "rtrancl = (\<lambda>x. rtrancl x \<union> {(y, y)})"
nitpick [card = 1-3, expect = none]
apply (rule ext)
by auto

lemma "(x, x) \<in> rtrancl {(y, y)}"
nitpick [expect = none]
by auto

lemma "((x, x), (x, x)) \<in> rtrancl {}"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<union>) = (\<lambda>x. (\<union>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<in> A \<Longrightarrow> a \<in> (A \<union> B)" "b \<in> B \<Longrightarrow> b \<in> (A \<union> B)"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<inter>) = (\<lambda>x. (\<inter>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<notin> A \<Longrightarrow> a \<notin> (A \<inter> B)" "b \<notin> B \<Longrightarrow> b \<notin> (A \<inter> B)"
nitpick [card = 1-5, expect = none]
by auto

lemma "x \<in> ((A::'a set) - B) \<longleftrightarrow> x \<in> A \<and> x \<notin> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (\<subset>) = (\<lambda>x. (\<subset>) (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subset> B \<Longrightarrow> (\<forall>a \<in> A. a \<in> B) \<and> (\<exists>b \<in> B. b \<notin> A)"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> \<forall>a \<in> A. a \<in> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> A \<subset> B"
nitpick [card = 5, expect = genuine]
oops

lemma "A \<subset> B \<Longrightarrow> A \<subseteq> B"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x::'a set. x) \<Longrightarrow> uminus = (\<lambda>x. uminus (I x))"
nitpick [card = 1-7, expect = none]
by auto

lemma "A \<union> - A = UNIV"
nitpick [expect = none]
by auto

lemma "A \<inter> - A = {}"
nitpick [expect = none]
by auto

lemma "A = -(A::'a set)"
nitpick [card 'a = 10, expect = genuine]
oops

lemma "finite A"
nitpick [expect = none]
oops

lemma "finite A \<Longrightarrow> finite B"
nitpick [expect = none]
oops

lemma "All finite"
nitpick [expect = none]
oops

subsection \<open>The and Eps\<close>

lemma "x = The"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = The"
nitpick [card = 1-3]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> The P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = z"
nitpick [expect = genuine]
oops

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = x \<or> The P = y"
nitpick [card = 2, expect = none]
nitpick [card = 3-5, expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [card = 1-2, expect = none]
nitpick [card = 8, expect = genuine]
oops

lemma "(\<forall>x. \<not> P x) \<longrightarrow> The P = y"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> The = (\<lambda>x. The (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "x = Eps"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = Eps"
nitpick [card = 1-3, expect = none]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> Eps P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> Eps P = z"
nitpick [expect = genuine]
apply auto
oops

lemma "P x \<Longrightarrow> P (Eps P)"
nitpick [card = 1-8, expect = none]
by (metis exE_some)

lemma "\<forall>x. \<not> P x \<longrightarrow> Eps P = y"
nitpick [expect = genuine]
oops

lemma "P (Eps P)"
nitpick [expect = genuine]
oops

lemma "Eps (\<lambda>x. x \<in> P) \<in> (P::nat set)"
nitpick [expect = genuine]
oops

lemma "\<not> P (Eps P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P :: nat \<Rightarrow> bool) (Eps P)"
nitpick [expect = genuine]
oops

lemma "P \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "(P :: nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "P (The P)"
nitpick [expect = genuine]
oops

lemma "(P :: nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> P (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P :: nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> (x::nat)"
nitpick [expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P (x::nat) \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P = {x} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

lemma "P = {x::nat} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

consts Q :: 'a

lemma "Q (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none] (* unfortunate *)
oops

lemma "\<not> (Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q :: nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q::'a \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q::'a \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "(Q::nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q::nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "Q (The Q)"
nitpick [expect = genuine]
oops

lemma "(Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> (x::nat)"
nitpick [expect = genuine]
oops

lemma "Q x \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q (x::nat) \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q = (\<lambda>x::'a. x = a) \<Longrightarrow> (Q::'a \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

lemma "Q = (\<lambda>x::nat. x = a) \<Longrightarrow> (Q::nat \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

nitpick_params [max_potential = 1]

lemma "(THE j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = potential] (* unfortunate *)
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = none]
sorry

nitpick_params [max_potential = 0]

subsection \<open>Destructors and Recursors\<close>

lemma "(x::'a) = (case True of True \<Rightarrow> x | False \<Rightarrow> x)"
nitpick [card = 2, expect = none]
by auto

lemma "x = (case (x, y) of (x', y') \<Rightarrow> x')"
nitpick [expect = none]
sorry

end


theory ntuples
imports axioms_base
begin

text{* First we define ordered pairs, and then n-tuples, before we prove the fundamental property
       of the ordered pair. *}

definition ordered_pair :: "Set \<Rightarrow> Set \<Rightarrow> Set"
where "ordered_pair x y \<equiv> {{x}, {x,y}}"

text{* Here we formalise n-tuples, as a subtype of Set. *}

(* Taken from Product_Type.thy, lines 300-320*)
nonterminal ntuple_args
syntax
  "_ntuple"      :: "ntuple_args \<Rightarrow> Set \<Rightarrow> Set"        ("(1'\<langle>_,/ _'\<rangle>)")
  "_ntuple_arg"  :: "Set \<Rightarrow> ntuple_args"                   ("_")
  "_ntuple_args" :: "ntuple_args \<Rightarrow> Set \<Rightarrow> ntuple_args"     ("_,/ _")

translations
  "\<langle>x, y\<rangle>" \<rightleftharpoons> "CONST ordered_pair x y"
  "_ntuple (_ntuple_args y z) x" \<rightleftharpoons> "_ntuple (_ntuple_arg (_ntuple y z)) x"
(*  "_abs (\<langle>x,y\<rangle>) t" \<rightharpoonup> "\<lambda>(x, y). t"   *) (*not sure where it's useful*)

value "\<langle>x,y,z,r,h\<rangle>"

text{* The fundamental property of ordered pairs. *}

lemma Prop4_3: "\<forall> x y u v :: Set. (\<langle>x,y\<rangle> = \<langle>u,v\<rangle>) \<longrightarrow> ((x=u) \<and> (y=v))"

(* page 230 *)

proof (rule allI, rule allI, rule allI, rule allI, rule impI)
  fix x y u v :: Set
  assume "\<langle>x,y\<rangle> = \<langle>u,v\<rangle>"                                     -- "Assume (x,y) = (u,v)."
  then have 0: "{{x},{x,y}} = {{u},{u,v}}"                  -- "Then {{x},{x,y}} = {{u},{u,v}}."
    using ordered_pair_def by simp
  moreover have "{x} \<in> {{x}, {x,y}}" using pairing by auto  -- " Since {x} E {{x}, {x,y}},"
  ultimately have "{x} \<in> {{u}, {u, v}}"                     -- "{x} E {{u}, {u, v}}."
    by auto
  moreover hence "{x} = {u} \<or> {x} = {u,v}" using pairing
    by (simp add: Rep_Set_inject)                           -- "Hence, {x} = {u} or {x} = {u,v}."
  moreover hence "x=u" by (metis Rep_Set_inject pairing)    -- "In either case x=u."
  moreover have *: "{u,v} \<in> {{u},{u,v}}" using pairing by simp -- "Now, {u,v} E {{u},{u,v}};"
  moreover hence "{u,v} \<in> {{x},{x,y}}" using 0 by simp      -- "so, {u,v} E {{x},{x,y}}."
  moreover then have 2:"{u,v} = {x} \<or> {u, v} = {x,y}" by (simp add: Rep_Set_inject pairing)
                                                            -- "Then {u,v} = {x} or {u, v} = {x,y}."
  moreover have **: "{x,y} = {u} \<or> {x,y} = {u, v}" by (metis 0 Rep_Set_inverse pairing)
                                                            -- "Similarly, {x,y} = {u} or {x,y} = {u, v}."
  moreover hence "y=v"
(* Sledgehammer can find a proof from this poing already:
                           by (metis Rep_Set_inverse calculation(3) calculation(6) pairing)  *)
    proof (cases "{u,v} = {x} \<and> {x,y} = {u}")
      assume "{u,v} = {x} \<and> {x,y} = {u}"                    -- "If {u, v} = {x} and {x,y} = {u},"
      then have "x = y" by (metis Rep_Set_inverse pairing)
      moreover have "\<dots> = u" using \<open>x = u\<close> calculation by blast
      moreover have "\<dots> = v" by (metis Rep_Set_inverse \<open>{u, v} = {x} \<and> {x, y} = {u}\<close> pairing)
                                                              -- " then x = y = u = v;"
      thus ?thesis by (metis Rep_Set_inject \<open>{u, v} = { x} \<and> {x, y} = { u}\<close> pairing)
      next
      assume *: "\<not>({u,v} = {x} \<and> {x,y} = {u})"               -- " if not,"
      then have "{u, v} = {x,y}" using calculation(6) calculation(7) by auto
                                                              -- "{u, v} = {x,y}."
      hence "{u, v} = {u, y}"  by (simp add: calculation(3))  --"Hence, {u, v} = {u, y}."
      show "y=v"
      proof (cases "v\<noteq>u")
        assume "v\<noteq>u" thus "y=v" by (metis Rep_Set_inverse \<open>{u, v} = {u, y}\<close> pairing)
                                                              --"So, if v \<noteq> u, then y = v;"
        next
        assume "\<not>(v\<noteq>u)" then have "y=u" using * \<open>{u, v} = {x, y}\<close> calculation(3) by auto
                                                              -- "if v = u, then y = v."
        thus "y=v" using \<open>\<not> v \<noteq> u\<close> by blast                  --"Thus, in all cases, y = v."
      qed
    qed
  ultimately show "x = u \<and> y = v" by simp
qed

text{* The following exercises show that it doesn't matter how we define ordered pairs, as long
       as their fundamental property holds. *}

text{* \textbf{FOMUS workshop extra exercise:} *}

lemma Ex4_8_a:    fixes op :: "Class \<Rightarrow> Class \<Rightarrow> Class" ("(\<lceil>_ , _\<rceil>)")
  assumes "\<lceil>X,Y\<rceil> = { {\<emptyset>,X} , {{\<emptyset>,Y}} } "
    shows "\<forall> x y u v :: Set. (\<lceil>x,y\<rceil> = \<lceil>u,v\<rceil>) \<longrightarrow> ((x=u) \<and> (y=v))"
oops

text{* \textbf{FOMUS workshop extra exercise:} *}

lemma Ex4_8_b:
  fixes op :: "Class \<Rightarrow> Class \<Rightarrow> Class" ("(\<lceil>_ , _\<rceil>)")
  assumes "\<lceil>X,Y\<rceil> = { {\<emptyset>,{X}} , {{Y}} } "
    shows "\<forall> x y u v :: Set. (\<lceil>x,y\<rceil> = \<lceil>u,v\<rceil>) \<longrightarrow> ((x=u) \<and> (y=v))"
oops

(* The following contains ToTuple and the relevant lemmas from FOL_Formula.
   TO-DO: define the notation "\<langle>x_1,\<dots>,x_n\<rangle>" *)

text {* Sometimes we need to use metafunctions of type nat \<Rightarrow> Set to describe tuples.
        \texttt{ToTuple} takes an interpretation \tt{i::nat$\Rightarrow$Set} and an
        Isabelle-natural number \tt{n::nat} and returns the tuple
        \tt{$\langle i(0), \dots, i(n)\rangle$}
        In this way we can refer to arbitrary n-tuples. *}

primrec ToTuple :: "[nat \<Rightarrow> Set, nat] \<Rightarrow> Set"
where
  "ToTuple i 0 = i(0)"
  | "ToTuple i (Suc n) = \<langle>ToTuple i n, i(Suc n)\<rangle>"
-- "We sometimes call (ToTuple i n) the (n+1)-tuple coming from i."
notation ToTuple ("(\<langle>\<dots>,(1_)((2_))\<rangle>)")
(* For now, I don't know how to refer to an argument twice in a notation. It should be:
   \<langle> (1_)(0),...,(1_)((2_))\<rangle>. *)

abbreviation ToTuple_add1 :: "(nat\<Rightarrow>Set) \<Rightarrow> nat \<Rightarrow> Set \<Rightarrow> Set" ("(\<langle>\<dots>, _ (_), _\<rangle>)")
where "\<langle>\<dots>,i(n),x\<rangle> \<equiv> \<langle> \<langle>\<dots>,i(n)\<rangle>,x\<rangle>"

abbreviation ToTuple_add2 :: "(nat\<Rightarrow>Set) \<Rightarrow> nat \<Rightarrow> Set \<Rightarrow> Set \<Rightarrow> Set" ("(\<langle>\<dots>,_ (_), _, _\<rangle>)")
where "\<langle>\<dots>,i(n),x,y\<rangle> \<equiv> \<langle> \<langle>\<dots>,i(n)\<rangle>,x,y\<rangle>"

text {* Some basic lemmas about n-tuples. *}

lemma Tuple_Eq: "\<langle>\<dots>,i(n)\<rangle> = \<langle>\<dots>,j(n)\<rangle> \<Longrightarrow> \<forall>k \<le> n. i(k) = j(k)"
-- "Equal n-tuples from different interpretations imply that the interpretations are the same
    below n."
proof (induct n, simp_all)
  fix n::nat
  assume IH:   "(\<langle>\<dots>,i(n)\<rangle> = \<langle>\<dots>,j(n)\<rangle> \<Longrightarrow> \<forall>k\<le>n. i(k) = j(k))"
     and assm: "\<langle>\<dots>,i(n), i(Suc n)\<rangle> = \<langle>\<dots>, j(n), j(Suc n)\<rangle>"
  thus "\<forall>k\<le>Suc n. i k = j k" using Prop4_3 le_Suc_eq by blast
qed

lemma Tuple_Dom: "\<lbrakk>\<And>k. k \<le> n \<Longrightarrow> x(k) = y(k)\<rbrakk> \<Longrightarrow> \<langle>\<dots>,x(n)\<rangle> = \<langle>\<dots>,y(n)\<rangle>"
-- "If two interpretations are the same below n, then they produce the same n-tuples."
by (induct n, simp_all)

lemma Tuple_All1: "(\<forall>v. \<forall>i. \<phi>( \<langle>\<dots>, i(n), v\<rangle> )) \<Longrightarrow> (\<forall>i. \<phi>( \<langle>\<dots>,i(Suc n)\<rangle> ))"
-- "If \<phi> holds for every (n+2) tuple, whose first (n+1) elements may come from any i, then \<phi> holds
    for the (n+2) tuple coming from any i."
by simp

lemma Tuple_All2: "(\<forall>i. \<phi>( \<langle>\<dots>, i(Suc n)\<rangle> )) \<Longrightarrow> (\<forall>v. \<forall>i. \<phi>(\<langle>\<dots>,i(n), v\<rangle>))"
-- "The reverse of Tuple_All1."
proof
  fix v
  assume A1: "\<forall>i. \<phi>( \<langle>\<dots>, i(Suc n)\<rangle> )"
  show "\<forall>i. \<phi>(\<langle>\<dots>,i(n), v\<rangle>)"
  proof
    fix i :: "nat \<Rightarrow> Set"
    have "ToTuple (\<lambda>k. if k = (Suc n) then v else i(k)) (Suc n)
      = \<langle>ToTuple (\<lambda>k. if k = (Suc n) then v else i(k)) n, v\<rangle>" by simp
    also have "\<dots> = \<langle>\<dots>,i(n), v\<rangle>"
      using Tuple_Dom [of n i "\<lambda>k. if k = (Suc n) then v else i(k)"] by simp
    finally show "\<phi>(\<langle>\<dots>, i(n), v\<rangle>)" using A1 by metis
  qed
qed

lemma Tuple_All: "(\<forall>i::nat\<Rightarrow>Set. \<phi>( \<langle>\<dots>, i(Suc n)\<rangle>)) \<longleftrightarrow> (\<forall>v::Set. \<forall>i::nat\<Rightarrow>Set. \<phi>(\<langle>\<dots>, i(n), v\<rangle>))"
using Tuple_All1 Tuple_All2 by auto

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Nub
imports
  HOLCF
  LList
  Maybe
  Nats
  WorkerWrapperNew
begin
(*>*)

section\<open>Transforming $O(n^2)$ \emph{nub} into an $O(n\lg n)$ one\<close>

text\<open>Andy Gill's solution, mechanised.\<close>

subsection\<open>The @{term "nub"} function.\<close>

fixrec nub :: "Nat llist \<rightarrow> Nat llist"
where
  "nub\<cdot>lnil = lnil"
| "nub\<cdot>(x :@ xs) = x :@ nub\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs)"

lemma nub_strict[simp]: "nub\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec nub_body :: "(Nat llist \<rightarrow> Nat llist) \<rightarrow> Nat llist \<rightarrow> Nat llist"
where
  "nub_body\<cdot>f\<cdot>lnil = lnil"
| "nub_body\<cdot>f\<cdot>(x :@ xs) = x :@ f\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs)"

lemma nub_nub_body_eq: "nub = fix\<cdot>nub_body"
  by (rule cfun_eqI, subst nub_def, subst nub_body.unfold, simp)

(* **************************************** *)

subsection\<open>Optimised data type.\<close>

text \<open>Implement sets using lazy lists for now. Lifting up HOL's @{typ "'a
set"} type causes continuity grief.\<close>

type_synonym NatSet = "Nat llist"

definition
  SetEmpty :: "NatSet" where
  "SetEmpty \<equiv> lnil"

definition
  SetInsert :: "Nat \<rightarrow> NatSet \<rightarrow> NatSet" where
  "SetInsert \<equiv> lcons"

definition
  SetMem :: "Nat \<rightarrow> NatSet \<rightarrow> tr" where
  "SetMem \<equiv> lmember\<cdot>(bpred (=))"

lemma SetMem_strict[simp]: "SetMem\<cdot>x\<cdot>\<bottom> = \<bottom>" by (simp add: SetMem_def)
lemma SetMem_SetEmpty[simp]: "SetMem\<cdot>x\<cdot>SetEmpty = FF"
  by (simp add: SetMem_def SetEmpty_def)
lemma SetMem_SetInsert: "SetMem\<cdot>v\<cdot>(SetInsert\<cdot>x\<cdot>s) = (SetMem\<cdot>v\<cdot>s orelse x =\<^sub>B v)"
  by (simp add: SetMem_def SetInsert_def)

text \<open>AndyG's new type.\<close>

domain R = R (lazy resultR :: "Nat llist") (lazy exceptR :: "NatSet")

definition
  nextR :: "R \<rightarrow> (Nat * R) Maybe" where
  "nextR = (\<Lambda> r. case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>r))\<cdot>(resultR\<cdot>r) of
                     lnil \<Rightarrow> Nothing
                   | x :@ xs \<Rightarrow> Just\<cdot>(x, R\<cdot>xs\<cdot>(exceptR\<cdot>r)))"

lemma nextR_strict1[simp]: "nextR\<cdot>\<bottom> = \<bottom>" by (simp add: nextR_def)
lemma nextR_strict2[simp]: "nextR\<cdot>(R\<cdot>\<bottom>\<cdot>S) = \<bottom>" by (simp add: nextR_def)

lemma nextR_lnil[simp]: "nextR\<cdot>(R\<cdot>lnil\<cdot>S) = Nothing" by (simp add: nextR_def)

definition
  filterR :: "Nat \<rightarrow> R \<rightarrow> R" where
  "filterR \<equiv> (\<Lambda> v r. R\<cdot>(resultR\<cdot>r)\<cdot>(SetInsert\<cdot>v\<cdot>(exceptR\<cdot>r)))"

definition
  c2a :: "Nat llist \<rightarrow> R" where
  "c2a \<equiv> \<Lambda> xs. R\<cdot>xs\<cdot>SetEmpty"

definition
  a2c :: "R \<rightarrow> Nat llist" where
  "a2c \<equiv> \<Lambda> r. lfilter\<cdot>(\<Lambda> v. neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>r)))\<cdot>(resultR\<cdot>r)"

lemma a2c_strict[simp]: "a2c\<cdot>\<bottom> = \<bottom>" unfolding a2c_def by simp

lemma a2c_c2a_id: "a2c oo c2a = ID"
  by (rule cfun_eqI, simp add: a2c_def c2a_def lfilter_const_true)

definition
  wrap :: "(R \<rightarrow> Nat llist) \<rightarrow> Nat llist \<rightarrow> Nat llist" where
  "wrap \<equiv> \<Lambda> f xs. f\<cdot>(c2a\<cdot>xs)"

definition
  unwrap :: "(Nat llist \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "unwrap \<equiv> \<Lambda> f r. f\<cdot>(a2c\<cdot>r)"

lemma unwrap_strict[simp]: "unwrap\<cdot>\<bottom> = \<bottom>"
  unfolding unwrap_def by (rule cfun_eqI, simp)

lemma wrap_unwrap_id: "wrap oo unwrap = ID"
  using cfun_fun_cong[OF a2c_c2a_id]
  by - ((rule cfun_eqI)+, simp add: wrap_def unwrap_def)

text \<open>Equivalences needed for later.\<close>

lemma TR_deMorgan: "neg\<cdot>(x orelse y) = (neg\<cdot>x andalso neg\<cdot>y)"
  by (rule trE[where p=x], simp_all)

lemma case_maybe_case:
  "(case (case L of lnil \<Rightarrow> Nothing | x :@ xs \<Rightarrow> Just\<cdot>(h\<cdot>x\<cdot>xs)) of
     Nothing \<Rightarrow> f | Just\<cdot>(a, b) \<Rightarrow> g\<cdot>a\<cdot>b)
   =
   (case L of lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>(fst (h\<cdot>x\<cdot>xs))\<cdot>(snd (h\<cdot>x\<cdot>xs)))"
  apply (cases L, simp_all)
  apply (case_tac "h\<cdot>a\<cdot>llist")
  apply simp
  done

lemma case_a2c_case_caseR:
    "(case a2c\<cdot>w of lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>x\<cdot>xs)
   = (case nextR\<cdot>w of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))" (is "?lhs = ?rhs")
proof -
  have "?rhs = (case (case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w) of
                     lnil \<Rightarrow> Nothing
                   | x :@ xs \<Rightarrow> Just\<cdot>(x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))) of Nothing \<Rightarrow> f | Just\<cdot>(x, r) \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>r))"
    by (simp add: nextR_def)
  also have "\<dots> = (case ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w) of
                     lnil \<Rightarrow> f | x :@ xs \<Rightarrow> g\<cdot>x\<cdot>(a2c\<cdot>(R\<cdot>xs\<cdot>(exceptR\<cdot>w))))"
    using case_maybe_case[where L="ldropWhile\<cdot>(\<Lambda> x. SetMem\<cdot>x\<cdot>(exceptR\<cdot>w))\<cdot>(resultR\<cdot>w)"
                            and f=f and g="\<Lambda> x r. g\<cdot>x\<cdot>(a2c\<cdot>r)" and h="\<Lambda> x xs. (x, R\<cdot>xs\<cdot>(exceptR\<cdot>w))"]
    by simp
  also have "\<dots> = ?lhs"
    apply (simp add: a2c_def)
    apply (cases "resultR\<cdot>w")
      apply simp_all
    apply (rule_tac p="SetMem\<cdot>a\<cdot>(exceptR\<cdot>w)" in trE)
      apply simp_all
    apply (induct_tac llist)
       apply simp_all
    apply (rule_tac p="SetMem\<cdot>aa\<cdot>(exceptR\<cdot>w)" in trE)
      apply simp_all
    done
  finally show "?lhs = ?rhs" by simp
qed

lemma filter_filterR: "lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>(a2c\<cdot>r) = a2c\<cdot>(filterR\<cdot>x\<cdot>r)"
  using filter_filter[where p="Tr.neg oo (\<Lambda> y. x =\<^sub>B y)" and q="\<Lambda> v. Tr.neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>r))"]
  unfolding a2c_def filterR_def
  by (cases r, simp_all add: SetMem_SetInsert TR_deMorgan)

text\<open>Apply worker/wrapper. Unlike Gill/Hutton, we manipulate the body of
the worker into the right form then apply the lemma.\<close>

definition
  nub_body' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body' \<equiv> \<Lambda> f r. case a2c\<cdot>r of lnil \<Rightarrow> lnil
                                   | x :@ xs \<Rightarrow> x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs))"

lemma nub_body_nub_body'_eq: "unwrap oo nub_body oo wrap = nub_body'"
  unfolding nub_body_def nub_body'_def unwrap_def wrap_def a2c_def c2a_def
  by ((rule cfun_eqI)+
     , case_tac "lfilter\<cdot>(\<Lambda> v. Tr.neg\<cdot>(SetMem\<cdot>v\<cdot>(exceptR\<cdot>xa)))\<cdot>(resultR\<cdot>xa)"
     , simp_all add: fix_const)

definition
  nub_body'' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body'' \<equiv> \<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>(a2c\<cdot>xs)))"

lemma nub_body'_nub_body''_eq: "nub_body' = nub_body''"
proof(rule cfun_eqI)+
  fix f r show "nub_body'\<cdot>f\<cdot>r = nub_body''\<cdot>f\<cdot>r"
    unfolding nub_body'_def nub_body''_def
    using case_a2c_case_caseR[where f="lnil" and g="\<Lambda> x xs. x :@ f\<cdot>(c2a\<cdot>(lfilter\<cdot>(Tr.neg oo (\<Lambda> y. x =\<^sub>B y))\<cdot>xs))" and w="r"]
    by simp
qed

definition
  nub_body''' :: "(R \<rightarrow> Nat llist) \<rightarrow> R \<rightarrow> Nat llist" where
  "nub_body''' \<equiv> (\<Lambda> f r. case nextR\<cdot>r of Nothing \<Rightarrow> lnil
                                      | Just\<cdot>(x, xs) \<Rightarrow> x :@ f\<cdot>(filterR\<cdot>x\<cdot>xs))"

lemma nub_body''_nub_body'''_eq: "nub_body'' = nub_body''' oo (unwrap oo wrap)"
  unfolding nub_body''_def nub_body'''_def wrap_def unwrap_def
  by ((rule cfun_eqI)+, simp add: filter_filterR)

text\<open>Finally glue it all together.\<close>

lemma nub_wrap_nub_body''': "nub = wrap\<cdot>(fix\<cdot>nub_body''')"
  using worker_wrapper_fusion_new[OF wrap_unwrap_id unwrap_strict, where body=nub_body]
        nub_nub_body_eq
        nub_body_nub_body'_eq
        nub_body'_nub_body''_eq
        nub_body''_nub_body'''_eq
  by simp

end


theory SumAndProductAxiom
imports Main
begin
typedecl μ
consts P :: "μ⇒μ⇒bool"
axiomatization where P_is_antisymmetric:
"(P x y)∧(P y x) ⟶ (x = y)"
axiomatization where P_is_reflexive:
"P x x"
axiomatization where P_is_transitive:
"∃z. (P x y ∧  P y z)⟶ P x z"

abbreviation overlap :: "μ⇒μ⇒bool" ("O") where
"O x y ≡ ∃z. (P z x ∧ P z y)"

axiomatization where axiom_schema:
"∃x. Φ x ⟶ (∃z. ∀y. ((O y z) ⟷ (Φ x ∧ O y x)))"

axiomatization where strong_supplementation:
"¬P y x ⟶(∃z.(P y z ∧ ¬(O y x)))"

theorem "∃z. (P x z ∧ P y z)⟶(∃z. ∀w. ((O w x) ∨ (O w y)))"
proof-
  have "∃x.(x=a ∨ x=b)⟶(∃z. ∀y. ((O y z) ⟷ ((x=a ∨ x=b) ∧ O y x)))" using axiom_schema by blast
  then have "∃x.(x=a ∨ x=b)" by auto
  hence "∃x.(∃z. ∀y.((O y z) ⟷ ((x=a ∨ x=b) ∧ O y x)))" by auto
  then have "∀y.(∃x.(x=a ∨ x=b) ∧ O y x)⟶(O y a ∨ O y b)" by auto
  from this have "∀y.(∃z.((O y z)⟷(O a y ∨ O b y)))" by blast
  hence "∃z. (P x z ∧ P y z)⟶(∃z. ∀w. ((O w x) ∨ (O w y)))" by auto
  show "∃z. (P x z ∧ P y z)⟶(∃z. ∀w. ((O w x) ∨ (O w y)))" by auto
qed

theorem "(∃z.(P z x ∧ P z y)⟶(∀w.(P w z ⟷(P w x ∧ P w y))))"
proof-
  have "∃x.(P x a ∧ P x b)⟶(∃z.(∀y.(O y z ⟷((P x a ∧ P x b)∧ O y x))))" using axiom_schema by auto
  have "∃x.∀y.(P x a ∧ P x b)∧(O y x)⟶(∀y.(P y a ∧ P y b))" by simp
  hence "∃x.(P x a ∧ P x b)⟶(∃z.(∀y.(O y z ⟷(P y a ∧ P y b))))" using P_is_reflexive by auto
  have "∀y.∃z.(O y z)⟶P y z" using P_is_reflexive by blast
  hence "∃x.(P x a ∧ P x b)⟶(∃z.(∀y.(P y z ⟷(P y a ∧ P y b))))" by auto
  thus "(∃z.(P z x ∧ P z y)⟶(∀w.(P w z ⟷(P w x ∧ P w y))))" by auto
qed

end


theory heap_deleteMinimum
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

datatype 'a Maybe = Nothing | Just "'a"

datatype Heap = Node "Heap" "Nat" "Heap" | Nil3

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun listDeleteMinimum :: "Nat list => (Nat list) Maybe" where
"listDeleteMinimum (Nil2) = Nothing"
| "listDeleteMinimum (Cons2 y xs) = Just xs"

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

fun merge :: "Heap => Heap => Heap" where
"merge (Node z x2 x3) (Node x4 x5 x6) =
   (if le x2 x5 then Node (merge x3 (Node x4 x5 x6)) x2 z else
      Node (merge (Node z x2 x3) x6) x5 x4)"
| "merge (Node z x2 x3) (Nil3) = Node z x2 x3"
| "merge (Nil3) y = y"

fun toList :: "Nat => Heap => Nat list" where
"toList (Z) y = Nil2"
| "toList (S z) (Node x2 x3 x4) =
     Cons2 x3 (toList z (merge x2 x4))"
| "toList (S z) (Nil3) = Nil2"

fun heapSize :: "Heap => Nat" where
"heapSize (Node l y r) = S (plus (heapSize l) (heapSize r))"
| "heapSize (Nil3) = Z"

fun toList2 :: "Heap => Nat list" where
"toList2 x = toList (heapSize x) x"

fun maybeToList :: "Heap Maybe => (Nat list) Maybe" where
"maybeToList (Nothing) = Nothing"
| "maybeToList (Just y) = Just (toList2 y)"

fun deleteMinimum :: "Heap => Heap Maybe" where
"deleteMinimum (Node l y r) = Just (merge l r)"
| "deleteMinimum (Nil3) = Nothing"

(*hipster plus
          listDeleteMinimum
          le
          merge
          toList
          heapSize
          toList2
          maybeToList
          deleteMinimum *)

(*hipster plus le*)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_aa [thy_expl]: "plus (plus x1 y1) z1 =
plus x1 (plus y1 z1)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_ai [thy_expl]: "plus (plus x1 x1) (plus y1 z1) =plus (plus x1 y1) (plus x1 z1)"
by (hipster_induct_schemes plus.simps le.simps)

lemma lemma_aj [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes plus.simps le.simps)

(*hipster le*)
lemma lemma_ak [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps)

lemma lemma_al [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_am [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_an [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps)

lemma lemma_ao [thy_expl]: "le y2 x2 \<Longrightarrow> le (S x2) y2 = False"
by (hipster_induct_schemes le.simps)

lemma lemma_ap [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
by (hipster_induct_schemes le.simps Nat.exhaust)

lemma le_trans [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
by (hipster_induct_schemes le.simps Nat.exhaust)

(*hipster heapSize plus*)

(*hipster le plus heapSize*)
lemma lemma_aq [thy_expl]: "le x2 (plus x2 y2) = True"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_ar [thy_expl]: "le (plus x2 y2) x2 = le y2 Z"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_as [thy_expl]: "le (plus x1 y1) (plus x1 z1) = le y1 z1"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps Nat.exhaust)

lemma lemma_at [thy_expl]: "le (plus x1 y1) (plus y1 z1) = le x1 z1"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_au [thy_expl]: "le (plus x2 y2) (S y2) = le (plus x2 z2) (S z2)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_av [thy_expl]: "le (plus x1 y1) (S x1) = le (plus z1 y1) (S z1)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_aw [thy_expl]: "le (plus x1 x1) (plus y1 y1) = le x1 y1"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_ax [thy_expl]: "le (S x2) (plus x2 y2) = le (S z2) (plus z2 y2)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_ay [thy_expl]: "le (S x1) (plus y1 x1) = le (S z1) (plus y1 z1)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_az [thy_expl]: "le (S x1) (plus y1 x1) = le (S z1) (plus z1 y1)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_ba [thy_expl]: "le x2 (S Z) = le (plus x2 y2) (S y2)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_bb [thy_expl]: "le (S Z) x2 = le (S y2) (plus x2 y2)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_bc [thy_expl]: "le (plus x2 x2) (S Z) = le x2 Z"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

lemma lemma_bd [thy_expl]: "le (S Z) (plus x2 x2) = le (S y2) (plus x2 y2)"
by (hipster_induct_schemes le.simps plus.simps heapSize.simps)

hipster toList toList2 maybeToList

hipster merge

theorem x0 :
  "!! (h :: Heap) .
     (listDeleteMinimum (toList2 h)) = (maybeToList (deleteMinimum h))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory E4_4
  imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
ev0 : "ev 0" |
evSS : "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  thus "False"
  proof cases
    case ev0
  next
    case evSS
    thus ?thesis using ev.simps by blast
  qed
qed

end