chapter \<open>Gap Buffer\<close>
section \<open>Challenge\<close>
text_raw \<open>{\upshape
A gap buffer is a data structure for the implementation of text editors,
which can efficiently move the cursor, as well add and delete characters.

The idea is simple: the editor's content is represented as a character array~$a$
of length~$n$,
which has a gap of unused entries $a[l], \ldots, a[r-1]$,
with respect to two indices $l \le r$.
The data it represents is composed as $a[0], \ldots, a[l-1], a[r], ..., a[n-1]$.

The current cursor position is at the left index $l$, and if we type a character, it is
written to $a[l]$ and $l$ is increased.
When the gap becomes empty, the array is enlarged and the data from $r$ is shifted to the right.

\paragraph{Implementation task.}
Implement the following four operations in the language of your tool:
Procedures \verb|left()| and \verb|right()| move the cursor by one character;
\verb|insert()| places a character at the beginning of the gap $a[l]$;
\verb|delete()| removes the character at $a[l]$ from the range of text.

\begin{multicols}{2}
\begin{lstlisting}[language=C,morekeywords={procedure,function,end,to,in,var,then,not,mod}]
procedure left()
    if l != 0 then
        l := l - 1
        r := r - 1
        a[r] := a[l]
    end-if
end-procedure

procedure right()
    // your task: similar to left()
    // but pay attention to the
    // order of statements
end-procedure
\end{lstlisting}

\begin{lstlisting}[language=C,morekeywords={procedure,function,end,to,in,var,then,not,mod}]
procedure insert(x: char)
    if l == r then
        // see extended task
        grow()
    end-if
    a[l] := x
    l := l + 1
end-procedure

procedure delete()
    if l != 0 then
        l := l - 1
    end-if
end-procedure
\end{lstlisting}
\end{multicols}

\paragraph{Verification task.}
Specify the intended behavior of the buffer in terms of a contiguous
representation of the editor content.
This can for example be based on strings, functional arrays, sequences, or lists.
Verify that the gap buffer implementation satisfies this specification,
and that every access to the array is within bounds.

\emph{Hint:}
For this task you may assume that \verb|insert()| has the
precondition $l < r$ and remove the call to \verb|grow()|.
Alternatively, assume a contract for \verb|grow()| that ensures
that this call does not change the abstract representation.

\paragraph{Extended verification task.}
Implement the operation \verb|grow()|, specify its behavior in a way that lets
you verify \verb|insert()| in a modular way
(i.e. not by referring to the implementation of \verb|grow()|),
and verify that \verb|grow()| satisfies this specification.

\emph{Hint}: You may assume that the allocation of the new buffer always succeeds.
If~your tool/language supports copying array ranges (such as
\verb|System.arraycopy()| in Java),
consider using these primitives instead of the loops in the
pseudo-code below.

\begin{lstlisting}[language=C,morekeywords={procedure,function,end,to,in,new,var,then,not,mod}]
procedure grow()
    var b := new char[a.length + K]

    // b[0..l] := a[0..l]
    for i = 0 to l - 1 do
        b[i] := a[i]
    end-for

    // b[r + K..] := a[r..]
    for i = r to a.length - 1 do
        b[i + K] := a[i]
    end-for

    r := r + K
    a := b
end-procedure
\end{lstlisting}

\paragraph{Resources}
\begin{itemize}
\item \url{https://en.wikipedia.org/wiki/Gap_buffer}
\item \url{http://scienceblogs.com/goodmath/2009/02/18/gap-buffers-or-why-bother-with-1}
\end{itemize}
}
\clearpage
\<close>
section \<open>Solution\<close>
theory Challenge1
imports "lib/VTcomp"
begin

  text \<open>Fully fledged specification of textbuffer ADT,
    and its implementation by a gap buffer.
  \<close>
  subsection \<open>Abstract Specification\<close>

  text \<open>
    Initially, we modelled the abstract text as a cursor position and a list.
    However, this gives you an invariant on the abstract level. An isomorphic
    but invariant free formulation is a pair of lists, representing the text
    before and after the cursor.
  \<close>

  datatype 'a textbuffer = BUF "'a list" "'a list"

  text \<open>The primitive operations are the empty textbuffer,
    and to extract the text and the cursor position\<close>

  definition empty :: "'a textbuffer" where "empty = BUF [] []"
  primrec get_text :: "'a textbuffer \<Rightarrow> 'a list" where "get_text (BUF a b) = a@b"
  primrec get_pos :: "'a textbuffer \<Rightarrow> nat" where "get_pos (BUF a b) = length a"

  text \<open>These are the operations that were specified in the challenge\<close>
  primrec move_left :: "'a textbuffer \<Rightarrow> 'a textbuffer" where
    "move_left (BUF a b)
    = (if a\<noteq>[] then BUF (butlast a) (last a#b) else BUF a b)"
  primrec move_right :: "'a textbuffer \<Rightarrow> 'a textbuffer" where
    "move_right (BUF a b)
    = (if b\<noteq>[] then BUF (a@[hd b]) (tl b) else BUF a b)"
  primrec insert :: "'a \<Rightarrow> 'a textbuffer \<Rightarrow> 'a textbuffer" where
    "insert x (BUF a b) = BUF (a@[x]) b"
  primrec delete :: "'a textbuffer \<Rightarrow> 'a textbuffer" where
    "delete (BUF a b) = BUF (butlast a) b"
   \<comment> \<open>Note that @{lemma \<open>butlast [] = []\<close> by simp} in Isabelle\<close>

  text \<open>We can also assign them a meaning wrt position and text\<close>

  lemma empty_pos[simp]: "get_pos empty = 0"
    unfolding empty_def by auto
  lemma empty_text[simp]: "get_text empty = []"
    unfolding empty_def by auto
  lemma move_left_pos[simp]: "get_pos (move_left b) = get_pos b - 1"
    \<comment> \<open>Note that @{lemma \<open>0-(1::nat)=0\<close> by simp} in Isabelle\<close>
    by (cases b) auto
  lemma move_left_text[simp]: "get_text (move_left b) = get_text b"
    by (cases b) auto

  lemma move_right_pos[simp]:
    "get_pos (move_right b) = min (get_pos b+1) (length (get_text b))"
    by (cases b) auto
  lemma move_right_text[simp]: "get_text (move_right b) = get_text b"
    by (cases b) auto

  lemma insert_pos[simp]: "get_pos (insert x b) = get_pos b + 1"
    by (cases b) auto
  lemma insert_text: "get_text (insert x b)
    = take (get_pos b) (get_text b)@x#drop (get_pos b) (get_text b)"
    by (cases b) auto

  lemma delete_pos[simp]: "get_pos (delete b) = get_pos b - 1"
    by (cases b) auto
  lemma delete_text: "get_text (delete b)
    = take (get_pos b-1) (get_text b)@drop (get_pos b) (get_text b)"
    by (cases b) auto
  text \<open>For the zero case, we can prove a simpler (equivalent) lemma\<close>
  lemma delete_text0[simp]: "get_pos b=0 \<Longrightarrow> get_text (delete b) = get_text b"
    by (cases b) auto

  text \<open>To fully exploit the capabilities of our tool, we can (optionally) show
    that the operations of a text buffer are parametric in its content.
    Then, we can automatically refine the representation of the content.
  \<close>
  definition [to_relAPP]:
    "textbuffer_rel A \<equiv> {(BUF a b, BUF a' b') | a b a' b'.
                           (a,a')\<in>\<langle>A\<rangle>list_rel \<and> (b,b')\<in>\<langle>A\<rangle>list_rel}"

  lemma [param]: "(BUF,BUF) \<in> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>textbuffer_rel"
    by (auto simp: textbuffer_rel_def)
  lemma [param]: "(rec_textbuffer,rec_textbuffer)
    \<in> (\<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel\<rightarrow>B) \<rightarrow> \<langle>A\<rangle>textbuffer_rel \<rightarrow> B"
    by (auto simp: textbuffer_rel_def) parametricity

  context
    notes[simp] =
      empty_def get_text_def get_pos_def move_left_def move_right_def
      insert_def delete_def conv_to_is_Nil
  begin
    sepref_decl_op (no_def) empty :: "\<langle>A\<rangle>textbuffer_rel" .
    sepref_decl_op (no_def) get_text :: "\<langle>A\<rangle>textbuffer_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
    sepref_decl_op (no_def) get_pos :: "\<langle>A\<rangle>textbuffer_rel \<rightarrow> nat_rel" .
    sepref_decl_op (no_def) move_left :: "\<langle>A\<rangle>textbuffer_rel \<rightarrow> \<langle>A\<rangle>textbuffer_rel" .
    sepref_decl_op (no_def) move_right :: "\<langle>A\<rangle>textbuffer_rel \<rightarrow> \<langle>A\<rangle>textbuffer_rel" .
    sepref_decl_op (no_def) insert :: "A\<rightarrow>\<langle>A\<rangle>textbuffer_rel \<rightarrow> \<langle>A\<rangle>textbuffer_rel" .
    sepref_decl_op (no_def) delete :: "\<langle>A\<rangle>textbuffer_rel \<rightarrow> \<langle>A\<rangle>textbuffer_rel" .
  end

subsection \<open>Refinement 1: List with Gap\<close>

  subsection \<open>Implementation on List-Level\<close>
  type_synonym 'a gap_buffer = "nat \<times> nat \<times> 'a list"

  subsubsection \<open>Abstraction Relation\<close>
  text \<open>Also called coupling relation sometimes.
    Can be any relation, here we define it by an invariant and an
    abstraction function.  \<close>
  definition "gap_\<alpha> \<equiv> \<lambda>(l,r,buf). BUF (take l buf) (drop r buf)"
  definition "gap_invar \<equiv> \<lambda>(l,r,buf). l\<le>r \<and> r\<le>length buf"
  abbreviation "gap_rel \<equiv> br gap_\<alpha> gap_invar"

  subsubsection \<open>Empty\<close>

  definition "empty1 \<equiv> RETURN (0,0,[])"
  lemma empty1_correct: "(empty1, RETURN empty) \<in> \<langle>gap_rel\<rangle>nres_rel"
    unfolding empty1_def empty_def
    apply refine_vcg
    by (auto simp: in_br_conv gap_\<alpha>_def gap_invar_def)

  subsubsection \<open>Left\<close>
  definition "move_left1 \<equiv> \<lambda>(l,r,buf). doN {
    if l\<noteq>0 then doN {
      ASSERT(r-1<length buf \<and> l-1<length buf);
      RETURN (l-1,r-1,buf[r-1:=buf!(l-1)])
    } else RETURN (l,r,buf)
  }"

  lemma move_left1_correct:
    "(move_left1, RETURN o move_left) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding move_left1_def
    apply refine_vcg
    apply (auto
      simp: in_br_conv gap_\<alpha>_def gap_invar_def move_left1_def
      split: prod.splits)
    subgoal by (simp add: butlast_take)
    subgoal
      by (smt Cons_nth_drop_Suc One_nat_def Suc_pred diff_Suc_less
        drop_update_cancel last_take_nth_conv le_trans length_list_update
        less_le_trans neq0_conv nth_list_update_eq)
    done

  subsubsection \<open>Right\<close>
  definition "move_right1 \<equiv> \<lambda>(l,r,buf). doN {
    if r<length buf then doN {
      ASSERT (l<length buf);
      RETURN (l+1,r+1,buf[l:=buf!r])
    } else RETURN (l,r,buf)
  }"

  lemma move_right1_correct:
    "(move_right1,RETURN o move_right) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding move_right1_def
    apply refine_vcg
    unfolding gap_\<alpha>_def gap_invar_def
    apply (auto
      simp: in_br_conv hd_drop_conv_nth take_update_last
      split: prod.split)
    by (simp add: drop_Suc tl_drop)

  subsubsection \<open>Insert and Grow\<close>

  definition "can_insert \<equiv> \<lambda>(l,r,buf). l<r"

  definition "grow1 K \<equiv> \<lambda>(l,r,buf). doN {
    let b = op_array_replicate (length buf + K) default;
    b \<leftarrow> mop_list_blit buf 0 b 0 l;
    b \<leftarrow> mop_list_blit buf r b (r+K) (length buf - r);
    RETURN (l,r+K,b)
  }"

  lemma grow1_correct[THEN SPEC_trans, refine_vcg]:
    assumes "gap_invar gb"
    shows "grow1 K gb  \<le> (SPEC (\<lambda>gb'.
          gap_invar gb'
        \<and> gap_\<alpha> gb' = gap_\<alpha> gb
        \<and> (K>0 \<longrightarrow> can_insert gb')))"
    unfolding grow1_def
    apply refine_vcg
    using assms
    unfolding gap_\<alpha>_def gap_invar_def can_insert_def
    apply clarsimp_all
    apply (auto simp: op_list_blit_def)
    by (simp add: min_def)

  definition "insert1 x \<equiv> \<lambda>(l,r,buf). doN {
    (l,r,buf) \<leftarrow>
      if (l=r) then grow1 (length buf+1) (l,r,buf) else RETURN (l,r,buf);
    ASSERT (l<length buf);
    RETURN (l+1,r,buf[l:=x])
  }"

  lemma insert1_correct:
    "(insert1,RETURN oo insert) \<in> Id \<rightarrow> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding insert1_def
    apply refine_vcg
    unfolding insert_def gap_\<alpha>_def gap_invar_def can_insert_def
    apply (auto simp: in_br_conv take_update_last split: prod.split)
    done

  subsubsection \<open>Delete\<close>
  definition "delete1
    \<equiv> \<lambda>(l,r,buf). if l>0 then RETURN (l-1,r,buf) else RETURN (l,r,buf)"
  lemma delete1_correct:
    "(delete1,RETURN o delete) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
    apply clarsimp
    unfolding delete1_def
    apply refine_vcg
    unfolding gap_\<alpha>_def gap_invar_def
    by (auto simp: in_br_conv butlast_take split: prod.split)

subsection \<open>Imperative Arrays and Executable Code\<close>
  abbreviation "gap_impl_assn \<equiv> nat_assn \<times>\<^sub>a nat_assn \<times>\<^sub>a array_assn id_assn"
  definition "gap_assn A
    \<equiv> hr_comp (hr_comp gap_impl_assn gap_rel) (\<langle>the_pure A\<rangle>textbuffer_rel)"

  context
    notes gap_assn_def[symmetric,fcomp_norm_unfold]
  begin
    sepref_definition empty_impl
      is "uncurry0 empty1" :: "unit_assn\<^sup>k\<rightarrow>\<^sub>agap_impl_assn"
      unfolding empty1_def array.fold_custom_empty
      by sepref
    sepref_decl_impl empty_impl: empty_impl.refine[FCOMP empty1_correct] .

    sepref_definition move_left_impl
      is move_left1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
      unfolding move_left1_def by sepref
    sepref_decl_impl move_left_impl: move_left_impl.refine[FCOMP move_left1_correct] .

    sepref_definition move_right_impl
      is move_right1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
      unfolding move_right1_def by sepref
    sepref_decl_impl move_right_impl: move_right_impl.refine[FCOMP move_right1_correct] .

    sepref_definition insert_impl
      is "uncurry insert1" :: "id_assn\<^sup>k*\<^sub>agap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
      unfolding insert1_def grow1_def by sepref
      \<comment> \<open>We inline @{const grow1} here\<close>
    sepref_decl_impl insert_impl: insert_impl.refine[FCOMP insert1_correct] .

    sepref_definition delete_impl
      is delete1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
      unfolding delete1_def by sepref
    sepref_decl_impl delete_impl: delete_impl.refine[FCOMP delete1_correct] .

  end

  text \<open>
  The above setup generated the following refinement theorems, connecting the implementations
  with our abstract specification:
  @{thm [display]
    empty_impl_hnr move_left_impl_hnr move_right_impl_hnr insert_impl_hnr delete_impl_hnr
  }
  \<close>

  export_code move_left_impl move_right_impl insert_impl delete_impl
    in SML_imp module_name Gap_Buffer
    in OCaml_imp module_name Gap_Buffer
    in Haskell module_name Gap_Buffer
    in Scala module_name Gap_Buffer

subsection \<open>Simple Client\<close>

  definition "client \<equiv> RETURN (fold (\<lambda>f. f) [
    insert (1::int),
    insert (2::int),
    insert (3::int),
    insert (5::int),
    move_left,
    insert (4::int),
    move_right,
    insert (6::int),
    delete
  ] empty)"

  lemma "client \<le> SPEC (\<lambda>r. get_text r=[1,2,3,4,5])"
    unfolding client_def
    by (simp add: delete_text insert_text)

  sepref_definition client_impl
    is "uncurry0 client" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a gap_assn id_assn"
    unfolding client_def fold.simps id_def comp_def
    by sepref

  ML_val \<open>
    @{code client_impl} ()
  \<close>

end


theory T61
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
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_NStoogeSort2Permutes
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 x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun third :: "Nat => Nat" where
"third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"

fun twoThirds :: "Nat => Nat" where
"twoThirds y =
   (if (y = (S (S Z))) then S Z else
      (if (y = (S Z)) then S Z else
         (case y of
            Z => Z
            | S z => plus (S (S Z)) (twoThirds (minus y (S (S (S Z))))))))"

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
"sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun elem :: "'a => 'a list => bool" where
"elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function nstooge2sort2 :: "Nat list => Nat list"
         and nstoogesort2 :: "Nat list => Nat list"
         and nstooge2sort1 :: "Nat list => Nat list" where
"nstooge2sort2 y =
   (case splitAt (twoThirds (length y)) y of
      pair2 ys2 zs1 => x (nstoogesort2 ys2) zs1)"
| "nstoogesort2 (nil2) = nil2"
| "nstoogesort2 (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort2 (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort2 (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge2sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort2 zs1))"
by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (nstoogesort2 xs) xs"
  oops

end


theory DL_Equality_Sigma_Commit imports
  Abstract_Commitment
  Abstract_Sigma_Protocols
  Cyclic_Group_Ext
  Discrete_log
  GCD
  Uniform_Sampling
  Uniform_Sampling_Defs
begin

locale schnorr_2_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
    and x :: nat
    and g' :: 'grp
  assumes finite_group: "finite (carrier \<G>)"
    and order_gt_2: "order \<G> > 2"
    and prime_order: "prime (order \<G>)"
    and prime_field: "a < (order \<G>) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coprime a (order \<G>)"
    and g': "g' = \<^bold>g (^) x"
begin

lemma or_gt_0 [simp]:"order \<G> > 0"
  using order_gt_2 by simp

lemma lossless_samp_uni_excl: "lossless_spmf (samp_uni_excl (order \<G>) p)"
proof-
  have "order \<G> > 1" using order_gt_2 by simp
  then show ?thesis
    by (metis Diff_empty samp_uni_excl_def Diff_eq_empty_iff One_nat_def card_empty card_insert_disjoint card_lessThan equals0D finite_Diff_insert finite_lessThan lessThan_iff less_not_refl3 lossless_spmf_of_set subset_singletonD)
qed

lemma lossless_samp_uni: "lossless_spmf (sample_uniform (order \<G>))"
  using order_gt_2 by simp

lemma lossless_samp_uni_units: "lossless_spmf (samp_uni_units (order \<G>))"
  apply(simp add: samp_uni_units_def) using order_gt_2 by fastforce

lemma weight_samp_uni_units: "weight_spmf (samp_uni_units (order \<G>)) = 1"
  using lossless_samp_uni_units
  by (simp add: lossless_spmf_def)

lemma [simp]: "set_spmf (samp_uni_units_excl (order \<G>) p) = ({..< order \<G>} - {p} - {0})"
  by(simp add: samp_uni_units_excl_def)

lemma lossless_samp_uni_units_excl: "lossless_spmf (samp_uni_units_excl (order \<G>) p)"
  apply(simp add: samp_uni_units_excl_def) using order_gt_2
  by (smt Diff_empty Diff_insert0 One_nat_def Suc_leI card.insert card_empty card_lessThan finite.intros(1) finite_insert insert_Diff insert_absorb leD nat_neq_iff prime_gt_1_nat prime_order subset_singletonD two_is_prime_nat zero_le_one)

definition "challenge = samp_uni_units (order \<G>)"

definition "snd_challenge p = samp_uni_units_excl (order \<G>) p"

definition "response r w e = return_spmf ((w*e + r) mod (order \<G>))"

type_synonym witness = "nat"
type_synonym rand = nat
type_synonym 'grp' msg = "'grp' \<times> 'grp'"
type_synonym response = nat
type_synonym challenge = nat
type_synonym 'grp' pub_in = "'grp' \<times> 'grp'"

definition init :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> (rand \<times> 'grp msg) spmf"
  where "init h w = do {
    let (h, h') = h;
    r \<leftarrow> sample_uniform (order \<G>);
    return_spmf (r, \<^bold>g (^) r, g' (^) r)}"

definition check :: "'grp pub_in \<Rightarrow> 'grp msg \<Rightarrow> challenge \<Rightarrow> response \<Rightarrow> bool spmf"
  where "check h a e z =
    return_spmf (fst a \<otimes> (fst h (^) e) = \<^bold>g (^) z \<and> snd a \<otimes> (snd h (^) e) = g' (^) z)"

definition R :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> bool"
  where "R h w \<equiv> (fst h = \<^bold>g (^) w \<and> w \<noteq> 0 \<and> w < order \<G> \<and> snd h = g' (^) w)"

definition R2 :: "'grp pub_in \<Rightarrow> witness \<Rightarrow> ('grp msg, challenge, response) conv_tuple spmf"
  where "R2 H w = do {
  let (h, h') = H;
  (r, a, a') \<leftarrow> init H w;
  c \<leftarrow> samp_uni_units (order \<G>);
  let z = (w*c + r) mod (order \<G>);
  return_spmf ((a,a'),c, z)}"

definition S2 :: "'grp pub_in \<Rightarrow> challenge \<Rightarrow> ('grp msg, challenge, response) conv_tuple spmf"
  where "S2 H c = do {
  let (h, h') = H;
  z \<leftarrow> (sample_uniform (order \<G>));
  let a = \<^bold>g (^) z \<otimes> inv (h (^) c);
  let a' =  g' (^) z \<otimes> inv (h' (^) c);
  return_spmf ((a,a'),c, z)}"

definition pk_adversary2 :: "'grp pub_in \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> ('grp msg, challenge, response) conv_tuple \<Rightarrow> nat spmf"
  where "pk_adversary2 x' c1 c2 = do {
    let ((a,a'), e, z) = c1;
    let ((b,b'), e', z') = c2;
    return_spmf (if e > e' then (nat ((int z - int z') * (fst (bezw (e - e') (order \<G>))) mod order \<G>)) else
(nat ((int z' - int z) * (fst (bezw (e' - e) (order \<G>))) mod order \<G>)))}"

sublocale epsilon_protocols_base: epsilon_protocols_base init challenge snd_challenge response check R S2 .

lemma R2_eq_R: "R2 h w = epsilon_protocols_base.R h w"
  unfolding  R2_def epsilon_protocols_base.R_def Let_def
  by(simp add: challenge_def response_def split_def)

end

locale schnorr_2 = schnorr_2_base + cyclic_group \<G>
begin

lemma zr:
  assumes z: "z = (w*c + r) mod (order \<G>)"
    and x: "w < order \<G>"
    and c: "c < order \<G>"
    and r: "r < order \<G>"
  shows "(z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>) = r"
proof-
  have cong: "[z + (order \<G>)*(order \<G>) = w*c + r] (mod (order \<G>))"
    by(simp add: cong_nat_def z)
  hence "[z + (order \<G>)*(order \<G>) - w*c = r] (mod (order \<G>))"
  proof-
    have "z + (order \<G>)*(order \<G>) > w*c"
      using x c by (simp add: mult_strict_mono trans_less_add2)
    then show ?thesis
      by (metis cong add_diff_inverse_nat cong_add_lcancel_nat less_imp_le linorder_not_le)
  qed
  then show ?thesis
    by(simp add: cong_nat_def r)
qed

lemma xr':assumes x: "w < order \<G>"
    and c: "c < order \<G>"
    and r: "r < order \<G>"
  shows "((w*c + r) mod (order \<G>) mod (order \<G>) + (order \<G>)*(order \<G>) - w*c) mod (order \<G>) = r"
  using assms zr by simp

lemma complete: assumes "h = (\<^bold>g (^) (w::nat), g' (^) w)"
  shows "spmf (epsilon_protocols_base.completeness_game h w) True = 1"
proof-
  have "\<^bold>g (^) y \<otimes> (\<^bold>g (^) w) (^) e = \<^bold>g (^) ((w * e + y))" for y e
    by (simp add: add.commute nat_pow_pow nat_pow_mult)
  also have "(\<^bold>g (^) x) (^) y \<otimes> ((\<^bold>g (^) x) (^) w) (^) e = (\<^bold>g (^) x) (^) ((w * e + y) mod (order \<G>))" for y e
    by (metis add.commute nat_pow_pow nat_pow_mult  pow_generator_mod generator_closed nat_pow_closed mod_mult_right_eq)
  ultimately show ?thesis
    unfolding  epsilon_protocols_base.completeness_game_def init_def check_def
    by(simp add: Let_def bind_spmf_const  pow_generator_mod order_gt_2 weight_samp_uni_units lossless_weight_spmfD init_def challenge_def response_def g' assms)
qed

lemma completeness:
  shows "epsilon_protocols_base.completeness h w"
  apply(simp add: epsilon_protocols_base.completeness_def R_def)
  by (metis prod.collapse complete)

lemma h_sub:
  assumes "h = \<^bold>g (^) w" and x_not_0: "w \<noteq> 0" and w: "w < order \<G>" and z: "z < order \<G>" and c: "c < order \<G>"
  shows "\<^bold>g (^) ((z + (order \<G>)*(order \<G>) - w*c)) = \<^bold>g (^) z \<otimes> inv (h (^) c)"
(is "?lhs = ?rhs")
proof-
  have "(z + order \<G> * order \<G> - w * c) = (z + (order \<G> * order \<G> - w * c))"
    using w c z by (simp add: less_imp_le_nat mult_le_mono)
  then have lhs: "?lhs = \<^bold>g (^) z \<otimes> \<^bold>g (^) ((order \<G>)*(order \<G>) - w*c)" by(simp add: nat_pow_mult)
  have " \<^bold>g (^) ((order \<G>)*(order \<G>) - w*c) =  inv (h (^) c)"
  proof-
    have "((order \<G>)*(order \<G>) - w*c) > 0" using assms
      by (simp add: mult_strict_mono)
    then have " \<^bold>g (^) ((order \<G>)*(order \<G>) - w*c) =  \<^bold>g (^) int ((order \<G>)*(order \<G>) - w*c)"
      by (simp add: int_pow_int)
    also have "... = \<^bold>g (^) int ((order \<G>)*(order \<G>)) \<otimes> inv (\<^bold>g (^) (w*c))"
      using int_pow_diff[of "\<^bold>g" "order \<G> * order \<G>" "w * c"]
      by (smt \<open>0 < order \<G> * order \<G> - w * c\<close> generator_closed group.int_pow_def2 group_l_invI int_minus int_pow_int l_inv_ex of_nat_less_iff zero_less_diff)
    also have "... = \<^bold>g (^) ((order \<G>)*(order \<G>)) \<otimes> inv (\<^bold>g (^) (w*c))"
      by (metis int_pow_int)
    also have "... = \<^bold>g (^) ((order \<G>)*(order \<G>)) \<otimes> inv ((\<^bold>g (^) w) (^) c)"
      by(simp add: nat_pow_pow)
    also have "... = \<^bold>g (^) ((order \<G>)*(order \<G>)) \<otimes> inv (h (^) c)"
      using assms by simp
    also have "... = \<one> \<otimes> inv (h (^) c)"
      using generator_pow_order
      by (metis generator_closed mult_is_0 nat_pow_0 nat_pow_pow)
    ultimately show ?thesis
      by (simp add: assms(1))
  qed
  then show ?thesis using lhs by simp
qed

lemma h_sub2:
  assumes  "h' = g' (^) w" and x_not_0: "w \<noteq> 0" and w: "w < order \<G>" and z: "z < order \<G>" and c: "c < order \<G>"
  shows "g' (^) ((z + (order \<G>)*(order \<G>) - w*c))  = g' (^) z \<otimes> inv (h' (^) c)"
(is "?lhs = ?rhs")
proof-
  have "g' = \<^bold>g (^) x" using g' by simp
  have g'_carrier: "g' \<in> carrier \<G>" using g' by simp
  have 1: "g' (^) ((order \<G>)*(order \<G>) - w*c) = inv (h' (^) c)"
  proof-
    have "((order \<G>)*(order \<G>) - w*c) > 0" using assms
      by (simp add: mult_strict_mono)
    then have " g' (^) ((order \<G>)*(order \<G>) - w*c) =  g' (^) int ((order \<G>)*(order \<G>) - w*c)"
      by (simp add: int_pow_int)
    also have "... = g' (^) int ((order \<G>)*(order \<G>)) \<otimes> inv (g' (^) (w*c))"
      using int_pow_diff[of "g'" "order \<G> * order \<G>" "w * c"] g'_carrier
    proof -
      have "\<forall>x0 x1. int x1 - int x0 = int x1 + - 1 * int x0"
        by auto
      then have f1: "g' (^) int (order \<G> * order \<G> - w * c) = g' (^) nat (int (order \<G> * order \<G>) + - 1 * int (w * c))"
        by (metis (no_types) int_minus int_pow_int)
      have f2: "0 \<le> int (order \<G> * order \<G>) + - 1 * int (w * c)"
        using \<open>(0::nat) < order \<G> * order \<G> - (w::nat) * (c::nat)\<close> by linarith
      have f3: "\<forall>p a i. \<not> Group.group (p::\<lparr>carrier :: 'a set, monoid.mult :: _ \<Rightarrow> _ \<Rightarrow> _, one :: _, generator :: 'a\<rparr>) \<or> a (^)\<^bsub>p\<^esub> i = (if 0 \<le> i then a (^)\<^bsub>p\<^esub> nat i else inv\<^bsub>p\<^esub> (a (^)\<^bsub>p\<^esub> nat (- 1 * i)))"
        by (simp add: group.int_pow_def2)
      have f4: "\<forall>x0 x1. (x1::int) - x0 = - 1 * x0 + x1"
        by auto
      have "- 1 * int (w * c) + int (order \<G> * order \<G>) = int (order \<G> * order \<G>) + - 1 * int (w * c)"
        by presburger
      then show ?thesis
        using f4 f3 f2 f1 by (metis (full_types) g'_carrier group.int_pow_diff group_l_invI int_pow_int l_inv_ex)
    qed
    also have "... = g' (^) ((order \<G>)*(order \<G>)) \<otimes> inv (g' (^) (w*c))"
      by (metis int_pow_int)
    also have "... = g' (^) ((order \<G>)*(order \<G>)) \<otimes> inv (h' (^) c)"
      by(simp add: nat_pow_pow g'_carrier assms)
    also have "... = \<one> \<otimes> inv (h' (^) c)"
      using generator_pow_mult_order
      by (metis g' generator_closed mult.commute nat_pow_one nat_pow_pow)
    ultimately show ?thesis
      by (simp add: assms(1) g'_carrier)
  qed
  have "(z + order \<G> * order \<G> - w * c) = (z + (order \<G> * order \<G> - w * c))"
    using w c z by (simp add: less_imp_le_nat mult_le_mono)
  then have lhs: "?lhs = g' (^) z \<otimes> g' (^) ((order \<G>)*(order \<G>) - w*c)"
    by(auto simp add: nat_pow_mult g'_carrier)
  then show ?thesis using 1 by simp
qed

lemma hv_zk2: assumes "H = (\<^bold>g (^) (w::nat), g' (^) w)" and "w \<noteq> 0" and "w < order \<G>"
  shows "epsilon_protocols_base.R H w = bind_spmf challenge (S2 H)"
  including monad_normalisation
proof-
  have  "R2 H w = bind_spmf challenge (S2 H)"
  proof-
    have g'_carrier: "g' \<in> carrier \<G>" using g' by simp
    have "R2 H w = do {
    let (h, h') = H;
      r \<leftarrow> sample_uniform (order \<G>);
    let (r, a, a') =  (r, \<^bold>g (^) r, g' (^) r);
    c \<leftarrow> samp_uni_units (order \<G>);
    let z = (w*c + r) mod (order \<G>);
    return_spmf ((a,a'),c, z)}"
      by(simp add: R2_def init_def)
    also have "... = do {
    let (h, h') = H;
    r \<leftarrow> sample_uniform (order \<G>);
    c \<leftarrow> samp_uni_units (order \<G>);
    let z = (w*c + r) mod (order \<G>);
    let a = \<^bold>g (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    return_spmf ((a,a'),c, z)}"
      apply(simp add: Let_def R2_def init_def)
      using assms xr' by(simp cong: bind_spmf_cong_simp)
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> map_spmf (\<lambda> r. (w*c + r) mod (order \<G>)) (sample_uniform (order \<G>));
    let a = \<^bold>g (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    return_spmf ((a,a'),c, z)}"
      by(simp add: bind_map_spmf Let_def o_def)
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> (sample_uniform (order \<G>));
    let a = \<^bold>g (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    return_spmf ((a,a'),c, z)}"
      by(simp add: samp_uni_plus_one_time_pad)
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> (sample_uniform (order \<G>));
    let a = \<^bold>g (^) ((z + (order \<G>)*(order \<G>) - w*c));
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    return_spmf ((a,a'),c, z)}"
      by(simp add: g' pow_generator_mod)
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> (sample_uniform (order \<G>));
      let a = \<^bold>g (^) z \<otimes> inv (h (^) c);
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c) mod (order \<G>));
    return_spmf ((a,a'),c, z)}"
      using h_sub assms by(simp cong: bind_spmf_cong_simp)
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> (sample_uniform (order \<G>));
      let a = \<^bold>g (^) z \<otimes> inv (h (^) c);
    let a' = g' (^) ((z + (order \<G>)*(order \<G>) - w*c));
    return_spmf ((a,a'),c, z)}"
      using g'_carrier pow_carrier_mod[of "g'"] by simp
    also have "... = do {
    let (h, h') = H;
    c \<leftarrow> samp_uni_units (order \<G>);
    z \<leftarrow> (sample_uniform (order \<G>));
      let a = \<^bold>g (^) z \<otimes> inv (h (^) c);
    let a' =  g' (^) z \<otimes> inv (h' (^) c);
    return_spmf ((a,a'),c, z)}"
      using h_sub2 assms by(simp cong: bind_spmf_cong_simp)
    ultimately show ?thesis
      unfolding challenge_def S2_def init_def
      by(simp add: split_def Let_def)
  qed
  thus ?thesis using R2_eq_R by simp
qed

lemma inverse: assumes "gcd w (order \<G>) = 1"
  shows "[w * (fst (bezw w (order \<G>))) = 1] (mod order \<G>)"
proof-
  have 2: "fst (bezw  w (order \<G>)) * w + snd (bezw w (order \<G>)) * int (order \<G>) = 1"
    using bezw_aux assms int_minus by presburger
  hence 3: "(fst (bezw  w (order \<G>)) * w + snd (bezw w (order \<G>)) * int (order \<G>)) mod (order \<G>) = 1 mod (order \<G>)"
    by (simp add: zmod_int)
  hence 4: "(fst (bezw w (order \<G>)) * w) mod (order \<G>) = 1 mod (order \<G>)"
    by simp
  hence 5:  "[(fst (bezw w (order \<G>))) * w  = 1] (mod order \<G>)"
    using 2 3 cong_int_def by auto
  then show ?thesis by(simp add: mult.commute)
qed

lemma witness_find:
  assumes "ya < order \<G>" and "yb < order \<G>" and "y < order \<G>" and w: "w < order \<G>" and "h = \<^bold>g (^) w" and "ya \<noteq> yb" and "w \<noteq> 0"
  shows "w = (if (ya > yb) then nat ((int ((w * ya + y) mod order \<G>) - int ((w * yb + y) mod order \<G>)) * fst (bezw (ya - yb) (order \<G>)) mod int (order \<G>))
else nat ((int ((w * yb + y) mod order \<G>) - int ((w * ya + y) mod order \<G>)) * fst (bezw (yb - ya) (order \<G>)) mod int (order \<G>)))"
proof(cases "ya > yb")
  case True
 have gcd: "gcd (ya - yb) (order \<G>) = 1"
  proof-
    have "(ya - yb) < order \<G>" and "(ya - yb) \<noteq> 0"
      apply(simp add: less_imp_diff_less assms True)
      using True by simp
    then show ?thesis using prime_field by blast
  qed
  have "[w*(ya - yb)*(fst (bezw (ya - yb) (order \<G>))) = (w*ya - w*yb)*(fst (bezw (ya - yb) (order \<G>)))] (mod (order \<G>))"
    by (simp add: diff_mult_distrib2 assms cong_nat_def)
  hence "[w*((ya - yb)*(fst (bezw (ya - yb) (order \<G>)))) = (w*ya - w*yb)*(fst (bezw (ya - yb) (order \<G>)))] (mod (order \<G>))"
    by (simp add: mult.assoc)
  hence "[w = (w*ya - w*yb)*(fst (bezw (ya - yb) (order \<G>)))] (mod (order \<G>))"
    by (metis (no_types, hide_lams) gcd inverse[of "ya - yb"] cong_scalar_int cong_sym_int cong_trans_int mult.commute mult.left_neutral)
  hence "[int w = (int w* int ya - int w* int yb)*(fst (bezw (ya - yb) (order \<G>)))] (mod (order \<G>))"
    by (simp add: True less_imp_le_nat of_nat_diff)
  hence "int w mod order \<G>  = (int w* int ya - int w* int yb)*(fst (bezw (ya - yb) (order \<G>))) mod (order \<G>)"
    using cong_int_def by blast
  hence "w mod order \<G>  = (int w* int ya - int w* int yb)*(fst (bezw (ya - yb) (order \<G>))) mod (order \<G>)"
    by (simp add: zmod_int)
  then show ?thesis using w
  proof -
    have f1: "\<forall>n na nb. int (nb + na) - int (nb + n) = int na - int n"
      by simp
    have "(int (w * ya) - int (w * yb)) * fst (bezw (ya - yb) (order \<G>)) mod int (order \<G>) = int w"
      using \<open>int (w mod order \<G>) = (int w * int ya - int w * int yb) * fst (bezw (ya - yb) (order \<G>)) mod int (order \<G>)\<close> w by force
    then show ?thesis
      using f1
    proof -
      have "nat ((int ((y + w * ya) mod order \<G>) - int ((y + w * yb) mod order \<G>)) * fst (bezw (if True then ya - yb else yb - ya) (order \<G>)) mod int (order \<G>)) = w"
        by (metis (no_types) \<open>(int (w * ya) - int (w * yb)) * fst (bezw (ya - yb) (order \<G>)) mod int (order \<G>) = int w\<close> \<open>\<forall>n na nb. int (nb + na) - int (nb + n) = int na - int n\<close> mod_diff_left_eq mod_diff_right_eq mod_mult_cong nat_int zmod_int)
      then show ?thesis
        by (simp add: True add.commute)
    qed
  qed
next
  case False
  have False': "yb > ya" using False assms
    using nat_neq_iff by blast
  have gcd: "gcd (yb - ya) (order \<G>) = 1"
  proof-
    have "(yb - ya) < order \<G>" and "(yb - ya) \<noteq> 0"
      using less_imp_diff_less assms apply blast
      using assms(6) zero_less_diff False' by blast
    then show ?thesis using prime_field by blast
  qed
  have "[w*(yb - ya)*(fst (bezw (yb - ya) (order \<G>))) = (w*yb - w*ya)*(fst (bezw (yb - ya) (order \<G>)))] (mod (order \<G>))"
    using assms cong_nat_def
    by (simp add: diff_mult_distrib2)
  then have "[w*((yb - ya)*(fst (bezw (yb - ya) (order \<G>)))) = (w*yb - w*ya)*(fst (bezw (yb - ya) (order \<G>)))] (mod (order \<G>))"
    by (simp add: mult.assoc)
  then have "[w = (w*yb - w*ya)*(fst (bezw (yb - ya) (order \<G>)))] (mod (order \<G>))"
    using gcd inverse[of "(yb - ya)"]
    by (metis (no_types, hide_lams) cong_scalar_int cong_sym_int cong_trans_int mult.commute mult.left_neutral)
  then have "[int w = (int w* int yb - int w* int ya)*(fst (bezw (yb - ya) (order \<G>)))] (mod (order \<G>))"
    by (simp add: False' less_imp_le_nat of_nat_diff)
  then have "int w mod order \<G>  = (int w* int yb - int w* int ya)*(fst (bezw (yb - ya) (order \<G>))) mod (order \<G>)"
    using cong_int_def by blast
  hence "w mod order \<G>  = (int w* int yb - int w* int ya)*(fst (bezw (yb - ya) (order \<G>))) mod (order \<G>)"
    by (simp add: zmod_int)
  then show ?thesis using w
  proof -
    have f1: "\<forall>n na nb. int (nb + na) - int (nb + n) = int na - int n"
      by simp
    have "(int (w * yb) - int (w * ya)) * fst (bezw (yb - ya) (order \<G>)) mod int (order \<G>) = int w"
      using \<open>int (w mod order \<G>) = (int w * int yb - int w * int ya) * fst (bezw (yb - ya) (order \<G>)) mod int (order \<G>)\<close> w by force
    then show ?thesis
      using f1
    proof -
      have "nat ((int ((y + w * yb) mod order \<G>) - int ((y + w * ya) mod order \<G>)) * fst (bezw (if True then yb - ya else ya - yb) (order \<G>)) mod int (order \<G>)) = w"
        by (metis (no_types) \<open>(int (w * yb) - int (w * ya)) * fst (bezw (yb - ya) (order \<G>)) mod int (order \<G>) = int w\<close> \<open>\<forall>n na nb. int (nb + na) - int (nb + n) = int na - int n\<close> mod_diff_left_eq mod_diff_right_eq mod_mult_cong nat_int zmod_int)
      then show ?thesis
        by (simp add: False add.commute)
    qed
  qed
qed

lemma honest_verifier_ZK2:
  shows "epsilon_protocols_base.honest_V_ZK H w"
    unfolding epsilon_protocols_base.honest_V_ZK_def R_def
    using  hv_zk2[of "H" "w"]
    by (metis prod.collapse)

lemma special_soundness:
  shows "epsilon_protocols_base.special_soundness h w"
proof-
  {assume w1: "w \<noteq> 0" and w2: "w < order \<G>"
    have "local.epsilon_protocols_base.special_soundness_game h w pk_adversary2 = return_spmf True"
      (is "?lhs = ?rhs")
  proof-
    have "?lhs = do {
      y \<leftarrow> sample_uniform (order \<G>);
      ya \<leftarrow> samp_uni_units (order \<G>);
      yb \<leftarrow> samp_uni_units_excl (order \<G>) ya;
      return_spmf (w = (if (ya > yb) then nat ((int ((w * ya + y) mod order \<G>) - int ((w * yb + y) mod order \<G>)) * fst (bezw (ya - yb) (order \<G>)) mod int (order \<G>))
          else nat ((int ((w * yb + y) mod order \<G>) - int ((w * ya + y) mod order \<G>)) * fst (bezw (yb - ya) (order \<G>)) mod int (order \<G>))))}"
       unfolding local.epsilon_protocols_base.special_soundness_game_def pk_adversary2_def
       by(simp add: response_def challenge_def init_def snd_challenge_def)
     then show ?thesis
       by(simp add: lossless_samp_uni_units lossless_samp_uni_units_excl witness_find w1 w2 bind_spmf_const lossless_samp_uni_excl lossless_samp_uni  lossless_weight_spmfD cong: bind_spmf_cong_simp)
  qed }
  then have "w \<noteq> 0 \<Longrightarrow> w < order \<G> \<Longrightarrow> spmf (local.epsilon_protocols_base.special_soundness_game h w pk_adversary2) True = 1"
     by simp
  then show ?thesis unfolding epsilon_protocols_base.special_soundness_def R_def by auto
qed

theorem "epsilon_protocols_base.\<Sigma>_protocol h w"
  by(simp add: epsilon_protocols_base.\<Sigma>_protocol_def completeness honest_verifier_ZK2 special_soundness)

end

locale asy_schnorr_2 =
 fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
 assumes schnorr_2: "\<And>n. schnorr_2 (\<G> n) x g'"
begin

sublocale schnorr_2 "(\<G> n)" for n by(simp add: schnorr_2)

theorem "epsilon_protocols_base.\<Sigma>_protocol n g' h w"
  by (simp add: completeness honest_verifier_ZK2 local.epsilon_protocols_base.\<Sigma>_protocol_def special_soundness)

end

end


section \<open>The Hadjicostas--Chapman formula\<close>
theory Hadjicostas_Chapman
  imports Zeta_Laurent_Expansion
begin

text \<open>
  In this section, we will derive a formula for the \<open>\<zeta>\<close> function that was conjectured by
  Hadjicostas~\cite{hadjicostas2004} and proven shortly afterwards by Chapman~\cite{chapman2004}.
  The formula is:
    \begin{align*}
    &\int_0^1 \int_0^1 \frac{(-\ln (xy))^z (1-x)}{1-xy}\ \text{d}x\,\text{d}y\\
      &\quad = \int_0^1 \frac{(-\ln u)^z(-\ln u + u - 1)}{1-u}\ \text{d}u\\
      &\quad = \Gamma(z + 2) \left(\zeta(z + 2) - \frac{1}{z+1}\right)
    \end{align*}
  for any \<open>z\<close> with $\mathfrak{R}(z) > -2$. In particular, setting $z = 1$, we can derive
  the following formula for the Euler--Mascheroni constant \<open>\<gamma>\<close>:
    \[-\int_0^1 \int_0^1 \frac{1-x}{(1-xy) \ln (xy)}\ \text{d}x\,\text{d}y = \gamma\]
  This formula was first proven by Sondow~\cite{sondow2002}.
\<close>

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

text \<open>
  We first define the integral for real \<open>z > -2\<close>. This is then a non-negative integral,
  so that we can ignore the issue of integrability and use the Lebesgue integral on the
  extended non-negative reals

  We first show the equivalence of the single-integral and the double-integral form.
\<close>

definition Hadjicostas_nn_integral :: "real \<Rightarrow> ennreal" where
  "Hadjicostas_nn_integral z =
     set_nn_integral lborel {0<..<1}
       (\<lambda>u. ennreal ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"

definition Hadjicostas_integral :: "complex \<Rightarrow> complex" where
  "Hadjicostas_integral z =
     (LBINT u=0..1. of_real (-ln u) powr z / of_real (1 - u) * of_real (-ln u + u - 1))"

lemma Hadjicostas_nn_integral_altdef:
  "Hadjicostas_nn_integral z =
     (\<integral>\<^sup>+(x,y)\<in>{0<..<1}\<times>{0<..<1}. ((-ln (x*y)) powr z * (1-x) / (1-x*y)) \<partial>lborel)"
proof -
  define f where "f \<equiv> (\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"
  let ?I = "Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
  let ?f = "\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1))"
  define D :: "(real \<times> real) set" where "D = {0<..<1} \<times> {0<..<1}"
  define D1 where "D1 = (SIGMA x:{0<..<1}. {0<..<(x::real)})"
  define D2 where "D2 = (SIGMA u:{0<..<1}. {u<..<(1::real)})"
  have [measurable]: "D1 \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
  proof -
    have "D1 = {x\<in>space (lborel \<Otimes>\<^sub>M lborel). snd x > 0 \<and> fst x > snd x \<and> fst x < 1}"
      by (auto simp: D1_def space_pair_measure)
    also have "\<dots> \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
      by measurable
    finally show ?thesis .
  qed
  have [measurable]: "D2 \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
  proof -
    have "D2 = {x\<in>space (lborel \<Otimes>\<^sub>M lborel). fst x > 0 \<and> fst x < snd x \<and> snd x < 1}"
      by (auto simp: D2_def space_pair_measure)
    also have "\<dots> \<in> sets (lborel \<Otimes>\<^sub>M lborel)"
      by measurable
    finally show ?thesis .
  qed

  have "(\<integral>\<^sup>+(x,y)\<in>D. ((-ln (x*y)) powr z * (1-x) / (1-x*y)) \<partial>lborel) =
          (\<integral>\<^sup>+x\<in>{0<..<1}. (\<integral>\<^sup>+y\<in>{0<..<1}. ((-ln (x*y)) powr z / (1-x*y) * (1-x)) \<partial>lborel) \<partial>lborel)"
    unfolding lborel_prod [symmetric] case_prod_unfold D_def
    by (subst lborel.nn_integral_fst[symmetric])
       (auto intro!: nn_integral_cong simp: indicator_def)
  also have "\<dots> = (\<integral>\<^sup>+x\<in>{0<..<1}. (\<integral>\<^sup>+u\<in>{0<..<x}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) \<partial>lborel)"
  proof (rule set_nn_integral_cong)
    fix x :: real assume x: "x \<in> space lborel \<inter> {0<..<1}"
    show "(\<integral>\<^sup>+y\<in>{0<..<1}. ((-ln (x*y)) powr z / (1-x*y) * (1-x)) \<partial>lborel) =
            (\<integral>\<^sup>+u\<in>{0<..<x}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)" using x
      by (subst lborel_distr_mult'[of "1/x"])
         (auto simp: nn_integral_density nn_integral_distr indicator_def field_simps
               simp flip: ennreal_mult' intro!: nn_integral_cong)
  qed auto
  also have "\<dots> = (\<integral>\<^sup>+(x,u)\<in>D1. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
    unfolding lborel_prod [symmetric] case_prod_unfold D_def
    by (subst lborel.nn_integral_fst[symmetric], measurable)
       (auto intro!: nn_integral_cong simp: indicator_def D1_def)
  also have "\<dots> = (\<integral>\<^sup>+(x,u). indicator D2 (u,x) * ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
    by (intro nn_integral_cong)  (auto simp: D1_def D2_def indicator_def split: if_splits)
  also have "\<dots> = (\<integral>\<^sup>+u\<in>{0<..<1}. (\<integral>\<^sup>+x\<in>{u<..<1}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) \<partial>lborel)"
    unfolding case_prod_unfold lborel_prod [symmetric]
    by (subst lborel_pair.nn_integral_snd [symmetric], measurable)
       (auto intro!: nn_integral_cong simp: D2_def indicator_def)
  also have "\<dots> = (\<integral>\<^sup>+u\<in>{0<..<1}. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)) \<partial>lborel)"
  proof (intro set_nn_integral_cong refl)
    fix u :: real assume u: "u \<in> space lborel \<inter> {0<..<1}"
    let ?F = "\<lambda>x. (- ln u) powr z / (1 - u) * (ln x - x)"
    have "(\<integral>\<^sup>+x\<in>{u<..<1}. ennreal ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) =
            (\<integral>\<^sup>+x\<in>{u..1}. ennreal ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel)"
      by (rule nn_integral_cong_AE, rule AE_I[of _ _ "{u,1}"])
         (auto simp: emeasure_lborel_countable indicator_def)
    also have "\<dots> = ennreal (?F 1 - ?F u)"
      using u by (intro nn_integral_FTC_Icc) (auto intro!: derivative_eq_intros simp: divide_simps)
    also have "?F 1 - ?F u = (-ln u) powr z / (1 - u) * (-ln u + u - 1)"
      using u by (simp add: divide_simps) (simp add: algebra_simps)?
    finally show "(\<integral>\<^sup>+x\<in>{u<..<1}. ((- ln u) powr z / (1 - u) * (1 - x) / x) \<partial>lborel) = ennreal \<dots>" .
  qed
  also have "\<dots> = Hadjicostas_nn_integral z"
    by (simp add: Hadjicostas_nn_integral_def)
  finally show ?thesis by (simp add: D_def)
qed

text \<open>
  We now solve the single integral for real \<open>z > -1\<close>.
\<close>
lemma Hadjicostas_Chapman_aux:
  fixes z :: real
  assumes z: "z > -1"
  defines "f \<equiv> (\<lambda>u. ((-ln u) powr z / (1 - u) * (-ln u + u - 1)))"
  shows   "(f has_integral (Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1)))) {0<..<1}"
proof -
  let ?I = "Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
  have nonneg: "1 \<le> x + exp (- x)" if "x \<ge> 0" for x :: real
  proof -
    have "x + (1 + (-x)) \<le> x + exp (-x)"
      by (intro add_left_mono exp_ge_add_one_self)
    thus ?thesis by simp
  qed

  have eq: "((\<lambda>t::real. exp (-t)) ` {0<..}) = {0<..<1}"
  proof safe
    fix x :: real assume x: "x \<in> {0<..<1}"
    hence "x = exp (-(-ln x))" and "-ln x \<in> {0<..}"
      by auto
    thus "x \<in> (\<lambda>t. exp (-t)) ` {0<..}" by blast
  qed auto

  have I: "((\<lambda>x. x powr (z+1) / (exp x - 1) - x powr z / exp x) has_integral ?I) {0<..}"
  proof -
    from z have "z + 1 \<notin> \<real>\<^sub>\<le>\<^sub>0"
      by (auto simp: nonpos_Reals_def)
    hence z': "z + 1 \<notin> \<int>\<^sub>\<le>\<^sub>0"
      using nonpos_Ints_subset_nonpos_Reals by blast
    have "((\<lambda>x. x powr (z + 2 - 1) / (exp x - 1) - x powr (z + 1 - 1) / exp x)
            has_integral (Gamma (z + 2) * Re (zeta (z + 2)) - Gamma (z + 1))) {0<..}" using z
      by (intro has_integral_diff Gamma_integral_real' Gamma_times_zeta_has_integral_real) auto
    also have "Gamma (z + 2) * Re (zeta (z + 2)) - Gamma (z + 1) =
                 Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1))"
      using Gamma_plus1[of "z+1"] z z' by (auto simp: field_simps)
    finally show ?thesis
      by (simp add: add_ac)
  qed
  also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>-exp (-x)\<bar> * f (exp (-x))) has_integral ?I) {0<..}"
    unfolding f_def
    apply (intro has_integral_cong)
    apply (auto simp: field_simps powr_add powr_def exp_add)
    apply (simp flip: exp_add)
    done
  finally have *: "((\<lambda>x. \<bar>-exp (-x)\<bar> * f (exp (-x))) has_integral ?I) {0<..}" .

  have "((\<lambda>x. \<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x))) absolutely_integrable_on {0<..}) \<and>
                  integral {0<..} (\<lambda>x. \<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x))) = ?I"
  proof (intro conjI nonnegative_absolutely_integrable_1)
    fix x :: real assume x: "x \<in> {0<..}"
    thus "\<bar>-exp (-x)\<bar> *\<^sub>R f (exp (-x)) \<ge> 0"
      unfolding f_def using nonneg
      by (intro scaleR_nonneg_nonneg mult_nonneg_nonneg divide_nonneg_nonneg) auto
  qed (use * in \<open>simp_all add: has_integral_iff\<close>)

  also have "?this \<longleftrightarrow> f absolutely_integrable_on (\<lambda>x. exp (- x)) ` {0<..} \<and>
                       integral ((\<lambda>x. exp (- x)) ` {0<..}) f = ?I"
    by (intro has_absolute_integral_change_of_variables_1')
       (auto intro!: derivative_eq_intros inj_onI)
  also have "(\<lambda>x::real. exp (- x)) ` {0<..} = {0<..<1}"
    by (fact eq)
  finally show "(f has_integral ?I) {0<..<1}"
    by (auto simp: has_integral_iff dest: set_lebesgue_integral_eq_integral)
qed

lemma real_zeta_ge_one_over_minus_one:
  fixes z :: real
  assumes z: "z > 1"
  shows "Re (zeta (complex_of_real z)) \<ge> 1 / (z - 1)"
proof -
  have ineq: "1 \<le> x - ln x" if "x \<in> {0<..<1}" for x :: real
    using ln_le_minus_one[of x] that by simp
  have *: "((\<lambda>u. (- ln u) powr (z - 2) * (u - ln u - 1) / (1 - u)) has_integral
           Gamma z * (Re (zeta (complex_of_real z)) - 1 / (z - 1))) {0<..<1}"
    using Hadjicostas_Chapman_aux[of "z - 2"] z by simp
  from ineq have "Gamma z * (Re (zeta (complex_of_real z)) - 1 / (z - 1)) \<ge> 0"
    by (intro has_integral_nonneg[OF *] z mult_nonneg_nonneg divide_nonneg_nonneg) auto
  moreover have "Gamma z > 0"
    using assms by (intro Gamma_real_pos) auto
  ultimately show "Re (zeta (complex_of_real z)) \<ge> 1 / (z - 1)"
    by (subst (asm) zero_le_mult_iff) auto
qed

text \<open>
  We now have the formula for real \<open>z > -1\<close>.
\<close>
lemma Hadjicostas_Chapman_formula_real:
  fixes z :: real
  assumes z: "z > -1"
  shows   "Hadjicostas_nn_integral z =
             ennreal (Gamma (z + 2) * (Re (zeta (z + 2)) - 1 / (z + 1)))"
proof -
  have nonneg: "1 \<le> x - ln x" if "x > 0" "x < 1" for x :: real
  proof -
    have "ln x + (1 + ln x) \<le> ln x + exp (ln x)"
      by (intro add_left_mono exp_ge_add_one_self)
    thus ?thesis using that by (simp add: exp_minus)
  qed
  show ?thesis
    unfolding Hadjicostas_nn_integral_def using nonneg Hadjicostas_Chapman_aux[OF z]
    by (intro nn_integral_has_integral_lebesgue' mult_nonneg_nonneg divide_nonneg_nonneg) auto
qed

subsection \<open>Analyticity of the integral\<close>

text \<open>
  To extend the formula to its full domain of validity (any complex \<open>z\<close> with
  $\mathfrak{R}(z)>-2$), we will use analytic continuation. To do this, we first
  have to show that the integral is an analytic function of \<open>z\<close> on that domain.
  This is unfortunately somewhat involved, since the integral is an improper one
  and we first need to show uniform convergence so that we can pull the derivative
  inside the integral sign.

  We will use the single-integral form so that we only have to deal with one integral
  and not two.
\<close>

context
  fixes f :: "complex \<Rightarrow> real \<Rightarrow> complex"
  defines "f \<equiv> (\<lambda>z u. of_real (-ln u) powr z / of_real (1 - u) * of_real (-ln u + u - 1))"
begin

context
  fixes x y :: real and g1 g2 :: "real \<Rightarrow> real"
  assumes "x > -2"
  defines "g1 \<equiv> (\<lambda>x. (- ln x) powr y * (x - ln x - 1) / (1 - x))"
  defines "g2 \<equiv> (\<lambda>u. (-ln u) powr x * (u - ln u - 1) / (1 - u))"
begin

lemma integrable_bound1:
  "interval_lebesgue_integrable lborel 0 (ereal (exp (- 1))) g1"
  unfolding zero_ereal_def
proof (rule interval_lebesgue_integrable_bigo_left)
  show "g1 \<in> O[at_right 0](\<lambda>u. u powr (-1/2))"
    unfolding g1_def by real_asymp
  show "continuous_on {0<..exp(-1)} g1"
    unfolding g1_def by (auto intro!: continuous_intros)
  have "set_integrable lborel (einterval 0 (exp (-1))) (\<lambda>u. u powr (-1/2))"
  proof (rule interval_integral_FTC_nonneg)
    fix u :: real assume u: "0 < ereal u" "ereal u < ereal (exp (-1))"
    show "((\<lambda>u. 2 * u powr (1/2)) has_field_derivative (u powr (-1/2))) (at u)"
      using u by (auto intro!: derivative_eq_intros simp: power2_eq_square)
    show "isCont (\<lambda>u. u powr (-1/2)) u"
      using u by (auto intro!: continuous_intros)
  next
    show "(((\<lambda>u. 2 * u powr (1/2)) \<circ> real_of_ereal) \<longlongrightarrow> 2 * exp (-1) powr (1/2))
            (at_left (ereal (exp (- 1))))"
      unfolding ereal_tendsto_simps by real_asymp
    show "(((\<lambda>u. 2 * u powr (1/2)) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_right 0)"
      unfolding zero_ereal_def unfolding ereal_tendsto_simps by real_asymp
  qed auto
  thus "interval_lebesgue_integrable lborel (ereal 0) (ereal (exp (- 1)))
          (\<lambda>u. u powr (-1/2))"
    by (simp add: interval_lebesgue_integrable_def zero_ereal_def)
qed (auto simp add: g1_def set_borel_measurable_def)

lemma integrable_bound2:
  "interval_lebesgue_integrable lborel (exp (-1)) 1 g2"
      unfolding one_ereal_def
proof (rule interval_lebesgue_integrable_bigo_right)
  show "g2 \<in> O[at_left 1](\<lambda>u. (1 - u) powr (x + 1))"
    unfolding g2_def by real_asymp
  have "ln x \<noteq> 0" if "x \<in> {exp (-1)..<1}" for x :: real
  proof -
    have "0 < exp (-1 :: real)" by simp
    also have "\<dots> \<le> x" using that by auto
    finally have "x > 0" .
    from that \<open>x > 0\<close> have "ln x < ln 1"
      by (subst ln_less_cancel_iff) auto
    thus "ln x \<noteq> 0" by simp
  qed
  thus "continuous_on {exp (- 1)..<1} g2"
    unfolding g2_def by (auto intro!: continuous_intros)
  let ?F = "(\<lambda>u. -1 / (x + 2) * (1 - u) powr (x + 2))"
  have "set_integrable lborel (einterval (exp (-1)) 1) (\<lambda>u. (1 - u) powr (x + 1))"
  proof (rule interval_integral_FTC_nonneg[where F = ?F])
    fix u :: real assume u: "ereal (exp (-1)) < ereal u" "ereal u < 1"
    show "(?F has_field_derivative (1 - u) powr (x + 1)) (at u)"
      using u \<open>x > -2\<close> by (auto intro!: derivative_eq_intros simp: one_ereal_def add_ac)
    show "isCont (\<lambda>u. (1 - u) powr (x + 1)) u"
      using u by (auto intro!: continuous_intros)
  next
    show "(((\<lambda>u. - 1 / (x + 2) * (1 - u) powr (x + 2)) \<circ> real_of_ereal) \<longlongrightarrow>
            - 1 / (x + 2) * (1 - exp (-1)) powr (x + 2)) (at_right (ereal (exp (- 1))))"
      unfolding ereal_tendsto_simps by real_asymp
    show "(((\<lambda>u. - 1 / (x + 2) * (1 - u) powr (x + 2)) \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_left 1)"
      unfolding one_ereal_def unfolding ereal_tendsto_simps
      using \<open>x > -2\<close> by real_asymp
  qed auto
  thus "interval_lebesgue_integrable lborel (ereal (exp (- 1)))
          (ereal 1) (\<lambda>u. (1 - u) powr (x + 1))"
    by (simp add: interval_lebesgue_integrable_def one_ereal_def)
qed (auto simp add: g2_def set_borel_measurable_def)

lemma bound2:
  "norm (f z u) \<le> g2 u" if z: "Re z \<in> {x..y}" and u: "u \<in> {exp (-1)<..<1}" for z u
proof -
  have "0 < exp (-1::real)" by simp
  also have "\<dots> \<le> u" using u by (simp add: einterval_def)
  finally have "u > 0" .

  from u \<open>u > 0\<close> have ln_u: "ln u > ln (exp (-1))"
    by (subst ln_less_cancel_iff) (auto simp: einterval_def)
  from z u \<open>u > 0\<close> have "norm (f z u) = (- ln u) powr Re z * \<bar>u - ln u - 1\<bar> / (1 - u)"
    unfolding f_def norm_mult norm_divide norm_of_real
    by (simp add: norm_powr_real_powr einterval_def)
  also have "\<bar>u - ln u - 1\<bar> = u - ln u - 1"
    using u \<open>u > 0\<close> ln_add_one_self_le_self2[of "u - 1"] by (simp add: einterval_def)
  also have "(- ln u) powr Re z * (u - ln u - 1) / (1 - u) \<le>
               (- ln u) powr x * (u - ln u - 1) / (1 - u)"
    using z u \<open>u > 0\<close> ln_u ln_add_one_self_le_self2[of "u - 1"]
    by (intro mult_right_mono divide_right_mono powr_mono') (auto simp: einterval_def)
  finally show "norm (f z u) \<le> g2 u" by (simp add: g2_def)
qed

lemma integrable2_aux: "interval_lebesgue_integrable lborel (exp (-1)) 1 (f z)"
    if z: "Re z \<in> {x..y}" for z
proof -
  have "set_integrable lborel {exp (-1)<..<1} (f z)"
  proof (rule set_integrable_bound[OF _ _ AE_I2[OF impI]])
    fix u :: real assume "u \<in> {exp (-1)<..<1}"
    hence "norm (f z u) \<le> g2 u" using z by (intro bound2) auto
    also have "\<dots> \<le> norm (g2 u)" by simp
    finally show "norm (f z u) \<le> norm (g2 u)" .
  qed (use integrable_bound2 in \<open>simp_all add: interval_lebesgue_integrable_def
         one_ereal_def set_borel_measurable_def f_def\<close>)
  thus ?thesis by (simp add: interval_lebesgue_integrable_def one_ereal_def)
qed

lemma uniform_limit2:
  "uniform_limit {z. Re z \<in> {x..y}}
        (\<lambda>a z. LBINT u=exp (-1)..a. f z u)
        (\<lambda>z. LBINT u=exp (-1)..1. f z u) (at_left 1)"
  by (intro uniform_limit_interval_integral_right[of _ _ g2] AE_I2 impI)
     (use bound2 integrable_bound2 in \<open>simp_all add: einterval_def f_def set_borel_measurable_def\<close>)

lemma uniform_limit2':
    "uniform_limit {z. Re z \<in> {x..y}}
          (\<lambda>n z. LBINT u=exp (-1)..ereal (1-(1/2)^Suc n). f z u)
          (\<lambda>z. LBINT u=exp (-1)..1. f z u) sequentially"
proof (rule filterlim_compose[OF uniform_limit2])
  have "filterlim (\<lambda>n. 1 - (1/2)^Suc n :: real) (at_left 1) sequentially"
    by real_asymp
  hence "filtermap ereal (filtermap (\<lambda>n. (1 - (1 / 2) ^ Suc n)) sequentially) \<le>
        filtermap ereal (at_left 1)"
    unfolding filterlim_def by (rule filtermap_mono)
  thus "filterlim (\<lambda>n. ereal (1 - (1/2)^Suc n)) (at_left 1) sequentially"
    unfolding one_ereal_def at_left_ereal by (simp add: filterlim_def filtermap_filtermap)
qed

lemma bound1: "norm (f z u) \<le> g1 u" if z: "Re z \<in> {x..y}" and u: "u \<in> {0<..<exp (-1)}" for z u
proof -
  from u have "u \<le> exp (-1)" by (simp add: einterval_def)
  also have "exp (-1) < exp (0::real)"
    by (subst exp_less_cancel_iff) auto
  also have "exp (0::real) = 1" by simp
  finally have "u < 1" .
  from u have "ln u < ln (exp (-1))"
    by (subst ln_less_cancel_iff) (auto simp: einterval_def)
  hence ln_u: "ln u < -1" by simp
  from z u \<open>u < 1\<close> have "norm (f z u) = (- ln u) powr Re z * \<bar>u - ln u - 1\<bar> / (1 - u)"
    unfolding f_def norm_mult norm_divide norm_of_real
    by (simp add: norm_powr_real_powr einterval_def)
  also have "\<bar>u - ln u - 1\<bar> = u - ln u - 1"
    using u ln_add_one_self_le_self2[of "u - 1"] by (simp add: einterval_def)
  also have "(- ln u) powr Re z * (u - ln u - 1) / (1 - u) \<le>
               (- ln u) powr y * (u - ln u - 1) / (1 - u)"
    using z u ln_u \<open>u < 1\<close>
    by (intro mult_right_mono divide_right_mono powr_mono) (auto simp: einterval_def)
  finally show "norm (f z u) \<le> g1 u" by (simp add: g1_def)
qed

lemma integrable1_aux: "interval_lebesgue_integrable lborel 0 (exp (-1)) (f z)"
  if z: "Re z \<in> {x..y}" for z
proof -
  have "set_integrable lborel {0<..<exp (-1)} (f z)"
  proof (rule set_integrable_bound[OF _ _ AE_I2[OF impI]])
    fix u :: real assume "u \<in> {0<..<exp (-1)}"
    hence "norm (f z u) \<le> g1 u" using z by (intro bound1) auto
    also have "\<dots> \<le> norm (g1 u)" by simp
    finally show "norm (f z u) \<le> norm (g1 u)" .
  qed (use integrable_bound1 in \<open>simp_all add: interval_lebesgue_integrable_def
         zero_ereal_def set_borel_measurable_def f_def\<close>)
  thus ?thesis by (simp add: interval_lebesgue_integrable_def zero_ereal_def)
qed

lemma uniform_limit1:
  "uniform_limit {z. Re z \<in> {x..y}}
        (\<lambda>a z. LBINT u=a..exp (-1). f z u)
        (\<lambda>z. LBINT u=0..exp (-1). f z u) (at_right 0)"
  by (intro uniform_limit_interval_integral_left[of _ _ g1] AE_I2 impI)
     (use bound1 integrable_bound1 in \<open>simp_all add: einterval_def f_def set_borel_measurable_def\<close>)

lemma uniform_limit1':
    "uniform_limit {z. Re z \<in> {x..y}}
          (\<lambda>n z. LBINT u=ereal ((1/2)^Suc n)..exp (-1). f z u)
          (\<lambda>z. LBINT u=0..exp (-1). f z u) sequentially"
proof (rule filterlim_compose[OF uniform_limit1])
  have "filterlim (\<lambda>n. (1/2)^Suc n :: real) (at_right 0) sequentially"
    by real_asymp
  hence "filtermap ereal (filtermap (\<lambda>n. ((1 / 2) ^ Suc n)) sequentially) \<le>
        filtermap ereal (at_right 0)"
    unfolding filterlim_def by (rule filtermap_mono)
  thus "filterlim (\<lambda>n. ereal ((1/2)^Suc n)) (at_right 0) sequentially"
    unfolding zero_ereal_def at_right_ereal by (simp add: filterlim_def filtermap_filtermap)
qed

end

text \<open>
  With all of the above bounds, we have shown that the integral exists for any
  \<open>z\<close> with $\mathfrak{R}(z) > -2$.
\<close>
theorem Hadjicostas_integral_integrable: "interval_lebesgue_integrable lborel 0 1 (f z)"
  if z: "Re z > -2"
proof -
  from dense[OF z] obtain x where x: "x > -2" "Re z > x" by blast
  have "interval_lebesgue_integrable lborel 0 (exp(-1)) (f z)"
    by (rule integrable1_aux[of x _ "Re z + 1"]) (use x in auto)
  moreover have "interval_lebesgue_integrable lborel (exp(-1)) 1 (f z)"
    by (rule integrable2_aux[of x _ "Re z + 1"]) (use x in auto)
  ultimately show "interval_lebesgue_integrable lborel 0 1 (f z)"
    by (rule interval_lebesgue_integrable_combine) (auto simp: f_def set_borel_measurable_def)
qed

lemma integral_holo_aux:
  assumes ab: "a > 0" "a \<le> b" "b < 1"
  shows "(\<lambda>z. LBINT u=ereal a..ereal b. f z u) holomorphic_on A"
proof -
  define f' :: "complex \<Rightarrow> real \<Rightarrow> complex"
    where "f' \<equiv> (\<lambda>z u. ln (-ln u) * f z u)"
  note [derivative_intros] = has_field_derivative_complex_powr_right'

  have "(\<lambda>z. integral (cbox a b) (f z)) holomorphic_on UNIV"
  proof (rule leibniz_rule_holomorphic[of _ _ _ _ f'], goal_cases)
    case (1 z t)
    show ?case unfolding f_def
      apply (insert 1 ab)
      apply (rule derivative_eq_intros refl | simp)+
      apply (auto simp: f'_def field_simps f_def Ln_of_real)
      done
  next
    from ab show "continuous_on (UNIV \<times> cbox a b) (\<lambda>(z, t). f' z t)"
      by (auto simp: case_prod_unfold f'_def f_def Ln_of_real intro!: continuous_intros)
  next
    fix z :: complex
    show "f z integrable_on cbox a b"
      unfolding f_def f'_def using ab
      by (intro integrable_continuous continuous_intros) auto
  qed (auto simp: convex_halfspace_Re_gt)
  also have "(\<lambda>z. integral (cbox a b) (f z)) = (\<lambda>z. \<integral>u\<in>cbox a b. f z u \<partial>lborel)"
  proof (intro ext set_borel_integral_eq_integral(2) [symmetric])
    fix z :: complex
    show "complex_set_integrable lborel (cbox a b) (f z)"
      unfolding f_def using ab
      by (intro continuous_on_imp_set_integrable_cbox continuous_intros) (auto simp: Ln_of_real)
  qed
  also have "\<dots> = (\<lambda>z. LBINT u=a..b. f z u)"
    using ab by (simp add: interval_integral_Icc)
  finally show ?thesis by (rule holomorphic_on_subset) auto
qed

lemma integral_holo:
  assumes ab: "min a b > 0" "max a b < 1"
  shows "(\<lambda>z. LBINT u=ereal a..ereal b. f z u) holomorphic_on A"
proof (cases "a \<le> b")
  case True
  thus ?thesis using assms integral_holo_aux[of a b] by auto
next
  case False
  have "(\<lambda>z. -(LBINT u=ereal b..ereal a. f z u)) holomorphic_on A"
    using False assms by (intro holomorphic_intros integral_holo_aux) auto
  thus ?thesis by (subst interval_integral_endpoints_reverse)
qed

lemma holo1: "(\<lambda>z. LBINT u=0..exp (-1). f z u) holomorphic_on {z. Re z > -2}"
proof (rule holomorphic_uniform_sequence
    [where f = "(\<lambda>n z. LBINT u=ereal ((1/2)^Suc n)..exp (-1). f z u)"], goal_cases)
  case (3 z)
  define \<epsilon> where "\<epsilon> = (Re z + 2) / 2"
  from 3 have "\<epsilon> > 0" by (auto simp: \<epsilon>_def)
  have subset: "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}"
  proof safe
    fix s assume s: "s \<in> cball z \<epsilon>"
    have "\<bar>Re (s - z)\<bar> \<le> norm (s - z)" by (rule abs_Re_le_cmod)
    also have "\<dots> \<le> \<epsilon>" using s by (simp add: dist_norm norm_minus_commute)
    finally show "Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}" by auto
  qed

  show ?case
  proof (rule exI[of _ \<epsilon>], intro conjI)
    have "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}" by fact
    also have "\<dots> \<subseteq> {s. Re s > -2}"
      using 3 by (auto simp: \<epsilon>_def field_simps)
    finally show "cball z \<epsilon> \<subseteq> {s. Re s > -2}" .
  next
    from 3 have "Re z - \<epsilon> > -2" by (simp add: \<epsilon>_def field_simps)
    thus "uniform_limit (cball z \<epsilon>) (\<lambda>n z. LBINT u=ereal ((1 / 2) ^ Suc n)..ereal (exp (- 1)). f z u)
            (\<lambda>z. LBINT u=0..ereal (exp(-1)). f z u) sequentially"
      using uniform_limit_on_subset[OF uniform_limit1' subset] by simp
  qed fact+
next
  fix n :: nat
  have "(1 / 2) ^ Suc n < (1 / 2 :: real) ^ 0"
    by (subst power_strict_decreasing_iff) auto
  thus "(\<lambda>z. LBINT u=ereal ((1 / 2) ^ Suc n)..ereal (exp (- 1)). f z u) holomorphic_on {z. Re z > -2}"
    by (intro integral_holo) auto
qed (auto simp: open_halfspace_Re_gt)

lemma holo2: "(\<lambda>z. LBINT u=exp (-1)..1. f z u) holomorphic_on {z. Re z > -2}"
proof (rule holomorphic_uniform_sequence
    [where f = "(\<lambda>n z. LBINT u=exp (-1)..ereal (1-(1/2)^Suc n). f z u)"], goal_cases)
  case (3 z)
  define \<epsilon> where "\<epsilon> = (Re z + 2) / 2"
  from 3 have "\<epsilon> > 0" by (auto simp: \<epsilon>_def)
  have subset: "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}"
  proof safe
    fix s assume s: "s \<in> cball z \<epsilon>"
    have "\<bar>Re (s - z)\<bar> \<le> norm (s - z)" by (rule abs_Re_le_cmod)
    also have "\<dots> \<le> \<epsilon>" using s by (simp add: dist_norm norm_minus_commute)
    finally show "Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}" by auto
  qed

  show ?case
  proof (rule exI[of _ \<epsilon>], intro conjI)
    have "cball z \<epsilon> \<subseteq> {s. Re s \<in> {Re z - \<epsilon>..Re z + \<epsilon>}}" by fact
    also have "\<dots> \<subseteq> {s. Re s > -2}"
      using 3 by (auto simp: \<epsilon>_def field_simps)
    finally show "cball z \<epsilon> \<subseteq> {s. Re s > -2}" .
  next
    from 3 have "Re z - \<epsilon> > -2" by (simp add: \<epsilon>_def field_simps)
    thus "uniform_limit (cball z \<epsilon>) (\<lambda>n z. LBINT u=ereal (exp (- 1))..ereal (1-(1/2)^Suc n). f z u)
            (\<lambda>z. LBINT u=ereal (exp(-1))..1. f z u) sequentially"
      using uniform_limit_on_subset[OF uniform_limit2' subset] by simp
  qed fact+
next
  fix n :: nat
  have "(1 / 2) ^ Suc n < (1 / 2 :: real) ^ 0"
    by (subst power_strict_decreasing_iff) auto
  thus "(\<lambda>z. LBINT u=ereal (exp (-1))..ereal (1-(1/2)^Suc n). f z u) holomorphic_on {z. Re z > -2}"
    by (intro integral_holo) auto
qed (auto simp: open_halfspace_Re_gt)

text \<open>
  Finally, we have shown that Hadjicostas's integral is an analytic function
  of \<open>z\<close> in the domain $\mathfrak{R}(z) > -2$.
\<close>
lemma holomorphic_Hadjicostas_integral:
  "Hadjicostas_integral holomorphic_on {z. Re z > -2}"
proof -
  have "(\<lambda>z. (LBINT u=0..exp(-1). f z u) + (LBINT u=exp(-1)..1. f z u))
          holomorphic_on {z. Re z > -2}"
    by (intro holomorphic_intros holo1 holo2)
  also have "?this \<longleftrightarrow> (\<lambda>z. LBINT u=0..1. f z u) holomorphic_on {z. Re z > -2}"
    using Hadjicostas_integral_integrable
    by (intro holomorphic_cong interval_integral_sum)
       (simp_all add: zero_ereal_def one_ereal_def min_def max_def)
  also have "(\<lambda>z. LBINT u=0..1. f z u) = Hadjicostas_integral"
    by (simp add: Hadjicostas_integral_def[abs_def] f_def)
  finally show ?thesis .
qed

lemma analytic_Hadjicostas_integral:
  "Hadjicostas_integral analytic_on {z. Re z > -2}"
  by (simp add: analytic_on_open open_halfspace_Re_gt holomorphic_Hadjicostas_integral)

end

subsection \<open>Analytic continuation and main result\<close>

text \<open>
  Since we have already shown the formula for any real \<open>z > -1\<close> and e.\,g.\ 0 is a limit
  point of that set, it extends to the full domain by analytic continuation.

  As a caveat, note that $\zeta(s)$ is \<^emph>\<open>not\<close> analytic at \<open>z = 1\<close>, so that we use
  an analytic continuation of $\zeta(z) - \frac{1}{z-1}$ to state the formula. This
  continuation is @{term "pre_zeta 1"}.
\<close>
lemma Hadjicostas_Chapman_formula_aux:
  assumes z: "Re z > -2"
  shows   "Hadjicostas_integral z = Gamma (z + 2) * pre_zeta 1 (z + 2)"
    (is "_ z = ?f z")
proof (rule analytic_continuation'[of Hadjicostas_integral])
  show "Hadjicostas_integral holomorphic_on {z. Re z > -2}"
    by (rule holomorphic_Hadjicostas_integral)
  show "connected {z. Re z > -2}"
    by (intro convex_connected convex_halfspace_Re_gt)
  show "open {z. Re z > -2}"
    by (auto simp: open_halfspace_Re_gt)
  show "{z. Re z > -1 \<and> Im z = 0} \<subseteq> {z. Re z > -2}" and "0 \<in> {z. Re z > -2}"
    by auto
  have "\<forall>n. 1 / (of_nat (Suc n)) \<in> {z. Re z > -1 \<and> Im z = 0} - {0}"
    by (auto simp: field_simps simp flip: of_nat_Suc)
  moreover have "(\<lambda>n. 1 / of_nat (Suc n) :: complex) \<longlonglongrightarrow> 0"
    by (rule tendsto_divide_0[OF tendsto_const] filterlim_compose[OF tendsto_of_nat] filterlim_Suc)+
  ultimately show "0 islimpt {z. Re z > -1 \<and> Im z = 0}"
    unfolding islimpt_sequential
    by (intro exI[of _ "\<lambda>n. 1 / of_nat (Suc n) :: complex"]) simp
  show "?f holomorphic_on {z. - 2 < Re z}"
  proof (intro holomorphic_intros)
    fix z assume z: "z \<in> {z. Re z > -2}"
    hence "z + 2 \<notin> \<real>\<^sub>\<le>\<^sub>0" by (auto elim!: nonpos_Reals_cases simp: complex_eq_iff)
    thus "z + 2 \<notin> \<int>\<^sub>\<le>\<^sub>0" using nonpos_Ints_subset_nonpos_Reals by blast
  qed auto
next
  fix s assume s: "s \<in> {z. - 1 < Re z \<and> Im z = 0}"
  hence "s + 2 \<noteq> 1" by (simp add: algebra_simps complex_eq_iff)
  have ineq: "x - ln x \<ge> 1" if "x \<in> {0<..<1}" for x :: real
    using ln_le_minus_one[of x] that by (simp add: algebra_simps)
  define x where "x = Re s"
  from s have x: "x > -1" and [simp]: "s = of_real x"
    by (auto simp: x_def complex_eq_iff)
  have "Hadjicostas_integral s = (LBINT u=0..1. of_real ((-ln u) powr x / (1-u) * (-ln u + u - 1)))"
    unfolding Hadjicostas_integral_def
    by (intro interval_lebesgue_integral_cong) (auto simp: einterval_def powr_Reals_eq)
  also have "\<dots> = of_real (LBINT u=0..1. (-ln u) powr x / (1-u) * (-ln u + u - 1))"
    by (subst interval_lebesgue_integral_of_real) auto
  also have "(LBINT u=0..1. (- ln u) powr x / (1 - u) * (- ln u + u - 1)) =
             (\<integral>u. (- ln u) powr x / (1-u) * (- ln u + u - 1) * indicator {0<..<1} u \<partial>lborel)"
    by (simp add: interval_integral_Ioo zero_ereal_def one_ereal_def set_lebesgue_integral_def mult_ac)
  also have "\<dots> = enn2real (Hadjicostas_nn_integral x)"
    unfolding Hadjicostas_nn_integral_def using ineq
    by (subst integral_eq_nn_integral)
       (auto intro!: AE_I2 divide_nonneg_nonneg mult_nonneg_nonneg arg_cong[where f = enn2real]
               nn_integral_cong simp: indicator_def)
  also have "\<dots> = enn2real (ennreal (Gamma (x + 2) * (Re (zeta (x + 2)) - 1 / (x + 1))))"
    using x by (subst Hadjicostas_Chapman_formula_real) auto
  also have "\<dots> = Gamma (x + 2) * (Re (zeta (x + 2)) - 1 / (x + 1))"
    using x real_zeta_ge_one_over_minus_one[of "x + 2"]
    by (intro enn2real_ennreal mult_nonneg_nonneg Gamma_real_nonneg) (auto simp: add_ac)
  also have "complex_of_real \<dots> = Gamma (s + 2) * (zeta (s + 2) -  1 / (s + 1))"
    using x Gamma_complex_of_real[of "x + 2"] by (simp add: zeta_real')
  also have "(zeta (s + 2) -  1 / (s + 1)) = pre_zeta 1 (s + 2)"
    using \<open>s + 2 \<noteq> 1\<close> by (subst zeta_minus_pole_eq [symmetric]) (auto simp flip: of_nat_Suc)
  finally show "Hadjicostas_integral s = Gamma (s + 2) * pre_zeta 1 (s + 2)" .
qed (use assms in auto)

text \<open>
  The following form and the corollary are perhaps a bit nicer to read.
\<close>
theorem Hadjicostas_Chapman_formula:
  assumes z: "Re z > -2" "z \<noteq> -1"
  shows   "Hadjicostas_integral z = Gamma (z + 2) * (zeta (z + 2) - 1 / (z + 1))"
proof -
  from z have "z + 1 \<noteq> 0"
    by (auto simp: complex_eq_iff)
  thus ?thesis using Hadjicostas_Chapman_formula_aux[of z] assms
    by (subst (asm) zeta_minus_pole_eq [symmetric]) (auto simp: add_ac)
qed

corollary euler_mascheroni_integral_form:
  "Hadjicostas_integral (-1) = euler_mascheroni"
  using Hadjicostas_Chapman_formula_aux[of "-1"] by simp

end


(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports Main
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

consts comb :: i
datatype comb =
  K
| S
| app ("p \<in> comb", "q \<in> comb")  (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

consts contract  :: i
abbreviation contract_syntax :: "[i,i] \<Rightarrow> o"  (infixl "\<rightarrow>\<^sup>1" 50)
  where "p \<rightarrow>\<^sup>1 q \<equiv> <p,q> \<in> contract"

abbreviation contract_multi :: "[i,i] \<Rightarrow> o"  (infixl "\<rightarrow>" 50)
  where "p \<rightarrow> q \<equiv> <p,q> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<rightarrow>\<^sup>1 p"
    S:   "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<rightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow>\<^sup>1 q\<bullet>r"
    Ap2: "[| p\<rightarrow>\<^sup>1q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow>\<^sup>1 r\<bullet>q"
  type_intros comb.intros

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

consts parcontract :: i

abbreviation parcontract_syntax :: "[i,i] => o"  (infixl "\<Rrightarrow>\<^sup>1" 50)
  where "p \<Rrightarrow>\<^sup>1 q == <p,q> \<in> parcontract"

abbreviation parcontract_multi :: "[i,i] => o"  (infixl "\<Rrightarrow>" 50)
  where "p \<Rrightarrow> q == <p,q> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "[| p \<in> comb |] ==> p \<Rrightarrow>\<^sup>1 p"
    K:    "[| p \<in> comb;  q \<in> comb |] ==> K\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 p"
    S:    "[| p \<in> comb;  q \<in> comb;  r \<in> comb |] ==> S\<bullet>p\<bullet>q\<bullet>r \<Rrightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "[| p\<Rrightarrow>\<^sup>1q;  r\<Rrightarrow>\<^sup>1s |] ==> p\<bullet>r \<Rrightarrow>\<^sup>1 q\<bullet>s"
  type_intros comb.intros

text \<open>
  Misc definitions.
\<close>

definition I :: i
  where "I \<equiv> S\<bullet>K\<bullet>K"

definition diamond :: "i \<Rightarrow> o"
  where "diamond(r) \<equiv>
    \<forall>x y. <x,y>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. <y,z>\<in>r & <y',z> \<in> r))"

subsection \<open>Transitive closure preserves the Church-Rosser property\<close>

lemma diamond_strip_lemmaD [rule_format]:
  "[| diamond(r);  <x,y>:r^+ |] ==>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ & <y,z>: r)"
  apply (unfold diamond_def)
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) ==> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection \<open>Results about Contraction\<close>

text \<open>
  For type checking: replaces @{term "a \<rightarrow>\<^sup>1 b"} by \<open>a, b \<in>
  comb\<close>.
\<close>

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb ==> I\<bullet>p \<rightarrow> p"
  \<comment> \<open>Example only: not used\<close>
  unfolding I_def by (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  unfolding I_def by blast

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

lemma I_contract_E: "I \<rightarrow>\<^sup>1 r ==> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p \<rightarrow>\<^sup>1 r ==> (\<exists>q. r = K\<bullet>q & p \<rightarrow>\<^sup>1 q)"
  by auto

lemma Ap_reduce1: "[| p \<rightarrow> q;  r \<in> comb |] ==> p\<bullet>r \<rightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "[| p \<rightarrow> q;  r \<in> comb |] ==> r\<bullet>p \<rightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text \<open>Counterexample to the diamond property for \<open>\<rightarrow>\<^sup>1\<close>.\<close>

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
  apply (unfold diamond_def)
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection \<open>Results about Parallel Contraction\<close>

text \<open>For type checking: replaces \<open>a \<Rrightarrow>\<^sup>1 b\<close> by \<open>a, b
  \<in> comb\<close>\<close>
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text \<open>Derive a case for each combinator constructor.\<close>
inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]:
    "K\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = K\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p \<Rrightarrow>\<^sup>1 r ==> (\<exists>p'. r = S\<bullet>p' & p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 r ==> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' & p \<Rrightarrow>\<^sup>1 p' & q \<Rrightarrow>\<^sup>1 q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  \<comment> \<open>Church-Rosser property for parallel contraction\<close>
  apply (unfold diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text \<open>
  \medskip Equivalence of @{prop "p \<rightarrow> q"} and @{prop "p \<Rrightarrow> q"}.
\<close>

lemma contract_imp_parcontract: "p\<rightarrow>\<^sup>1q ==> p\<Rrightarrow>\<^sup>1q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p\<rightarrow>q ==> p\<Rrightarrow>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p\<Rrightarrow>\<^sup>1q ==> p\<rightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p\<Rrightarrow>q ==> p\<rightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p\<Rrightarrow>q \<longleftrightarrow> p\<rightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end


theory ManWoman
  imports ConceptsAsModalitiesDL
begin

consts Woman :: concept
consts Man   :: concept
consts Person:: concept
consts Female:: concept

axiomatization where
A1: "Woman \<^bold>\<equiv> Person \<sqinter> Female"  and
A2: "Man   \<^bold>\<equiv> Person \<sqinter>\<^bold>\<not>Female"

theorem "Female \<midarrow>\<circ> \<^bold>\<not>Female \<sqsubseteq> Female"
  by blast

theorem "Female \<^bold>\<equiv> \<^bold>\<not>\<^bold>\<not>Female"
  by blast

theorem "\<top> \<sqsubseteq> Female\<squnion>\<^bold>\<not>Female"
  by blast

theorem "Person \<^bold>\<equiv> Woman \<squnion> Man"
proof -
  {
    fix x
    fix v1
    assume 1:"\<exists>v. Person(x,v1,v)"
    {
      assume 2:"\<exists>v. Female(x,v1,v)"
      from 1 2 have "\<exists>v. Woman(x,v1,v)" using A1 by blast
      hence "\<exists>v. (Woman\<squnion>Man)(x,v1,v)" by blast
    } moreover {
      assume "\<not>(\<exists>v. Female(x,v1,v))"
      hence 3:"\<exists>v. (\<^bold>\<not>Female)(x,v1,v)" by blast
      from 1 3 have "\<exists>v. Man(x,v1,v)" using A2 by blast
      hence "\<exists>v. (Woman\<squnion>Man)(x,v1,v)" by blast
    }
    ultimately have "\<exists>v. (Woman\<squnion>Man)(x,v1,v)" by blast
  }
  hence  "Person \<sqsubseteq> Woman \<squnion> Man" by blast
  moreover have "Woman \<squnion> Man \<sqsubseteq> Person" using A1 A2 by blast
  ultimately show "Person \<^bold>\<equiv> Woman \<squnion> Man" by blast
qed

theorem "\<bottom> \<^bold>\<equiv> Man \<sqinter> Female"
  using A1 A2 by blast

end


theory Tree_Demo
imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

lemma "Tip ~= Node l x r"
apply auto
done

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Tip = Tip" |
"mirror (Node l x r) = Node (mirror r) x (mirror l)"

value "mirror(Node (Node Tip a Tip) b t)"

lemma mirror_mirros[simp]: "mirror(mirror t) = t"
apply(induction t)
apply auto
done

text{* An example of fun: beyond one equation per constructor *}

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a [] = []" |
"sep a [x] = [x]" |
"sep a (x#y#zs) = x # a # sep a (y#zs)"

value "sep a [x,y,z]"

end