theory UteDefs
imports "../HOModel"
begin

section \<open>Verification of the \ute{} Consensus Algorithm\<close>

text \<open>
  Algorithm \ute{} is presented in~\<^cite>\<open>"biely:tolerating"\<close>. It is an
  uncoordinated algorithm that tolerates value (a.k.a.\ Byzantine) faults,
  and can be understood as a variant of \emph{UniformVoting}. The parameters
  $T$, $E$, and $\alpha$ appear as thresholds of the algorithm and in the
  communication predicates. Their values can be chosen within certain bounds
  in order to adapt the algorithm to the characteristics of different systems.

  We formalize in Isabelle the correctness proof of the algorithm that
  appears in~\<^cite>\<open>"biely:tolerating"\<close>, using the framework of theory
  \<open>HOModel\<close>.
\<close>

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

text \<open>
  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm proceeds in \emph{phases} of $2$ rounds each (we call
  \emph{steps} the individual rounds that constitute a phase).
  The following utility functions compute the phase and step of a round,
  given the round number.
\<close>

abbreviation
 "nSteps \<equiv> 2"
definition phase where "phase (r::nat) \<equiv> r div nSteps"
definition step where "step (r::nat) \<equiv> r mod nSteps"

lemma phase_zero [simp]: "phase 0 = 0"
by (simp add: phase_def)

lemma step_zero [simp]: "step 0 = 0"
by (simp add: step_def)

lemma phase_step: "(phase r * nSteps) + step r = r"
  by (auto simp add: phase_def step_def)

text \<open>The following record models the local state of a process.\<close>

record 'val pstate =
  x :: 'val                \<comment> \<open>current value held by process\<close>
  vote :: "'val option"    \<comment> \<open>value the process voted for, if any\<close>
  decide :: "'val option"  \<comment> \<open>value the process has decided on, if any\<close>

text \<open>Possible messages sent during the execution of the algorithm.\<close>

datatype 'val msg =
   Val "'val"
 | Vote "'val option"

text \<open>
  The \<open>x\<close> field of the initial state is unconstrained, all other
  fields are initialized appropriately.
\<close>

definition Ute_initState where
  "Ute_initState p st \<equiv>
   (vote st = None) \<and> (decide st = None)"

text \<open>
  The following locale introduces the parameters used for the \ute{}
  algorithm and their constraints~\<^cite>\<open>"biely:tolerating"\<close>.
\<close>

locale ute_parameters =
  fixes \<alpha>::nat and T::nat and E::nat
  assumes majE: "2*E \<ge> N + 2*\<alpha>"
      and majT: "2*T \<ge> N + 2*\<alpha>"
      and EltN: "E < N"
      and TltN: "T < N"
begin

text \<open>Simple consequences of the above parameter constraints.\<close>

lemma alpha_lt_N: "\<alpha> < N"
using EltN majE by auto

lemma alpha_lt_T: "\<alpha> < T"
using majT alpha_lt_N by auto

lemma alpha_lt_E: "\<alpha> < E"
using majE alpha_lt_N by auto

text \<open>
  We separately define the transition predicates and the send functions
  for each step and later combine them to define the overall next-state relation.
\<close>

text \<open>
  In step 0, each process sends its current \<open>x\<close>.
  If it receives the value $v$ more than $T$ times, it votes for $v$,
  otherwise it doesn't vote.
\<close>

definition
  send0 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send0 r p q st \<equiv> Val (x st)"

definition
  next0 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next0 r p st msgs st' \<equiv>
     (\<exists>v. card {q. msgs q = Some (Val v)} > T \<and> st' = st \<lparr> vote := Some v \<rparr>)
   \<or> \<not>(\<exists>v. card {q. msgs q = Some (Val v)} > T) \<and> st' = st \<lparr> vote := None \<rparr>"

text \<open>
  In step 1, each process sends its current \<open>vote\<close>.

  If it receives more than \<open>\<alpha>\<close> votes for a given value \<open>v\<close>,
  it sets its \<open>x\<close> field to \<open>v\<close>, else it sets \<open>x\<close> to a
  default value.

  If the process receives more than \<open>E\<close> votes for \<open>v\<close>, it decides
  \<open>v\<close>, otherwise it leaves its decision unchanged.
\<close>

definition
  send1 :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "send1 r p q st \<equiv> Vote (vote st)"

definition
  next1 :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "next1 r p st msgs st' \<equiv>
    ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha> \<and> x st' = v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > \<alpha>)
         \<and> x st' = undefined  )
  \<and> ( (\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E \<and> decide st' = Some v)
     \<or> \<not>(\<exists>v. card {q. msgs q = Some (Vote (Some v))} > E)
         \<and> decide st' = decide st )
  \<and> vote st' = None"

text \<open>
  The overall send function and next-state relation are simply obtained as
  the composition of the individual relations defined above.
\<close>

definition
  Ute_sendMsg :: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val msg"
where
  "Ute_sendMsg (r::nat) \<equiv> if step r = 0 then send0 r else send1 r"

definition
  Ute_nextState :: "nat \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> (Proc \<Rightarrow> 'val msg option)
                        \<Rightarrow> 'val pstate \<Rightarrow> bool"
where
  "Ute_nextState r \<equiv> if step r = 0 then next0 r else next1 r"

subsection \<open>Communication Predicate for \ute{}\<close>

text \<open>
  Following~\<^cite>\<open>"biely:tolerating"\<close>, we now define the communication predicate
  for the \ute{} algorithm to be correct.

  The round-by-round predicate stipulates the following conditions:
  \begin{itemize}
  \item no process may receive more than \<open>\<alpha>\<close> corrupted messages, and
  \item every process should receive more than \<open>max(T, N + 2*\<alpha> - E - 1)\<close>
    correct messages.
  \end{itemize}
  \<^cite>\<open>"biely:tolerating"\<close> also requires that every process should receive more
  than \<open>\<alpha>\<close> correct messages, but this is implied, since \<open>T > \<alpha>\<close>
  (cf. lemma \<open>alpha_lt_T\<close>).
\<close>

definition Ute_commPerRd where
  "Ute_commPerRd HOrs SHOrs \<equiv>
   \<forall>p. card (HOrs p - SHOrs p) \<le> \<alpha>
     \<and> card (SHOrs p \<inter> HOrs p) > N + 2*\<alpha> - E - 1
     \<and> card (SHOrs p \<inter> HOrs p) > T"

text \<open>
  The global communication predicate requires there exists some phase
  \<open>\<Phi>\<close> such that:
  \begin{itemize}
  \item all HO and SHO sets of all processes are equal in the second step
    of phase \<open>\<Phi>\<close>, i.e.\ all processes receive messages from the
    same set of processes, and none of these messages is corrupted,
  \item every process receives more than \<open>T\<close> correct messages in
    the first step of phase \<open>\<Phi>+1\<close>, and
  \item every process receives more than \<open>E\<close> correct messages in the
    second step of phase \<open>\<Phi>+1\<close>.
  \end{itemize}
  The predicate in the article~\<^cite>\<open>"biely:tolerating"\<close> requires infinitely
  many such phases, but one is clearly enough.
\<close>

definition Ute_commGlobal where
  "Ute_commGlobal HOs SHOs \<equiv>
    \<exists>\<Phi>. (let r = Suc (nSteps*\<Phi>)
         in  (\<exists>\<pi>. \<forall>p. \<pi> = HOs r p \<and> \<pi> = SHOs r p)
           \<and> (\<forall>p. card (SHOs (Suc r) p \<inter> HOs (Suc r) p) > T)
           \<and> (\<forall>p. card (SHOs (Suc (Suc r)) p \<inter> HOs (Suc (Suc r)) p) > E))"

subsection \<open>The \ute{} Heard-Of Machine\<close>

text \<open>
  We now define the coordinated HO machine for the \ute{} algorithm
  by assembling the algorithm definition and its communication-predicate.
\<close>

definition Ute_SHOMachine where
  "Ute_SHOMachine = \<lparr>
     CinitState =  (\<lambda> p st crd. Ute_initState p st),
     sendMsg =  Ute_sendMsg,
     CnextState = (\<lambda> r p st msgs crd st'. Ute_nextState r p st msgs st'),
     SHOcommPerRd = Ute_commPerRd,
     SHOcommGlobal = Ute_commGlobal
   \<rparr>"

abbreviation
  "Ute_M \<equiv> (Ute_SHOMachine::(Proc, 'val pstate, 'val msg) SHOMachine)"

end   \<comment> \<open>locale @{text "ute_parameters"}\<close>

end   (* theory UteDefs *)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_82
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 zip :: "'a list => 'b list => (('a, 'b) pair) list" where
"zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = nil2"
| "take (S z) (nil2) = nil2"
| "take (S z) (cons2 x2 x3) = cons2 x2 (take z x3)"

theorem property0 :
  "((take n (zip xs ys)) = (zip (take n xs) (take n ys)))"
  oops

end


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

header {* (Infinite) Sequences *}

theory Sequence
imports Main
begin

text {*
  Lamport's Temporal Logic of Actions (TLA) is a linear-time temporal logic,
  and its semantics is defined over infinite sequence of states, which we
  simply represent by the type @{text "'a seq"}, defined as an abbreviation
  for the type @{text "nat \<Rightarrow> 'a"}, where @{text "'a"} is the type of sequence
  elements.

  This theory defines some useful notions about such sequences, and in particular
  concepts related to stuttering (finite repetitions of states), which are
  important for the semantics of TLA. We identify a finite sequence with an
  infinite sequence that ends in infinite stuttering. In this way, we avoid the
  complications of having to handle both finite and infinite sequences of states:
  see e.g. Devillers et al \cite{Devillers97} who discuss several variants of
  representing possibly infinite sequences in HOL, Isabelle and PVS.
*}

type_synonym 'a seq = "nat \<Rightarrow> 'a"

subsection "Some operators on sequences"

text {* Some general functions on sequences are provided *}

definition first :: "'a seq \<Rightarrow> 'a"
where "first s \<equiv> s 0"

definition second :: "('a seq) \<Rightarrow> 'a"
where "second s \<equiv> s 1"

definition suffix :: "'a seq \<Rightarrow> nat \<Rightarrow> 'a seq" (infixl "|\<^sub>s" 60)
where "s |\<^sub>s i \<equiv> \<lambda> n. s (n+i)"

definition tail :: "'a seq \<Rightarrow> 'a seq"
where "tail s \<equiv> s |\<^sub>s 1"

definition
 app :: "'a \<Rightarrow> ('a seq) \<Rightarrow> ('a seq)" (infixl "##" 60)
where
 "s ## \<sigma>  \<equiv> \<lambda> n. if n=0 then s else \<sigma> (n - 1)"

text {*
  @{text "s |\<^sub>s i"} returns the suffix of sequence @{term s} from
  index @{term i}.  @{term first} returns the first element of a sequence
  while  @{term second} returns the second element. @{term tail} returns the
  sequence starting at the second element. @{term "s ## \<sigma>"} prefixes the
  sequence @{term \<sigma>} by element @{term s}.
*}

subsubsection "Properties of @{term first} and @{term second}"

lemma first_tail_second: "first(tail s) = second s"
  by (simp add: first_def second_def tail_def suffix_def)

subsubsection "Properties of @{term suffix}"

lemma suffix_first: "first (s |\<^sub>s n) = s n"
  by (auto simp add: suffix_def first_def)

lemma suffix_second: "second (s |\<^sub>s n) = s (Suc n)"
  by (auto simp add: suffix_def second_def)

lemma suffix_plus: "s |\<^sub>s n |\<^sub>s m = s |\<^sub>s (m + n)"
  by (simp add: suffix_def add.assoc)

lemma suffix_commute: "((s |\<^sub>s n) |\<^sub>s m) = ((s |\<^sub>s m) |\<^sub>s n)"
  by (simp add: suffix_plus add.commute)

lemma suffix_plus_com: "s |\<^sub>s m |\<^sub>s n = s |\<^sub>s (m + n)"
proof -
  have "s |\<^sub>s n |\<^sub>s m = s |\<^sub>s (m + n)" by (rule suffix_plus)
  thus "s |\<^sub>s m |\<^sub>s n = s |\<^sub>s (m + n)" by (simp add: suffix_commute)
qed

lemma suffix_zero[simp]: "s |\<^sub>s 0 = s"
  by (simp add: suffix_def)

lemma suffix_tail: "s |\<^sub>s 1 = tail s"
  by (simp add: tail_def)

lemma tail_suffix_suc: "s |\<^sub>s (Suc n) = tail (s |\<^sub>s n)"
  by (simp add: suffix_def tail_def)

subsubsection "Properties of  @{term app}"

lemma seq_app_second: "(s ## \<sigma>) 1 = \<sigma> 0"
  by (simp add: app_def)

lemma seq_app_first: "(s ## \<sigma>) 0 = s"
  by (simp add: app_def)

lemma seq_app_first_tail: "(first s) ## (tail s) = s"
proof (rule ext)
  fix x
  show "(first s ## tail s) x = s x"
    by (simp add: first_def app_def suffix_def tail_def)
qed

lemma seq_app_greater_than_zero: "n > 0 \<Longrightarrow> (s ## \<sigma>) n = \<sigma> (n - 1)"
  by (simp add: app_def)

subsection "Finite and Empty Sequences"

text{*
  We identify finite and empty sequences and prove lemmas about them.
*}

definition fin :: "('a seq) \<Rightarrow> bool"
where "fin s \<equiv> \<exists> i. \<forall> j \<ge> i. s j = s i"

abbreviation inf :: "('a seq) \<Rightarrow> bool"
where "inf s \<equiv> \<not>(fin s)"

definition last :: "('a seq) \<Rightarrow> nat"
where "last s \<equiv> LEAST i. (\<forall> j \<ge> i. s j = s i)"

definition laststate :: "('a seq) \<Rightarrow> 'a"
where "laststate s \<equiv> s (last s)"

definition emptyseq :: "('a seq) \<Rightarrow> bool"
where "emptyseq \<equiv> \<lambda> s. \<forall> i. s i = s 0"

abbreviation notemptyseq :: "('a seq) \<Rightarrow> bool"
where "notemptyseq s \<equiv> \<not>(emptyseq s)"

text {*
  Predicate @{term fin} holds if there is an element
  in the sequence such that all subsequent elements are identical,
  i.e. the sequence is finite. @{term "last s"} returns the smallest index
  from which on all elements of a finite sequence @{term s} are identical. Note that
  if @{text s} is not finite then an arbitrary number is returned.
  @{term laststate} returns the last element of a finite sequence. We assume
  that the sequence is finite when using  @{term last} and  @{term laststate}.
  Predicate @{term emptyseq} identifies empty sequences -- i.e. all states in
  the sequence are identical to the initial one, while @{term notemptyseq} holds
  if the given sequence is not empty.
*}

subsubsection "Properties of @{term emptyseq}"

lemma empty_is_finite: assumes "emptyseq s" shows "fin s"
  using assms by (auto simp: fin_def emptyseq_def)

lemma empty_suffix_is_empty: assumes H: "emptyseq s" shows "emptyseq (s |\<^sub>s n)"
proof (clarsimp simp: emptyseq_def)
 fix i
 from H have "(s |\<^sub>s n) i = s 0" by (simp add: emptyseq_def suffix_def)
 moreover
 from H have "(s |\<^sub>s n) 0 = s 0" by (simp add: emptyseq_def suffix_def)
 ultimately
 show "(s |\<^sub>s n) i = (s |\<^sub>s n) 0" by simp
qed

lemma suc_empty: assumes H1: "emptyseq (s |\<^sub>s m)" shows "emptyseq (s |\<^sub>s (Suc m))"
proof -
  from H1 have "emptyseq ((s |\<^sub>s m) |\<^sub>s 1)" by (rule empty_suffix_is_empty)
  thus ?thesis by (simp add: suffix_plus)
qed

lemma empty_suffix_exteq: assumes H:"emptyseq s" shows "(s |\<^sub>s n) m = s m"
proof (unfold suffix_def)
  from H have "s (m+n) = s 0" by (simp add: emptyseq_def)
  moreover
  from H have "s m = s 0" by (simp add: emptyseq_def)
  ultimately show "s (m + n) = s m" by simp
qed

lemma empty_suffix_eq: assumes H: "emptyseq s" shows "(s |\<^sub>s n) = s"
proof (rule ext)
  fix m
  from H show "(s |\<^sub>s n) m = s m" by (rule empty_suffix_exteq)
qed

lemma seq_empty_all: assumes H: "emptyseq s" shows "s i = s j"
proof -
  from H have "s i = s 0" by (simp add: emptyseq_def)
  moreover
  from H have "s j = s 0" by (simp add: emptyseq_def)
  ultimately
  show ?thesis by simp
qed

subsubsection "Properties of @{term last} and @{term laststate}"

lemma fin_stut_after_last: assumes H: "fin s" shows "\<forall>j \<ge> last s. s j = s (last s)"
proof (clarify)
  fix j
  assume j: "j \<ge> last s"
  from H obtain i where "\<forall>j \<ge> i. s j = s i" (is "?P i") by (auto simp: fin_def)
  hence "?P (last s)" unfolding last_def by (rule LeastI)
  with j show "s j = s (last s)" by blast
qed

subsection "Stuttering Invariance"

text {*
  This subsection provides functions for removing stuttering
  steps of sequences, i.e. we formalise Lamports @{text \<natural>} operator.
  Our formal definition is close to that of Wahab in the PVS prover.

  The key novelty with the @{term "Sequence"} theory, is the treatment of
  stuttering invariance, which enables verification of stuttering invariance of
  the operators derived using it. Such proofs require comparing sequences
  up to stuttering. Here, Lamport's \cite{Lamport94} method is used to
  mechanise the equality of sequences up to stuttering: he defines
  the @{text \<natural>} operator, which collapses a sequence by removing
  all stuttering steps, except possibly infinite stuttering at the end of the sequence.
  These are left unchanged.
*}

definition nonstutseq :: "('a seq) \<Rightarrow> bool"
where "nonstutseq s \<equiv> \<forall> i. s i = s (Suc i) \<longrightarrow> (\<forall> j > i. s i = s j)"

definition stutstep :: "('a seq) \<Rightarrow> nat \<Rightarrow> bool"
where "stutstep s n \<equiv> (s n = s (Suc n))"

definition nextnat :: "('a seq) \<Rightarrow> nat"
where "nextnat s \<equiv> if emptyseq s then 0 else LEAST i. s i \<noteq> s 0"

definition nextsuffix :: "('a seq) \<Rightarrow> ('a seq)"
where "nextsuffix s \<equiv> s |\<^sub>s (nextnat s)"

fun "next" :: "nat \<Rightarrow> ('a seq) \<Rightarrow> ('a seq)" where
  "next 0 = id"
| "next (Suc n) = nextsuffix o (next n)"

definition collapse :: "('a seq) \<Rightarrow> ('a seq)" ("\<natural>")
where "\<natural> s \<equiv> \<lambda> n. (next n s) 0"

text {*
  Predicate @{term nonstutseq} identifies sequences without any
  stuttering steps -- except possibly for infinite stuttering at the end.
  Further, @{term "stutstep s n"} is a predicate which holds if the element
  after @{term "s n"} is equal to @{term "s n"}, i.e. @{term "Suc n"} is
  a stuttering step.
  @{term "collapse s"} formalises Lamports  @{term "\<natural>"}
  operator. It returns the first state of the result of @{term "next n s"}.
  @{term "next n s"} finds suffix of the $n^{th}$ change. Hence the first
  element, which @{term "\<natural> s"} returns, is the state after the $n^{th}$
  change.  @{term "next n s"} is defined by primitive recursion on
  @{term "n"} using function composition of function @{term nextsuffix}. E.g.
  @{term "next 3 s"} equals @{term "nextsuffix (nextsuffix (nextsuffix s))"}.
  @{term "nextsuffix s"} returns the suffix of the sequence starting at the
  next changing state. It uses @{term "nextnat"} to obtain this. All the real
  computation is done in this function. Firstly, an empty sequence will obviously
  not contain any changes, and @{text 0} is therefore returned. In this case
  @{term "nextsuffix"} behaves like the identify function. If the sequence is not
  empty then the smallest number @{term "i"} such that @{term "s i"} is different
  from the initial state is returned. This is achieved by @{term "Least"}.
*}

subsubsection "Properties of @{term nonstutseq}"

lemma seq_empty_is_nonstut:
  assumes H: "emptyseq s" shows "nonstutseq s"
  using H by (auto simp: nonstutseq_def seq_empty_all)

lemma notempty_exist_nonstut:
  assumes H: "\<not> emptyseq (s |\<^sub>s m)" shows "\<exists> i. s i \<noteq> s m \<and> i > m"
using H proof (auto simp: emptyseq_def suffix_def)
  fix i
  assume i: "s (i + m) \<noteq> s m"
  hence "i \<noteq> 0" by (intro notI, simp)
  with i show ?thesis by auto
qed

subsubsection "Properties of @{term nextnat}"

lemma nextnat_le_unch: assumes H: "n < nextnat s" shows "s n = s 0"
proof (cases "emptyseq s")
  assume "emptyseq s"
  hence "nextnat s = 0" by (simp add: nextnat_def)
  with H show ?thesis by auto
next
  assume "\<not> emptyseq s"
  hence a1: "nextnat s = (LEAST i. s i \<noteq> s 0)" by (simp add: nextnat_def)
  show ?thesis
  proof (rule ccontr)
    assume a2: "s n \<noteq> s 0" (is "?P n")
    hence "(LEAST i. s i \<noteq> s 0) \<le> n" by (rule Least_le)
    hence "\<not>(n < (LEAST i. s i \<noteq> s 0))" by auto
    also from H a1 have "n < (LEAST i. s i \<noteq> s 0)" by simp
    ultimately show False by auto
  qed
qed

lemma stutnempty:
  assumes H: "\<not> stutstep s n" shows "\<not> emptyseq (s |\<^sub>s n)"
proof (unfold emptyseq_def suffix_def)
  from H have "s (Suc n) \<noteq> s n" by (auto simp add: stutstep_def)
  hence "s (1+n) \<noteq> s (0+n)" by simp
  thus "\<not>(\<forall> i. s (i+n) = s (0+n))" by blast
qed

lemma notstutstep_nexnat1:
  assumes H: "\<not> stutstep s n" shows "nextnat (s |\<^sub>s n) = 1"
proof -
  from H have h': "nextnat (s |\<^sub>s n) = (LEAST i. (s |\<^sub>s n) i \<noteq> (s |\<^sub>s n) 0)"
    by (auto simp add: nextnat_def stutnempty)
  from H have "s (Suc n) \<noteq> s n" by (auto simp add: stutstep_def)
  hence "(s |\<^sub>s n) 1 \<noteq> (s |\<^sub>s n) 0" (is "?P 1") by (auto simp add: suffix_def)
  hence "Least ?P \<le> 1" by (rule Least_le)
  hence g1: "Least ?P = 0 \<or> Least ?P = 1" by auto
  with h' have g1': "nextnat (s |\<^sub>s n) = 0 \<or> nextnat (s |\<^sub>s n) = 1" by auto
  also have "nextnat (s |\<^sub>s n) \<noteq> 0"
  proof -
    from H have "\<not> emptyseq (s |\<^sub>s n)" by (rule stutnempty)
    then obtain i where "(s |\<^sub>s n) i \<noteq>  (s |\<^sub>s n) 0" by (auto simp add: emptyseq_def)
    hence "(s |\<^sub>s n) (LEAST i. (s |\<^sub>s n) i \<noteq> (s |\<^sub>s n) 0) \<noteq> (s |\<^sub>s n) 0" by (rule LeastI)
    with h' have g2: "(s |\<^sub>s n) (nextnat (s |\<^sub>s n)) \<noteq> (s |\<^sub>s n) 0" by auto
    show "(nextnat (s |\<^sub>s n)) \<noteq> 0"
    proof
      assume "(nextnat (s |\<^sub>s n)) = 0"
      with g2 show "False" by simp
    qed
  qed
  ultimately show  "nextnat (s |\<^sub>s n) = 1" by auto
qed

lemma stutstep_notempty_notempty:
  assumes h1: "emptyseq (s |\<^sub>s Suc n)" (is "emptyseq ?sn")
      and h2: "stutstep s n"
  shows "emptyseq (s |\<^sub>s n)" (is "emptyseq ?s")
proof (auto simp: emptyseq_def)
  fix k
  show "?s k = ?s 0"
  proof (cases k)
    assume "k = 0" thus ?thesis by simp
  next
    fix m
    assume k: "k = Suc m"
    hence "?s k = ?sn m" by (simp add: suffix_def)
    also from h1 have "... = ?sn 0" by (simp add: emptyseq_def)
    also from h2 have "... = s n" by (simp add: suffix_def stutstep_def)
    finally show ?thesis by (simp add: suffix_def)
  qed
qed

lemma stutstep_empty_suc:
  assumes "stutstep s n"
  shows "emptyseq (s |\<^sub>s Suc n) = emptyseq (s |\<^sub>s n)"
using assms by (auto elim: stutstep_notempty_notempty suc_empty)

lemma nextnat_empty_neq: assumes H: "\<not> emptyseq s" shows "s (nextnat s) \<noteq> s 0"
proof -
  from H have a1: "nextnat s =  (LEAST i. s i \<noteq> s 0)" by (simp add: nextnat_def)
  from H obtain i where "s i \<noteq> s 0" by (auto simp: emptyseq_def)
  hence "s (LEAST i. s i \<noteq> s 0) \<noteq> s 0" by (rule LeastI)
  with a1 show ?thesis by auto
qed

lemma nextnat_empty_gzero: assumes H: "\<not> emptyseq s" shows "nextnat s > 0"
proof -
  from H have a1: "s (nextnat s) \<noteq> s 0" by (rule nextnat_empty_neq)
  have "nextnat s \<noteq> 0"
  proof
    assume "nextnat s = 0"
    with a1 show "False" by simp
  qed
  thus "nextnat s > 0" by simp
qed

subsubsection "Properties of @{term nextsuffix}"

lemma empty_nextsuffix:
  assumes H: "emptyseq s" shows "nextsuffix s = s"
  using H by (simp add: nextsuffix_def nextnat_def)

lemma empty_nextsuffix_id:
  assumes H: "emptyseq s" shows "nextsuffix s = id s"
  using H by (simp add: empty_nextsuffix)

lemma notstutstep_nextsuffix1:
  assumes H: "\<not> stutstep s n" shows "nextsuffix (s |\<^sub>s n) = s |\<^sub>s (Suc n)"
proof (unfold nextsuffix_def)
  show "(s |\<^sub>s n |\<^sub>s (nextnat (s |\<^sub>s n))) =  s |\<^sub>s (Suc n)"
  proof -
    from H have  "nextnat (s |\<^sub>s n) = 1" by (rule notstutstep_nexnat1)
    hence "(s |\<^sub>s n |\<^sub>s (nextnat (s |\<^sub>s n))) = s |\<^sub>s n |\<^sub>s 1" by auto
    thus ?thesis by (simp add: suffix_def)
  qed
qed

subsubsection "Properties of @{term next}"

lemma next_suc_suffix: "next (Suc n) s = nextsuffix (next n s)"
  by simp

lemma next_suffix_com: "nextsuffix (next n s) = (next n (nextsuffix s))"
  by (induct n, auto)

lemma next_plus: "next (m+n) s = next m (next n s)"
  by (induct m, auto)

lemma next_empty: assumes H: "emptyseq s" shows "next n s = s"
proof (induct n)
  from H show "next 0 s = s" by auto
next
  fix n
  assume a1: "next n s = s"
  have "next (Suc n) s = nextsuffix (next n s)" by auto
  with a1 have "next (Suc n) s = nextsuffix s" by simp
  with H show "next (Suc n) s = s"
    by (simp add: nextsuffix_def nextnat_def)
qed

lemma notempty_nextnotzero:
  assumes H: "\<not>emptyseq s" shows "(next (Suc 0) s) 0 \<noteq> s 0"
proof -
  from H have g1: "s (nextnat s) \<noteq> s 0" by (rule nextnat_empty_neq)
  have "next (Suc 0) s = nextsuffix s" by auto
  hence "(next (Suc 0) s) 0 =  s (nextnat s)" by (simp add: nextsuffix_def suffix_def)
  with g1 show ?thesis by simp
qed

lemma next_ex_id: "\<exists> i. s i = (next m s) 0"
proof -
  have "\<exists> i. (s |\<^sub>s i) = (next m s)"
  proof (induct m)
    have "s |\<^sub>s 0 = next 0 s" by simp
    thus "\<exists> i. (s |\<^sub>s i) = (next 0 s)" ..
  next
    fix m
    assume a1: "\<exists> i. (s |\<^sub>s i) = (next m s)"
    then obtain i where a1': "(s |\<^sub>s i) = (next m s)" ..
    have "next (Suc m) s = nextsuffix (next m s)" by auto
    hence "next (Suc m) s = (next m s) |\<^sub>s (nextnat (next m s))" by (simp add: nextsuffix_def)
    hence "\<exists> i. next (Suc m) s = (next m s) |\<^sub>s i" ..
    then obtain j where "next (Suc m) s = (next m s) |\<^sub>s j" ..
    with a1' have "next (Suc m) s = (s |\<^sub>s i) |\<^sub>s j" by simp
    hence "next (Suc m) s = (s |\<^sub>s (j+i))" by (simp add: suffix_plus)
    hence "(s |\<^sub>s (j+i)) = next (Suc m) s" by simp
    thus "\<exists> i. (s |\<^sub>s i) = (next (Suc m) s)" ..
  qed
  then obtain i where "(s |\<^sub>s i) = (next m s)" ..
  hence "(s |\<^sub>s i) 0 = (next m s) 0" by auto
  hence "s i = (next m s) 0" by (auto simp add: suffix_def)
  thus ?thesis ..
qed

subsubsection "Properties of @{term collapse}"

lemma emptyseq_collapse_eq: assumes A1: "emptyseq s" shows "\<natural> s = s"
proof (unfold collapse_def, rule ext)
  fix n
  from A1 have "next n s = s" by (rule next_empty)
  moreover
  from A1 have "s n = s 0" by (simp add: emptyseq_def)
  ultimately
  show "(next n s) 0 = s n" by simp
qed

lemma empty_collapse_empty:
  assumes H: "emptyseq s" shows "emptyseq (\<natural> s)"
  using H by (simp add: emptyseq_collapse_eq)

lemma collapse_empty_empty:
  assumes H: "emptyseq (\<natural> s)" shows "emptyseq s"
proof (rule ccontr)
  assume a1: "\<not>emptyseq s"
  from H have "\<forall> i. (next i s) 0 = s 0" by (simp add: collapse_def emptyseq_def)
  moreover
  from a1 have "(next (Suc 0) s) 0 \<noteq> s 0" by (rule notempty_nextnotzero)
  ultimately show "False" by blast
qed

lemma collapse_empty_iff_empty [simp]: "emptyseq (\<natural> s) = emptyseq s"
  by (auto elim: empty_collapse_empty collapse_empty_empty)

subsection "Similarity of Sequences"

text{*
  Since adding or removing stuttering steps does not change the validity
  of a stuttering-invarant formula, equality is often too strong,
  and the weaker equality \emph{up to stuttering} is sufficient.
  This is often called \emph{similarity} ($\approx$)
  of sequences in the literature, and is required to
  show that logical operators are stuttering invariant. This
  is mechanised as:
*}

definition seqsimilar :: "('a seq) \<Rightarrow> ('a seq) \<Rightarrow> bool" (infixl "\<approx>" 50)
where "\<sigma> \<approx> \<tau> \<equiv> (\<natural> \<sigma>) = (\<natural> \<tau>)"

subsubsection "Properties of @{term seqsimilar}"

lemma seqsim_refl [iff]: "s \<approx> s"
  by (simp add: seqsimilar_def)

lemma seqsim_sym: assumes H: "s \<approx> t" shows "t \<approx> s"
  using H by (simp add: seqsimilar_def)

lemma seqeq_imp_sim: assumes H: "s = t" shows "s \<approx> t"
  using H by simp

lemma seqsim_trans [trans]: assumes h1: "s \<approx> t" and h2: "t \<approx> z" shows "s \<approx> z"
  using assms by (simp add: seqsimilar_def)

theorem sim_first: assumes H: "s \<approx> t" shows "first s = first t"
proof -
  from H have "(\<natural> s) 0 = (\<natural> t) 0" by (simp add: seqsimilar_def)
  thus ?thesis by (simp add: collapse_def first_def)
qed

lemmas sim_first2 = sim_first[unfolded first_def]

lemma tail_sim_second: assumes H: "tail s \<approx> tail t" shows "second s = second t"
proof -
  from H have "first (tail s) = first (tail t)" by (simp add: sim_first)
  thus "second s = second t" by (simp add: first_tail_second)
qed

lemma seqsimilarI:
  assumes 1: "first s = first t" and 2: "nextsuffix s \<approx> nextsuffix t"
  shows "s \<approx> t"
  unfolding seqsimilar_def collapse_def
proof
  fix n
  show "next n s 0 = next n t 0"
  proof (cases n)
    assume "n = 0"
    with 1 show ?thesis by (simp add: first_def)
  next
    fix m
    assume m: "n = Suc m"
    from 2 have "next m (nextsuffix s) 0 =  next m (nextsuffix t) 0"
      unfolding seqsimilar_def collapse_def by (rule fun_cong)
    with m show ?thesis by (simp add: next_suffix_com)
  qed
qed

lemma seqsim_empty_empty:
  assumes H1: "s \<approx> t" and H2: "emptyseq s" shows "emptyseq t"
proof -
  from H2 have "emptyseq (\<natural> s)" by simp
  with H1 have "emptyseq (\<natural> t)" by (simp add: seqsimilar_def)
  thus ?thesis by simp
qed

lemma seqsim_empty_iff_empty:
  assumes H: "s \<approx> t" shows "emptyseq s = emptyseq t"
proof
  assume "emptyseq s" with H show "emptyseq t" by (rule seqsim_empty_empty)
next
  assume t: "emptyseq t"
  from H have "t \<approx> s" by (rule seqsim_sym)
  from this t show "emptyseq s" by (rule seqsim_empty_empty)
qed

lemma seq_empty_eq:
  assumes H1: "s 0 = t 0" and H2: "emptyseq s" and H3: "emptyseq t"
  shows "s = t"
proof (rule ext)
  fix n
  from assms have "t n = s n" by (auto simp: emptyseq_def)
  thus "s n = t n" by simp
qed

lemma seqsim_notstutstep:
  assumes H: "\<not> (stutstep s n)" shows "(s |\<^sub>s (Suc n)) \<approx> nextsuffix (s |\<^sub>s n)"
  using H by (simp add: notstutstep_nextsuffix1)

lemma stut_nextsuf_suc:
  assumes H: "stutstep s n" shows "nextsuffix (s |\<^sub>s n) = nextsuffix (s |\<^sub>s (Suc n))"
proof (cases "emptyseq (s |\<^sub>s n)")
  case True
  hence g1: "nextsuffix (s |\<^sub>s n) = (s |\<^sub>s n)" by (simp add: nextsuffix_def nextnat_def)
  from True have g2: "nextsuffix (s |\<^sub>s Suc n) = (s |\<^sub>s Suc n)"
    by (simp add: suc_empty nextsuffix_def nextnat_def)
  have "(s |\<^sub>s n) = (s |\<^sub>s Suc n)"
  proof
    fix x
    from True have "s (x + n) = s (0 + n)" "s (Suc x + n) = s (0 + n)"
      unfolding emptyseq_def suffix_def by (blast+)
    thus "(s |\<^sub>s n) x = (s |\<^sub>s Suc n) x" by (simp add: suffix_def)
  qed
  with g1 g2 show ?thesis by auto
next
  case False
  with H have "(nextnat (s |\<^sub>s n)) = Suc (nextnat (s |\<^sub>s Suc n))"
    by (simp add: stutstep_notempty_sucnextnat)
  thus ?thesis
    by (simp add: nextsuffix_def suffix_plus)
qed

lemma seqsim_stutstep:
  assumes H: "stutstep s n" shows "(s |\<^sub>s (Suc n)) \<approx> (s |\<^sub>s n)" (is "?sn \<approx> ?s")
  unfolding seqsimilar_def collapse_def
proof
  fix m
  show "next m (s |\<^sub>s Suc n) 0 = next m (s |\<^sub>s n) 0"
  proof (cases m)
    assume "m=0"
    with H show ?thesis by (simp add: suffix_def stutstep_def)
  next
    fix k
    assume m: "m = Suc k"
    with H  have "next m (s |\<^sub>s Suc n) = next k (nextsuffix  (s |\<^sub>s n))"
      by (simp add: stut_nextsuf_suc next_suffix_com)
    moreover from m have "next m (s |\<^sub>s n) = next k (nextsuffix  (s |\<^sub>s n))"
      by (simp add: next_suffix_com)
    ultimately show "next m (s |\<^sub>s Suc n) 0 = next m (s |\<^sub>s n) 0" by simp
  qed
qed

lemma addfeqstut: "stutstep ((first t) ## t) 0"
  by (simp add: first_def stutstep_def app_def suffix_def)

lemma addfeqsim: "((first t) ## t) \<approx> t"
proof -
  have "stutstep ((first t) ## t) 0" by (rule addfeqstut)
  hence "(((first t) ## t) |\<^sub>s (Suc 0)) \<approx> (((first t) ## t) |\<^sub>s 0)" by (rule seqsim_stutstep)
  hence "tail ((first t) ## t) \<approx> ((first t) ## t)" by (simp add: suffix_def tail_def)
  hence "t \<approx> ((first t) ## t)" by (simp add: tail_def app_def suffix_def)
  thus ?thesis by (rule seqsim_sym)
qed

lemma addfirststut:
  assumes H: "first s = second s" shows "s \<approx> tail s"
proof -
  have g1: "(first s) ## (tail s) = s" by (rule seq_app_first_tail)
  from H have "(first s) = first (tail s)"
    by (simp add: first_def second_def tail_def suffix_def)
  hence "(first s) ## (tail s) \<approx> (tail s)" by (simp add: addfeqsim)
  with g1 show ?thesis by simp
qed

lemma app_seqsimilar:
  assumes h1: "s \<approx> t" shows "(x ## s) \<approx> (x ## t)"
proof (cases "stutstep (x ## s) 0")
  case True
  from h1 have "first s = first t" by (rule sim_first)
  with True have a2: "stutstep (x ## t) 0"
    by (simp add: stutstep_def first_def app_def)
  from True have "((x ## s) |\<^sub>s (Suc 0)) \<approx> ((x ## s) |\<^sub>s 0)" by (rule seqsim_stutstep)
  hence "tail (x ## s) \<approx> (x ## s)" by (simp add: tail_def suffix_def)
  hence g1: "s \<approx> (x ## s)" by (simp add: app_def tail_def suffix_def)
  from a2 have "((x ## t) |\<^sub>s (Suc 0)) \<approx> ((x ## t) |\<^sub>s 0)" by (rule seqsim_stutstep)
  hence "tail (x ## t) \<approx> (x ## t)" by (simp add: tail_def suffix_def)
  hence g2: "t \<approx> (x ## t)" by (simp add: app_def tail_def suffix_def)
  from h1 g2 have "s \<approx> (x ## t)" by (rule seqsim_trans)
  from this[THEN seqsim_sym] g1 show "(x ## s) \<approx> (x ## t)"
    by (rule seqsim_sym[OF seqsim_trans])
next
  case False
  from h1 have "first s = first t" by (rule sim_first)
  with False have a2: "\<not> stutstep (x ## t) 0"
    by (simp add: stutstep_def first_def app_def)
  from False have "((x ## s) |\<^sub>s (Suc 0)) \<approx> nextsuffix ((x ## s) |\<^sub>s 0)"
    by (rule seqsim_notstutstep)
  hence "(tail (x ## s)) \<approx> nextsuffix (x ## s)"
    by (simp add: tail_def)
  hence g1: "s \<approx> nextsuffix (x ## s)" by (simp add: seq_app_tail)
  from a2 have "((x ## t) |\<^sub>s (Suc 0)) \<approx> nextsuffix ((x ## t) |\<^sub>s 0)"
    by (rule seqsim_notstutstep)
  hence "(tail (x ## t)) \<approx> nextsuffix (x ## t)" by (simp add: tail_def)
  hence g2: "t \<approx> nextsuffix (x ## t)" by (simp add: seq_app_tail)
  with h1 have "s \<approx> nextsuffix (x ## t)" by (rule seqsim_trans)
  from this[THEN seqsim_sym] g1 have g3: "nextsuffix (x ## s) \<approx> nextsuffix (x ## t)"
    by (rule seqsim_sym[OF seqsim_trans])
  have "first (x ## s) = first (x ## t)" by (simp add: first_def app_def)
  from this g3 show ?thesis by (rule seqsimilarI)
qed

text {*
  If two sequences are similar then for any suffix of one of them there
  exists a similar suffix of the other one. We will prove a stronger
  result below.
*}

lemma simstep_disj1: assumes H: "s \<approx> t" shows "\<exists> m. ((s |\<^sub>s n) \<approx> (t |\<^sub>s m))"
proof (induct n)
  from H have "((s |\<^sub>s 0) \<approx> (t |\<^sub>s 0))" by auto
  thus "\<exists> m. ((s |\<^sub>s 0) \<approx> (t |\<^sub>s m))" ..
next
  fix n
  assume "\<exists> m. ((s |\<^sub>s n) \<approx> (t |\<^sub>s m))"
  then obtain m where a1': "(s |\<^sub>s n) \<approx> (t |\<^sub>s m)" ..
  show "\<exists> m. ((s |\<^sub>s (Suc n)) \<approx> (t |\<^sub>s m))"
  proof (cases "stutstep s n")
    case True
    hence "(s |\<^sub>s (Suc n)) \<approx> (s |\<^sub>s n)" by (rule seqsim_stutstep)
    from this a1' have "((s |\<^sub>s (Suc n)) \<approx> (t |\<^sub>s m))" by (rule seqsim_trans)
    thus ?thesis ..
  next
    case False
    hence "(s |\<^sub>s (Suc n)) \<approx> nextsuffix (s |\<^sub>s n)" by (rule seqsim_notstutstep)
    moreover
    from a1' have "nextsuffix (s |\<^sub>s n) \<approx> nextsuffix (t |\<^sub>s m)"
      by (simp add: seqsim_suffix_seqsim)
    ultimately have "(s |\<^sub>s (Suc n)) \<approx> nextsuffix (t |\<^sub>s m)" by (rule seqsim_trans)
    hence "(s |\<^sub>s (Suc n)) \<approx> t |\<^sub>s (m + (nextnat (t |\<^sub>s m)))"
      by (simp add: nextsuffix_def suffix_plus_com)
    thus "\<exists> m. (s |\<^sub>s (Suc n)) \<approx> t |\<^sub>s m" ..
  qed
qed

lemma nextnat_le_seqsim:
  assumes n: "n < nextnat s" shows "s \<approx> (s |\<^sub>s n)"
proof (cases "emptyseq s")
  case True   -- {* case impossible *}
  with n show ?thesis by (simp add: nextnat_def)
next
  case False
  from n show ?thesis
  proof (induct n)
    show "s \<approx> (s |\<^sub>s 0)" by simp
  next
    fix n
    assume a2: "n < nextnat s \<Longrightarrow> s \<approx> (s |\<^sub>s n)" and a3: "Suc n < nextnat s"
    from a3 have g1: "s (Suc n) = s 0" by (rule nextnat_le_unch)
    from a3 have a3': "n < nextnat s" by simp
    hence "s n = s 0" by (rule nextnat_le_unch)
    with g1 have "stutstep s n" by (simp add: stutstep_def)
    hence g2: "(s |\<^sub>s n) \<approx> (s |\<^sub>s (Suc n))" by (rule seqsim_stutstep[THEN seqsim_sym])
    with a3' a2 show "s \<approx> (s |\<^sub>s (Suc n))" by (auto elim: seqsim_trans)
  qed
qed

lemma seqsim_prev_nextnat: "s \<approx> s |\<^sub>s ((nextnat s) - 1)"
proof (cases "emptyseq s")
  case True
  hence "s |\<^sub>s ((nextnat s)-(1::nat)) = s |\<^sub>s 0" by (simp add: nextnat_def)
  thus ?thesis by simp
next
  case False
  hence "nextnat s > 0" by (rule nextnat_empty_gzero)
  thus ?thesis by (simp add: nextnat_le_seqsim)
qed

text {*
  Given a suffix @{text "s |\<^sub>s n"} of some sequence @{text "s"} that is
  similar to some suffix @{text "t |\<^sub>s m"} of sequence @{text "t"}, there
  exists some suffix @{text "t |\<^sub>s m'"} of @{text "t"} such that
  @{text "s |\<^sub>s n"} and @{text "t |\<^sub>s m'"} are similar and also
  @{text "s |\<^sub>s (n+1)"} is similar to either @{text "t |\<^sub>s m'"} or to
  @{text "t |\<^sub>s (m'+1)"}.
*}

lemma seqsim_suffix_suc:
  assumes H: "s |\<^sub>s n \<approx> t |\<^sub>s m"
  shows "\<exists>m'. s |\<^sub>s n \<approx> t |\<^sub>s m' \<and> ((s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m') \<or> (s |\<^sub>s Suc n \<approx> t |\<^sub>s m'))"
proof (cases "stutstep s n")
  case True
  hence "s |\<^sub>s Suc n \<approx> s |\<^sub>s n" by (rule seqsim_stutstep)
  from this H have "s |\<^sub>s Suc n \<approx> t |\<^sub>s m" by (rule seqsim_trans)
  with H show ?thesis by blast
next
  case False
  hence "\<not> emptyseq (s |\<^sub>s n)" by (rule stutnempty)
  with H have a2: "\<not> emptyseq (t |\<^sub>s m)" by (simp add: seqsim_empty_iff_empty)
  hence g4: "nextsuffix (t |\<^sub>s m) = (t |\<^sub>s m) |\<^sub>s Suc (nextnat (t |\<^sub>s m) - 1)"
    by (simp add: nextnat_empty_gzero nextsuffix_def)
  have g3: "(t |\<^sub>s m) \<approx> (t |\<^sub>s m) |\<^sub>s (nextnat (t |\<^sub>s m) - 1)"
    by (rule seqsim_prev_nextnat)
  with H have G1: "s |\<^sub>s n \<approx> (t |\<^sub>s m) |\<^sub>s (nextnat (t |\<^sub>s m) - 1)"
    by (rule seqsim_trans)
  from False have G1': "(s |\<^sub>s Suc n) = nextsuffix (s |\<^sub>s n)"
    by (rule notstutstep_nextsuffix1[THEN sym])
  from H have "nextsuffix (s |\<^sub>s n) \<approx> nextsuffix (t |\<^sub>s m)"
    by (rule seqsim_suffix_seqsim)
  with G1 G1' g4
  have "s |\<^sub>s n \<approx> t |\<^sub>s (m + (nextnat (t |\<^sub>s m) - 1))
      \<and> s |\<^sub>s (Suc n) \<approx> t |\<^sub>s Suc (m + (nextnat (t |\<^sub>s m) - 1))"
    by (simp add: suffix_plus_com)
  thus ?thesis by blast
qed

text {*
  The following main result about similar sequences shows that if
  @{text "s \<approx> t"} holds then for any suffix @{text "s |\<^sub>s n"} of @{text "s"}
  there exists a suffix @{text "t |\<^sub>s m"} such that
  \begin{itemize}
  \item @{text "s |\<^sub>s n"} and @{text "t |\<^sub>s m"} are similar, and
  \item @{text "s |\<^sub>s (n+1)"} is similar to either @{text "t |\<^sub>s (m+1)"}
    or @{text "t |\<^sub>s m"}.
  \end{itemize}
  The idea is to pick the largest @{text "m"} such that @{text "s |\<^sub>s n \<approx> t |\<^sub>s m"}
  (or some such @{text "m"} if @{text "s |\<^sub>s n"} is empty).
*}

theorem sim_step:
  assumes H: "s \<approx> t"
  shows "\<exists> m. s |\<^sub>s n \<approx> t |\<^sub>s m \<and>
              ((s |\<^sub>s Suc n \<approx> t |\<^sub>s Suc m) \<or> (s |\<^sub>s Suc n \<approx> t |\<^sub>s m))"
    (is "\<exists>m. ?Sim n m")
proof (induct n)
  from H have "s |\<^sub>s 0 \<approx> t |\<^sub>s 0" by simp
  thus "\<exists> m. ?Sim 0 m" by (rule seqsim_suffix_suc)
next
  fix n
  assume "\<exists> m. ?Sim n m"
  hence "\<exists>k. s |\<^sub>s Suc n \<approx> t |\<^sub>s k" by blast
  thus "\<exists> m. ?Sim (Suc n) m" by (blast dest: seqsim_suffix_suc)
qed

end


theory Isar_Demo
imports Main
begin

section{* An introductory example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall>A. \<exists>a. A = f a" by(simp add: surj_def)
  from 1 have 2: "\<exists>a. {x. x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

text{* A bit shorter: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from 1 show "False" by blast
qed

subsection{* this, then, hence and thus *}

text{* Avoid labels, use this: *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

text{* then = from this *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  then have "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then show "False" by blast
qed

text{* hence = then have, thus = then show *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

subsection{* Structured statements: fixes, assumes, shows *}

lemma
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -  (* no automatic proof step! *)
  have "\<exists> a. {x. x \<notin> f x} = f a" using s
    by(auto simp: surj_def)
  thus "False" by blast
qed

section{* Proof patterns *}

lemma "P \<longleftrightarrow> Q"
proof
  assume "P"
  show "Q" sorry
next
  assume "Q"
  show "P" sorry
qed

lemma "A = (B::'a set)"
proof
  show "A \<subseteq> B" sorry
next
  show "B \<subseteq> A" sorry
qed

lemma "A \<subseteq> B"
proof
  fix a
  assume "a \<in> A"
  show "a \<in> B" sorry
qed

text{* Contradiction *}

lemma P
proof (rule ccontr)
  assume "\<not>P"
  show "False" sorry
qed

text{* Case distinction *}

lemma "R"
proof cases
  assume "P"
  show "R" sorry
next
  assume "\<not> P"
  show "R" sorry
qed

lemma "R"
proof -
  have "P \<or> Q" sorry
  then show "R"
  proof
    assume "P"
    show "R" sorry
  next
    assume "Q"
    show "R" sorry
  qed
qed

text{* obtain example *}

lemma "\<not> surj(f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists>a. {x. x \<notin> f x} = f a" by(auto simp: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

text{* Interactive exercise: *}

lemma assumes "EX x. ALL y. P x y" shows "ALL y. EX x. P x y"
oops (* solution at the bottom *)

section{* Streamlining proofs *}

subsection{* Pattern matching and ?-variables *}

text{* Show EX *}

lemma "EX xs. length xs = 0" (is "EX xs. ?P xs")
proof
  show "?P([])" by simp
qed

text{* Multiple EX easier with forward proof: *}

lemma "EX x y :: int. x < z & z < y" (is "EX x y. ?P x y")
proof -
  have "?P (z - 1) (z + 1)" by arith
  thus ?thesis by blast
qed

subsection{* Quoting facts: *}

lemma assumes "x < (0::int)" shows "x*x > 0"
proof -
  from `x<0` show ?thesis by(metis mult_neg_neg)
qed

subsection {* Example: Top Down Proof Development *}

text{* The key idea: case distinction on length: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  show ?thesis sorry
next
  assume "\<not> (EX n. length xs = n+n)"
  show ?thesis sorry
qed

text{* A proof skeleton: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" sorry
  thus ?thesis by blast
next
  assume "\<not> (EX n. length xs = n+n)"
  then obtain n where "length xs = Suc(n+n)" sorry
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" sorry
  then show ?thesis by blast
qed

text{* The complete proof: *}

lemma "(EX ys zs. xs = ys @ zs \<and> length ys = length zs) |
  (EX ys zs. xs = ys @ zs & length ys = length zs + 1)"
proof cases
  assume "EX n. length xs = n+n"
  then obtain n where "length xs = n+n" by blast
  let ?ys = "take n xs"
  let ?zs = "take n (drop n xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs"
    by (simp add: `length xs = n + n`)
  thus ?thesis by blast
next
  assume "\<not> (EX n. length xs = n+n)"
  hence "EX n. length xs = Suc(n+n)" by arith
  then obtain n where l: "length xs = Suc(n+n)" by blast
  let ?ys = "take (Suc n) xs"
  let ?zs = "take n (drop (Suc n) xs)"
  have "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by (simp add: l)
  thus ?thesis by blast
qed

subsection {* moreover *}

lemma assumes "A \<and> B" shows "B \<and> A"
proof -
  from `A \<and> B` have "A" by auto
  moreover
  from `A \<and> B` have "B" by auto
  ultimately show "B \<and> A" by auto
qed

subsection{* Raw proof blocks *}

lemma fixes k :: int assumes "k dvd (n+k)" shows "k dvd n"
proof -
  { fix a assume a: "n+k = k*a"
    have "EX b. n = k*b"
    proof
      show "n = k*(a - 1)" using a by(simp add: algebra_simps)
    qed }
  with assms show ?thesis by (auto simp add: dvd_def)
qed

text{* Solution to interactive exercise: *}

lemma assumes "EX x. ALL y. P x y" shows "ALL y. EX x. P x y"
proof
  fix b
  from assms obtain a where 0: "ALL y. P a y" by blast
  show "EX x. P x b"
  proof
    show "P a b" using 0 by blast
  qed
qed

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
    Author: Gerwin Klein
*)

header {* Merge Sort *}

(*<*) theory ex imports Main begin (*>*)

subsection {* Sorting with lists *}

text {*
  For simplicity we sort natural numbers.

  Define a predicate @{term sorted} that checks if each element in the list is
  less or equal to the following ones; @{term "le n xs"} should be true iff
  @{term n} is less or equal to all elements of @{text xs}.
*}

consts
  le     :: "nat \<Rightarrow> nat list \<Rightarrow> bool"
  sorted :: "nat list \<Rightarrow> bool"

text {*
  Define a function @{term "count xs x"} that counts how often @{term x} occurs
  in @{term xs}.
*}

consts
  count :: "nat list => nat => nat"

subsection {* Merge sort *}

text {*
  Implement \emph{merge sort}: a list is sorted by splitting it into two lists,
  sorting them separately, and merging the results.

  With the help of @{text recdef} define two functions
*}

consts merge :: "nat list \<times> nat list \<Rightarrow> nat list"
       msort :: "nat list \<Rightarrow> nat list"

text {* and show *}

theorem "sorted (msort xs)"
(*<*)oops(*>*)

theorem "count (msort xs) x = count xs x"
(*<*)oops(*>*)

text {*
  You may have to prove lemmas about @{term sorted} and @{term count}.

  Hints:
  \begin{itemize}
  \item For @{text recdef} see Section~3.5 of the Isabelle/HOL tutorial.

  \item To split a list into two halves of almost equal length you can use the
  functions \mbox{@{text "n div 2"}}, @{term take} und @{term drop}, where
  @{term "take n xs"} returns the first @{text n} elements of @{text xs} and
  @{text "drop n xs"} the remainder.

  \item Here are some potentially useful lemmas:\\
    @{text "linorder_not_le:"} @{thm linorder_not_le [no_vars]}\\
    @{text "order_less_le:"} @{thm order_less_le [no_vars]}\\
    @{text "min_def:"} @{thm min_def [no_vars]}
  \end{itemize}
*}

(*<*) end (*>*)


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: Time.thy                                                             *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 14 Sept 2017 *)

section {* Time Model *}

theory Time
  imports
    "../optics/Two"
    "../continuum/Continuum"
    "../utils/Positive"
begin

text {*
  The rationale for this theory is to define an abstract model of time that
  identifies reasonable assumptions that are sufficient for reasoning about
  time, namely without having to specify in detail the notion of time that
  we are dealing with such as discrete, continuous or super-dense time.
*}

subsection {* Abstract Time *}

text {*
  We introduce permissible time domains abstractly as a type class. Clearly,
  the elements of the type have to be linearly ordered while membership to
  the class @{class semidom_divide} entails many key properties of addition,
  subtraction, multiplication and division. Note that we cannot require time
  to form a field as there may not be an additive inverse i.e.~if we confine
  ourselves to positive time instants. Lastly, we also assume that time does
  not stop, meaning that the ordering is unbounded (class @{class no_top});
  there may be a bottom though which, if so, must be the same as @{term 0}.
*}

class time = linorder + semidom_divide + no_top

text {*
  Positive time makes the additional assumption that the ordering has a bottom
  which must be @{const zero}.
*}

class pos_time = time + zero + order_bot +
assumes zero_is_bot: "0 = \<bottom>"

text {*
  I wonder if we can get away with weaker assumptions below. It would mean that
  we may also be able to instantiate @{typ "int pos"} as both @{class time} and
  @{class pos_time} (note that integers do not form a field). If not, this is
  not an issue of course, since we can otherwise always use @{typ nat} in place
  of the type @{typ "int pos"}.
*}

instance pos :: (linordered_field) time
apply (intro_classes)
done

instantiation pos :: (linordered_field) pos_time
begin
lift_definition bot_pos :: "'a pos"
is "0" ..
instance
apply (intro_classes)
apply (transfer; simp)
apply (transfer; simp)
done
end

subsection {* Discrete Time *}

text {* Naturals, integers and rationals are used to model discrete time. *}

instance nat :: time
apply (intro_classes)
done

instance int :: time
apply (intro_classes)
done

instance rat :: time
apply (intro_classes)
done

instantiation nat :: pos_time
begin
instance
apply (intro_classes)
apply (unfold bot_nat_def)
apply (rule refl)
done
end

subsection {* Continuous Time *}

text {* Reals and positive reals are used to model continuous time. *}

type_notation real ("\<real>")

type_synonym pos_real = "real pos" ("\<real>\<^sup>+")

translations (type) "\<real>\<^sup>+" \<leftharpoondown> (type) "real pos"

instance real :: time
apply (intro_classes)
done

text {*
  Membership of @{typ pos_real} to the sort @{class time} follows from the
  earlier instantiation of @{typ "'a pos"} as class @{class time}, provided
  the type parameter @{typ "'a"} constitutes a @{class linordered_field}.
*}

subsection {* Instantiations *}

text {* Instantiation of class @{class time}. *}

lemma "OFCLASS(nat, time_class)" ..
lemma "OFCLASS(int, time_class)" ..
lemma "OFCLASS(rat, time_class)" ..
lemma "OFCLASS(real, time_class)" ..
lemma "OFCLASS(rat pos, time_class)" ..
lemma "OFCLASS(real pos, time_class)" ..

text {* Instantiation of class @{class pos_time}. *}

lemma "OFCLASS(nat, pos_time_class)" ..
lemma "OFCLASS(rat pos, pos_time_class)" ..
lemma "OFCLASS(real pos, pos_time_class)" ..

text {* Instantiation of class @{class two}. *}

lemma "OFCLASS(nat, two_class)" ..
lemma "OFCLASS(int, two_class)" ..
lemma "OFCLASS(rat, two_class)" ..
lemma "OFCLASS(real, two_class)" ..
lemma "OFCLASS(int pos, two_class)" ..
lemma "OFCLASS(rat pos, two_class)" ..
lemma "OFCLASS(real pos, two_class)" ..

text {* Instantiation of class @{class continuum}. *}

lemma "OFCLASS(nat, continuum_class)" ..
lemma "OFCLASS(int, continuum_class)" ..
lemma "OFCLASS(rat, continuum_class)" ..
lemma "OFCLASS(real, continuum_class)" ..
lemma "OFCLASS(int pos, continuum_class)" ..
lemma "OFCLASS(rat pos, continuum_class)" ..
lemma "OFCLASS(real pos, continuum_class)" ..
end


(* Title:      Residuated Lattices
   Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

theory Residuated_Lattices
  imports Kleene_Algebra.Signatures
begin

notation
  times (infixl "\<cdot>" 70)

notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf (infixl "\<sqinter>" 65) and
  sup (infixl "\<squnion>" 65) and
  Inf ("\<Sqinter>_" [900] 900) and
  Sup ("\<Squnion>_" [900] 900)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

section \<open>Residuated Lattices\<close>

subsection \<open>Residuated Functions on a Partial Order\<close>

text \<open>
  We follow Galatos and \emph{al.} to define residuated funtions on
  partial orders. Material from articles by Maddux, and J{\'o}sson and Tsinakis are also considered.

  This development should in the future be expanded to functions or categories where the sources and targets have
  different type.

  Let $P$ be a partial order, or a poset.
  A map $f : P \to P$ is residuated if there exists a map
  $g: P \to P$ such that $f(x) \le y \Leftrightarrow x \le g(y)$
  for all $x, y \in P$.
  That is, they are adjoints of a Galois connection.
\<close>

context order begin

definition residuated_pair :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "residuated_pair f g \<equiv> \<forall>x y. f(x) \<le> y \<longleftrightarrow> x \<le> g(y)"

theorem residuated_pairI [intro]:
  assumes "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
  and "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
  and "\<forall>x. x \<le> (g o f) x"
  and "\<forall>x. (f o g) x \<le> x"
  shows "residuated_pair f g"
  by (metis assms comp_apply local.order_trans residuated_pair_def antisym)

definition residuated :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "residuated f \<equiv> \<exists>g. residuated_pair f g"

text \<open>
  If a map $f$ is residuated, then its residual $g$ is unique.
\<close>

lemma residual_unique: "residuated f \<Longrightarrow> \<exists>!g. residuated_pair f g"
  unfolding residuated_def residuated_pair_def
  by (metis ext eq_refl order.antisym)

text \<open>
  Since the residual of a map $f$ is unique, it makes sense to
  define a residual operator.
\<close>

definition residual :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
  "residual f \<equiv> THE g. residuated_pair f g"

lemma residual_galois: "residuated f \<Longrightarrow> f(x) \<le> y \<longleftrightarrow> x \<le> residual f y"
  apply (clarsimp simp: residuated_def residuated_pair_def)
  apply (subgoal_tac "residual f = g")
  apply (simp_all add: residual_def)
  apply (rule the1_equality)
  apply (metis residuated_def residuated_pair_def residual_unique)
  by (simp add: residuated_pair_def)

lemma residual_galoisI1: "residuated f \<Longrightarrow> f(x) \<le> y \<Longrightarrow> x \<le> residual f y"
  by (metis residual_galois)

lemma residual_galoisI2: "residuated f \<Longrightarrow> x \<le> residual f y \<Longrightarrow> f(x) \<le> y"
  by (metis residual_galois)

text \<open>
  A closure operator on a poset is a map that is expansive, isotone and
  idempotent.
  The composition of the residual of a function $f$ with $f$ is a closure operator.
\<close>

definition closure :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "closure f \<equiv> (\<forall>x. x \<le> f x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"

lemma res_c1: "residuated f \<Longrightarrow> x \<le> residual f (f x)"
  by (metis local.order.refl residual_galois)

lemma res_c2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f (f x) \<le> residual f (f y)"
  by (metis local.order.refl local.order_trans residual_galois)

lemma res_c3: "residuated f \<Longrightarrow> residual f (f (residual f (f x))) = residual f (f x)"
  by (metis local.eq_iff local.order_trans res_c1 residual_galois)

lemma res_closure: "residuated f \<Longrightarrow> closure (residual f o f)"
  by (auto simp: closure_def intro: res_c1 res_c2 res_c3)

text \<open>
  Dually, an interior operator on a poset is a map that is contractive, isotone and
  idempotent.
  The composition of $f$ with its residual is an interior operator.
\<close>

definition interior :: "('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "interior f \<equiv> (\<forall>x. f x \<le> x) \<and> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y) \<and> (\<forall>x. f(f x) = f x)"

lemma res_i1: "residuated f \<Longrightarrow> f (residual f x) \<le> x"
  by (metis local.order.refl residual_galois)

lemma res_i2: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f (residual f x) \<le> f (residual f y)"
  by (metis local.order.refl local.order_trans residual_galois)

lemma res_i3: "residuated f \<Longrightarrow> f (residual f (f (residual f x))) = f (residual f x)"
  by (metis local.antisym_conv res_c1 res_c3 res_i1 residual_galois)

lemma res_interior: "residuated f \<Longrightarrow> interior (f o residual f)"
  by (auto simp: interior_def intro: res_i1 res_i2 res_i3)

text \<open>Next we show a few basic lemmas about residuated maps.\<close>

lemma res_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  by (metis local.order.trans res_c1 residual_galois)

lemma res_residual_iso: "residuated f \<Longrightarrow> x \<le> y \<Longrightarrow> residual f x \<le> residual f y"
  by (metis local.order.trans res_i1 residual_galois)

lemma res_comp1 [simp]: "residuated f \<Longrightarrow> f o residual f o f = f"
proof -
  assume resf: "residuated f"
  {
    fix x
    have "(f o residual f o f) x = f x"
      by (metis resf comp_apply local.eq_iff res_c1 res_i1 res_iso)
  }
  thus ?thesis
    by (metis ext)
qed

lemma res_comp2 [simp]: "residuated f \<Longrightarrow> residual f o f o residual f = residual f"
proof -
  assume resf: "residuated f"
  {
    fix x
    have "(residual f o f o residual f) x = residual f x"
      by (metis resf comp_apply local.eq_iff res_c1 res_i1 res_residual_iso)
  }
  thus ?thesis
    by (metis ext)
qed

end (* order *)

text \<open>
  A residuated function $f$ preserves all existing joins.
  Dually, its residual preserves all existing meets.
  We restrict our attention to semilattices, where binary joins or meets exist, and to
  complete lattices, where arbitrary joins and meets exist.
\<close>

lemma (in semilattice_sup) residuated_sup: "residuated f \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
proof (rule antisym)
  assume assm: "residuated f"
  thus "f (x \<squnion> y) \<le> f x \<squnion> f y"
    by (metis local.residual_galoisI1 local.residual_galoisI2 local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
  show "f x \<squnion> f y \<le> f (x \<squnion> y)"
    by (metis assm local.res_iso local.sup.bounded_iff local.sup_ge1 local.sup_ge2)
qed

lemma (in semilattice_inf) residuated_inf: "residuated f \<Longrightarrow> residual f (x \<sqinter> y) = residual f x \<sqinter> residual f y"
proof (rule antisym)
  assume assm: "residuated f"
  thus "residual f (x \<sqinter> y) \<le> residual f x \<sqinter> residual f y"
    by (metis local.inf.boundedI local.inf.cobounded1 local.inf.cobounded2 local.res_residual_iso)
  show "residual f x \<sqinter> residual f y \<le> residual f (x \<sqinter> y)"
    by (metis assm local.inf.bounded_iff local.inf.cobounded1 local.inf.cobounded2 local.residual_galoisI1 local.residual_galoisI2)
qed

context bounded_lattice begin

lemma residuated_strict: "residuated f \<Longrightarrow> f \<bottom> = \<bottom>"
  by (metis local.bot_least local.bot_unique local.res_i1 local.res_iso)

lemma res_top: "residuated f \<Longrightarrow> residual f \<top> = \<top>"
  by (metis local.residual_galoisI1 local.top_greatest local.top_unique)

end

context complete_lattice begin

text \<open>
  On a complete lattice, a function $f$ is residuated if and only if
  it preserves arbitrary (possibly infinite) joins.
  Dually, a function $g$ is a residual of a residuated funtion $f$
  if and only if $g$ preserver arbitrary meets.
\<close>

lemma residual_eq1: "residuated f \<Longrightarrow> residual f y = \<Squnion> {x. f x \<le> y}"
proof (rule antisym)
  assume assm: "residuated f"
  thus "residual f y \<le> \<Squnion>{x. f x \<le> y}"
    by (auto simp: res_i1 intro!: Sup_upper)
  show "\<Squnion>{x. f x \<le> y} \<le> residual f y"
    by (auto simp: assm intro!: Sup_least residual_galoisI1)
qed

lemma residual_eq2: "residuated f \<Longrightarrow> f x = \<Sqinter> {y. x \<le> residual f y}"
proof (rule antisym)
  assume assm: "residuated f"
  thus "f x \<le> \<Sqinter>{y. x \<le> residual f y}"
    by (auto intro: Inf_greatest residual_galoisI2)
  show "\<Sqinter>{y. x \<le> residual f y} \<le> f x"
    using assm by (auto simp: res_c1 intro!: Inf_lower)
qed

lemma residuated_Sup: "residuated f \<Longrightarrow> f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X}"
proof (rule antisym)
  assume assm: "residuated f"
  obtain y where y_def: "y = \<Squnion>{f x |x. x \<in> X}"
    by auto
  hence "\<forall>x \<in> X. f x \<le> y"
    by (auto simp: y_def intro: Sup_upper)
  hence "\<forall>x \<in> X. x \<le> residual f y"
    by (auto simp: assm intro!: residual_galoisI1)
  hence "\<Squnion>X \<le> residual f y"
    by (auto intro: Sup_least)
  thus "f(\<Squnion> X) \<le> \<Squnion>{f x |x. x \<in> X}"
    by (metis y_def assm residual_galoisI2)
qed (clarsimp intro!: Sup_least res_iso Sup_upper)

lemma residuated_Inf: "residuated f \<Longrightarrow> residual f(\<Sqinter> X) = \<Sqinter>{residual f x | x. x \<in> X}"
proof (rule antisym, clarsimp intro!: Inf_greatest res_residual_iso Inf_lower)
  assume assm: "residuated f"
  obtain y where y_def: "y = \<Sqinter>{residual f x |x. x \<in> X}"
    by auto
  hence "\<forall>x \<in> X. y \<le> residual f x"
    by (auto simp: y_def intro: Inf_lower)
  hence "\<forall>x \<in> X. f y \<le> x"
    by (metis assm residual_galoisI2)
  hence "f y \<le> \<Sqinter> X"
    by (auto intro: Inf_greatest)
  thus "\<Sqinter>{residual f x |x. x \<in> X} \<le> residual f (\<Sqinter>X)"
    by (auto simp: assm y_def intro!: residual_galoisI1)
qed

lemma Sup_sup: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> f (x \<squnion> y) = f x \<squnion> f y"
  apply (erule_tac x="{x, y}" in allE)
  by (force intro: Sup_eqI)

lemma Sup_residuatedI: "\<forall>X. f(\<Squnion> X) = \<Squnion>{f x | x. x \<in> X} \<Longrightarrow> residuated f"
proof (unfold residuated_def residuated_pair_def, standard+)
  fix x y
  assume "f x \<le> y"
  thus "x \<le> \<Squnion>{x. f x \<le> y}"
    by (clarsimp intro!: Sup_upper)
next
  fix x y
  assume assm: "\<forall>X. f (\<Squnion>X) = \<Squnion>{f x |x. x \<in> X}"
  hence f_iso: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
    using Sup_sup by (auto simp: le_iff_sup)
  assume "x \<le> \<Squnion>{x. f x \<le> y}"
  hence "f x \<le> f(\<Squnion>{x. f x \<le> y})"
    by (metis f_iso)
  also have "... = \<Squnion>{f x | x . f x \<le> y}"
    using assm by auto
  finally show "f x \<le> y"
    apply (rule order_trans)
    by (auto intro!: Sup_least)
qed

lemma Inf_inf: "\<forall>X. f(\<Sqinter> X) = \<Sqinter>{f x | x. x \<in> X} \<Longrightarrow> f (x \<sqinter> y) = f x \<sqinter> f y"
  apply (erule_tac x="{x, y}" in allE)
  by (force intro: Inf_eqI)

lemma Inf_residuatedI: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X) \<Longrightarrow> \<exists>f. residuated_pair f g"
proof (unfold residuated_pair_def, standard+)
  fix x y
  assume "x \<le> g y"
  thus "\<Sqinter>{y. x \<le> g y} \<le> y"
    by (clarsimp intro!: Inf_lower)
next
  fix x y
  assume assm: "\<forall>X. \<Sqinter>{g x | x. x \<in> X} = g (\<Sqinter> X)"
  hence g_iso: "\<forall>x y. x \<le> y \<longrightarrow> g x \<le> g y"
    using Inf_inf by (auto simp: le_iff_inf)
  assume "\<Sqinter>{y. x \<le> g y} \<le> y"
  hence "g (\<Sqinter>{y. x \<le> g y}) \<le> g y"
    by (metis g_iso)
  hence "(\<Sqinter>{g y | y. x \<le> g y}) \<le> g y"
    using assm apply (erule_tac x="{y. x \<le> g y}" in allE)
    by (auto intro!: Inf_lower)
  thus "x \<le> g y"
    apply (rule local.dual_order.trans)
    by (auto intro: Inf_greatest)
qed

end (* complete lattices *)

subsection \<open>Residuated Structures\<close>

text \<open>
  In this section, we define residuated algebraic structures, starting from the simplest of all,
  a \emph{residuated partial ordered groupoid}, to
  \emph{residuated l-monoids}, which are residuated
  lattices where the multiplicative operator forms a monoid.
\<close>

class pogroupoid = order + times +
  assumes mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  and mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"

text \<open>
  A residuated partial ordered groupoid is simply a partial order and a multiplicative groupoid with
  two extra operators satisfying the residuation laws.
  It is straighforward to prove that multiplication is compatible with the order,
  that is, multiplication is isotone.

  Most of the lemmas below come in pairs; they are related by opposition duality.
  Formalising this duality is left for future work.
\<close>

class residual_r_op =
  fixes residual_r :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60)

class residual_l_op =
  fixes residual_l :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60)

class residuated_pogroupoid = order + times + residual_l_op + residual_r_op +
  assumes resl_galois: "x \<le> z \<leftarrow> y \<longleftrightarrow> x \<cdot> y \<le> z"
  and resr_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
begin

lemma reslI [intro]: "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
  by (metis resl_galois)

lemma residuated_pair_multl [simp]: "residuated_pair (\<lambda>x. x \<cdot> y) (\<lambda>x. x \<leftarrow> y)"
  by (auto simp: residuated_pair_def resl_galois)

lemma residuated_pair_multr [simp]: "residuated_pair (\<lambda>y. x \<cdot> y) (\<lambda>y. x \<rightarrow> y)"
  by (auto simp: residuated_pair_def resr_galois)

text \<open>
  Multiplication is then obviously residuated.
\<close>

lemma residuated_multl [simp]: "residuated (\<lambda>x. x \<cdot> y)"
  by (metis residuated_def residuated_pair_multl)

lemma residuated_multr [simp]: "residuated (\<lambda>y. x \<cdot> y)"
  by (metis residuated_def residuated_pair_multr)

lemma resl_eq [simp]: "residual (\<lambda>x. x \<cdot> y) = (\<lambda>x. x \<leftarrow> y)"
  unfolding residual_def apply (rule the1_equality)
  by (auto simp: intro!: residual_unique)

lemma resr_eq [simp]: "residual (\<lambda>y. x \<cdot> y) = (\<lambda>y. x \<rightarrow> y)"
  unfolding residual_def apply (rule the1_equality)
  by (auto simp: intro!: residual_unique)

text \<open>
  Next we prove a few lemmas, all of which are instantiation of more general facts about residuated functions.
\<close>

lemma res_lc1: "x \<le> x \<cdot> y \<leftarrow> y"
  by auto

lemma res_lc2: "x \<le> y \<Longrightarrow> x \<cdot> z \<leftarrow> z \<le> y \<cdot> z \<leftarrow> z"
  by (metis local.res_c2 resl_eq residuated_multl)

lemma res_lc3 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<cdot> y \<leftarrow> y"
  by (metis local.res_c3 resl_eq residuated_multl)

lemma res_rc1: "x \<le> y \<rightarrow> y \<cdot> x"
  by auto

lemma res_rc2: "x \<le> y \<Longrightarrow> z \<rightarrow> z \<cdot> x \<le> z \<rightarrow> z \<cdot> y"
  by (metis local.res_c2 resr_eq residuated_multr)

lemma res_rc3 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<rightarrow> y \<cdot> x"
  by (metis local.res_c3 resr_eq residuated_multr)

lemma res_li1: "(x \<leftarrow> y) \<cdot> y \<le> x"
  by (metis local.res_i1 resl_eq residuated_multl)

lemma res_li2: "x \<le> y \<Longrightarrow> (x \<leftarrow> z) \<cdot> z \<le> (y \<leftarrow> z) \<cdot> z"
  by (metis local.res_i2 resl_eq residuated_multl)

lemma res_li3 [simp]: "((x \<leftarrow> y) \<cdot> y \<leftarrow> y) \<cdot> y = (x \<leftarrow> y) \<cdot> y"
  by (metis local.res_i3 resl_eq residuated_multl)

lemma res_ri1: "y \<cdot> (y \<rightarrow> x) \<le> x"
  by (metis local.res_i1 resr_eq residuated_multr)

lemma res_ri2: "x \<le> y \<Longrightarrow> z \<cdot> (z \<rightarrow> x) \<le> z \<cdot> (z \<rightarrow> y)"
  by (metis local.res_i2 resr_eq residuated_multr)

lemma res_ri3 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> (y \<rightarrow> x)) = y \<cdot> (y \<rightarrow> x)"
  by (metis local.res_i3 resr_eq residuated_multr)

subclass pogroupoid
proof
  fix x y z
  show "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
    by (metis local.res_iso residuated_multl)
  show "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
    by (metis local.res_iso residuated_multr)
qed

lemma resl_iso: "x \<le> y \<Longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
  by (metis res_residual_iso resl_eq residuated_multl)

lemma resr_iso: "x \<le> y \<Longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
  by (metis res_residual_iso resr_eq residuated_multr)

lemma resl_comp1 [simp]: "(x \<cdot> y \<leftarrow> y) \<cdot> y = x \<cdot> y"
  by (metis local.antisym local.mult_isor res_lc1 res_li1)

lemma resl_comp2 [simp]: "(x \<leftarrow> y) \<cdot> y \<leftarrow> y = x \<leftarrow> y"
  by (metis local.eq_iff res_lc1 res_li1 resl_iso)

lemma resr_comp1 [simp]: "y \<cdot> (y \<rightarrow> y \<cdot> x) = y \<cdot> x"
  by (metis local.antisym local.mult_isol res_rc1 res_ri1)

lemma resr_comp2 [simp]: "y \<rightarrow> y \<cdot> (y \<rightarrow> x) = y \<rightarrow> x"
  by (metis local.eq_iff res_rc1 res_ri1 resr_iso)

lemma resl_antitoner: "x \<le> y \<longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
  by (metis local.dual_order.trans local.mult_isol res_li1 reslI)

lemma resr_antitonel: "x \<le> y \<longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis local.dual_order.trans local.resl_galois res_ri1 resrI)

text \<open>The following lemmas are taken from Galatos and \emph{al.}\<close>

lemma jipsen1l: "x \<le> y \<leftarrow> (x \<rightarrow> y)"
  by (metis res_ri1 reslI)

lemma jipsen1r: "x \<le> (y \<leftarrow> x) \<rightarrow> y"
  by (metis res_li1 resrI)

lemma jipsen2l: "(y \<leftarrow> (x \<rightarrow> y)) \<rightarrow> y = x \<rightarrow> y"
  by (metis jipsen1l jipsen1r local.eq_iff local.resr_antitonel)

lemma jipsen2r: "y \<leftarrow> ((y \<leftarrow> x) \<rightarrow> y) = y \<leftarrow> x"
  by (metis jipsen1l jipsen1r local.eq_iff local.resl_antitoner)

end (* residuated_pogroupoid *)

text \<open>
  In a residuated partial ordered semigroup, the multiplicative operator is associative.
\<close>

class residuated_posemigroup = semigroup_mult + residuated_pogroupoid
begin

lemma resl_trans: "(x \<leftarrow> y)  \<cdot>  (y \<leftarrow> z) \<le> x \<leftarrow> z"
  by (metis local.res_li1 local.resl_antitoner local.resl_galois mult_assoc)

lemma resr_trans: "(x \<rightarrow> y)  \<cdot>  (y \<rightarrow> z) \<le> x \<rightarrow> z"
  by (metis local.res_ri1 local.resr_antitonel local.resr_galois mult_assoc)

lemma resr1: "(x \<rightarrow> y) \<cdot> z \<le> (x \<rightarrow> y \<cdot> z)"
  by (metis local.mult_isor local.res_ri1 local.resrI mult_assoc)

lemma resr2: "x \<rightarrow> y \<le> z \<cdot> x \<rightarrow> z \<cdot> y"
  by (metis local.mult_isol local.res_ri1 local.resrI mult_assoc)

lemma resr3: "x \<cdot> y \<rightarrow> z = y \<rightarrow> (x \<rightarrow> z)"
  by (metis local.eq_iff local.resr_galois mult_assoc)

lemma resl1: "z \<cdot> (x \<leftarrow> y) \<le> (z \<cdot> x \<leftarrow> y)"
  by (metis local.mult_isol local.res_li1 local.reslI mult_assoc)

lemma resl2: "x \<leftarrow> y \<le> x \<cdot> z \<leftarrow> y \<cdot> z"
  by (metis local.mult_isor local.res_li1 local.reslI mult_assoc)

lemma resl3: "x \<leftarrow> y \<cdot> z = (x \<leftarrow> z) \<leftarrow> y"
  by (metis local.eq_iff local.resl_galois mult_assoc)

lemma residual_assoc: "x \<rightarrow> (y \<leftarrow> z) = (x \<rightarrow> y) \<leftarrow> z"
proof (rule antisym)
  show "x \<rightarrow> (y \<leftarrow> z) \<le> (x \<rightarrow> y) \<leftarrow> z"
    by (metis local.res_ri1 local.resl_galois local.resr_galois mult_assoc)
  show "(x \<rightarrow> y) \<leftarrow> z \<le> x \<rightarrow> (y \<leftarrow> z)"
    by (metis local.res_li1 local.resl_galois local.resr_galois mult_assoc)
qed

end (* residuated_posemigroup *)

text \<open>
  In a residuated partially ordered monoid, the multiplicative operator has a unit $1$; that is,
  its reduct forms a monoid.
\<close>

class residuated_pomonoid = monoid_mult + residuated_pogroupoid
begin

subclass residuated_posemigroup ..

lemma resl_unit: "x \<leftarrow> 1 = x"
  by (metis local.mult_1_right local.resl_comp1)

lemma resr_unit: "1 \<rightarrow> x = x"
  by (metis local.mult_1_left local.resr_comp1)

lemma mult_one_resl: "x \<cdot> (1 \<leftarrow> y) \<le> x \<leftarrow> y"
  by (metis local.mult_1_right local.resl1)

lemma mult_one_resr: "(x \<rightarrow> 1) \<cdot> y \<le> x \<rightarrow> y"
  by (metis local.mult_1_left local.resr1)

text \<open>More lemmas from Galatos and \emph{al.} follow.\<close>

lemma jipsen3l: "1 \<le> x \<leftarrow> x"
  by (metis local.jipsen1l resr_unit)

lemma jipsen3r: "1 \<le> x \<rightarrow> x"
  by (metis local.jipsen1r resl_unit)

lemma jipsen4l [simp]: "(x \<leftarrow> x) \<cdot> x = x"
  by (metis local.mult_1_left local.resl_comp1)

lemma jipsen4r [simp]: "x \<cdot> (x \<rightarrow> x) = x"
  by (metis local.mult_1_right local.resr_comp1)

lemma jipsen5l [simp]: "(x \<leftarrow> x) \<cdot> (x \<leftarrow> x) = x \<leftarrow> x"
  by (metis jipsen4l local.resl3)

lemma jipsen5r [simp]: "(x \<rightarrow> x) \<cdot> (x \<rightarrow> x) = x \<rightarrow> x"
  by (metis jipsen4r local.resr3)

lemma jipsen6l: "y \<leftarrow> x \<le> (y \<leftarrow> z) \<leftarrow> (x \<leftarrow> z)"
  by (metis local.resl_galois local.resl_trans)

lemma jipsen6r: "x \<rightarrow> y \<le> (z \<rightarrow> x) \<rightarrow> (z \<rightarrow> y)"
  by (metis local.resr_galois local.resr_trans)

lemma jipsen7l: "y \<leftarrow> x \<le> (z \<leftarrow> y) \<rightarrow> (z \<leftarrow> x)"
  by (metis local.resr_galois local.resl_trans)

lemma jipsen7r: "x \<rightarrow> y \<le> (x \<rightarrow> z) \<leftarrow> (y \<rightarrow> z)"
  by (metis local.resl_galois local.resr_trans)

end (* residuated_pomonoid *)

text \<open>
  Residuated partially ordered groupoids can be expanded residuated join semilattice ordered groupoids.
  They are used as a base for action algebras, which are expansions
  of Kleene algebras by operations of residuation.
  Action algebras can be found in the AFP entry for Kleene algebras.
\<close>

class residuated_sup_lgroupoid = semilattice_sup + residuated_pogroupoid
begin

lemma distl: "x \<cdot> (y \<squnion> z) = x \<cdot> y \<squnion> x \<cdot> z"
  by (metis local.residuated_multr local.residuated_sup)

lemma distr: "(x \<squnion> y) \<cdot> z = x \<cdot> z \<squnion> y \<cdot> z"
  by (metis local.residuated_multl local.residuated_sup)

lemma resl_subdist_var: "x \<leftarrow> z \<le> (x \<squnion> y) \<leftarrow> z"
  by (metis local.resl_iso local.sup_ge1)

lemma resl_subdist: "(x \<leftarrow> z) \<squnion> (y \<leftarrow> z) \<le> (x \<squnion> y) \<leftarrow> z"
  by (metis local.le_sup_iff local.sup_commute resl_subdist_var)

lemma resr_subdist_var: "(x \<rightarrow> y) \<le> x \<rightarrow> (y \<squnion> z)"
  by (metis local.resr_iso local.sup_ge1)

lemma resr_subdist: "(x \<rightarrow> y) \<squnion> (x \<rightarrow> z) \<le> x \<rightarrow> (y \<squnion> z)"
  by (metis sup_commute sup_least resr_subdist_var)

lemma resl_superdist_var: "x \<leftarrow> (y \<squnion> z) \<le> x \<leftarrow> y"
  by (metis local.le_sup_iff local.res_li1 local.reslI local.resr_galois)

lemma resr_superdist_var: "(x \<squnion> y) \<rightarrow> z \<le> x \<rightarrow> z"
  by (metis local.le_sup_iff local.res_ri1 local.resl_galois local.resrI)

end (* residuated_sup_lgroupoid *)

text \<open>
  Similarly, semigroup and monoid variants can be defined.
\<close>

class residuated_sup_lsemigroup = semilattice_sup + residuated_posemigroup
subclass (in residuated_sup_lsemigroup) residuated_sup_lgroupoid ..

class residuated_sup_lmonoid = semilattice_sup + residuated_posemigroup
subclass (in residuated_sup_lmonoid) residuated_sup_lsemigroup ..

text \<open>
  By lattice duality, we define residuated meet semillatice ordered groupoid.
\<close>

class residuated_inf_lgroupoid = semilattice_inf + residuated_pogroupoid
begin

lemma resl_dist: "(x \<sqinter> y) \<leftarrow> z = (x \<leftarrow> z) \<sqinter> (y \<leftarrow> z)"
  by (metis local.resl_eq local.residuated_inf local.residuated_multl)

lemma resr_dist: "x \<rightarrow> (y \<sqinter> z) = (x \<rightarrow> y) \<sqinter> (x \<rightarrow> z)"
  by (metis local.resr_eq local.residuated_inf local.residuated_multr)

lemma resl_inf_superdist: "x \<leftarrow> y \<le> x \<leftarrow> (y \<sqinter> z)"
  by (metis local.inf_le1 local.resl_antitoner)

lemma resr_inf_superdist_var: "x \<rightarrow> y \<le> (x \<sqinter> z) \<rightarrow> y"
  by (metis local.inf_le1 local.resr_antitonel)

end (* residuated_inf_lgroupoid *)

class residuated_inf_lsemigroup = semilattice_inf + residuated_posemigroup
subclass (in residuated_inf_lsemigroup) residuated_inf_lgroupoid ..

class residuated_inf_lmonoid = semilattice_inf + residuated_posemigroup
subclass (in residuated_inf_lmonoid) residuated_inf_lsemigroup ..

text \<open>
  Finally, we obtain residuated lattice groupoids.
\<close>

class residuated_lgroupoid = lattice + residuated_pogroupoid
begin

subclass residuated_sup_lgroupoid ..

lemma resl_distr: "z \<leftarrow> (x \<squnion> y) = (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
proof (rule antisym)
  show "z \<leftarrow> x \<squnion> y \<le> (z \<leftarrow> x) \<sqinter> (z \<leftarrow> y)"
    by (metis local.inf.bounded_iff local.resl_superdist_var local.sup_commute)
  show "(z \<leftarrow> x) \<sqinter> (z \<leftarrow> y) \<le> z \<leftarrow> x \<squnion> y"
    by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup.bounded_iff)
qed

lemma resr_distl: "(x \<squnion> y) \<rightarrow> z = (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
proof (rule antisym)
  show "x \<squnion> y \<rightarrow> z \<le> (x \<rightarrow> z) \<sqinter> (y \<rightarrow> z)"
    by (metis local.inf.bounded_iff local.resr_antitonel local.resr_superdist_var local.sup_ge2)
  show "(x \<rightarrow> z) \<sqinter> (y \<rightarrow> z) \<le> x \<squnion> y \<rightarrow> z"
    by (metis local.inf.cobounded1 local.inf.cobounded2 local.resl_galois local.resr_galois local.sup_least)
qed

end (* residuated_lgroupoid *)

class residuated_lsemigroup = lattice + residuated_sup_lsemigroup
subclass (in residuated_lsemigroup) residuated_lgroupoid ..

class residuated_lmonoid = lattice + residuated_sup_lmonoid
subclass (in residuated_lmonoid) residuated_lsemigroup ..

class residuated_blgroupoid = bounded_lattice + residuated_pogroupoid
begin

lemma multl_strict [simp]: "x \<cdot> \<bottom> = \<bottom>"
  by (metis local.residuated_multr local.residuated_strict)

lemma multr_strict [simp]: "\<bottom> \<cdot> x = \<bottom>"
  by (metis local.residuated_multl local.residuated_strict)

lemma resl_top [simp]: "\<top> \<leftarrow> x = \<top>"
  by (metis local.res_top local.residuated_multl local.resl_eq)

lemma resl_impl [simp]: "x \<leftarrow> \<bottom> = \<top>"
  by (metis local.resl_comp2 multl_strict resl_top)

lemma resr_top [simp]: "x \<rightarrow> \<top> = \<top>"
  by (metis local.resrI local.top_greatest local.top_unique)

lemma resr_impl [simp]: "\<bottom> \<rightarrow> x = \<top>"
  by (metis local.resr_comp2 multr_strict resr_top)

end (* residuated_blgroupoid *)

class residuated_blsemigroup = bounded_lattice + residuated_sup_lsemigroup
subclass (in residuated_blsemigroup) residuated_blgroupoid ..

class residuated_blmonoid = bounded_lattice + residuated_sup_lmonoid
subclass (in residuated_blmonoid) residuated_blsemigroup ..

class residuated_clgroupoid = complete_lattice + residuated_pogroupoid
begin

lemma resl_eq_def: "y \<leftarrow> x = \<Squnion> {z. z \<cdot> x \<le> y}"
  by (metis local.residual_eq1 local.residuated_multl local.resl_eq)

lemma resr_eq_def: "x \<rightarrow> y = \<Squnion> {z. x \<cdot> z \<le> y}"
  by (metis local.residual_eq1 local.residuated_multr local.resr_eq)

lemma multl_def: "x \<cdot> y = \<Sqinter> {z. x \<le> z \<leftarrow> y}"
proof -
  have "\<Sqinter>{ya. x \<le> residual (\<lambda>a. a \<cdot> y) ya} = \<Sqinter>{z. x \<le> z \<leftarrow> y}"
    by simp
  thus ?thesis
    by (metis residuated_multl residual_eq2)
qed

lemma multr_def: "x \<cdot> y = \<Sqinter> {z. y \<le> x \<rightarrow> z}"
proof -
  have "\<Sqinter>{ya. y \<le> residual ((\<cdot>) x) ya} = \<Sqinter>{z. y \<le> x \<rightarrow> z}"
    by simp
  thus ?thesis
    by (metis residuated_multr residual_eq2)
qed

end (* residuated_clgroupoid *)

class residuated_clsemigroup = complete_lattice + residuated_sup_lsemigroup
subclass (in residuated_clsemigroup) residuated_clgroupoid ..

class residuated_clmonoid = complete_lattice + residuated_sup_lmonoid
subclass (in residuated_clmonoid) residuated_clsemigroup ..

end


theory lemmaTest
  imports Main
begin

datatype boolean = True | False
fun conj :: "boolean \<Rightarrow> boolean \<Rightarrow> boolean" where
  "conj True True = True" |
  "conj _ _ = False"

fun disj :: "boolean \<Rightarrow> boolean \<Rightarrow> boolean" where
  "disj False False = False" |
  "disj _ _ = True"

value "disj True False"

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n" |
  "add (Suc m) n = Suc(add m n)"

lemma add_02: "add m 0 = m"
  apply (induction m)
  apply (auto)
  done

datatype 'a array = Nil | Cons 'a "'a array"

fun append :: "'a array \<Rightarrow> 'a array \<Rightarrow> 'a array" where
  "append Nil ys = ys" |
  "append (Cons x xs) ys = Cons x (append xs ys)"

fun reverse :: "'a array \<Rightarrow> 'a array" where
  "reverse Nil = Nil" |
  "reverse (Cons x xs) = append (reverse xs) (Cons x Nil)"

value "reverse(Cons True (Cons False Nil))"

lemma append_Nil2 [simp]: "append xs Nil = xs"
  apply (induction xs)
  apply (auto)
  done

lemma append_association [simp]: "append (append xs ys) zs = append xs (append ys zs)"
  apply (induction xs)
  apply (auto)
  done

lemma reverse_append [simp]: "reverse(append xs ys) = append (reverse ys) (reverse xs)"
  apply (induction xs)
  apply (auto)
  done

lemma reverse_reverse [simp]: "reverse(reverse xs) = xs"
  apply (induction xs)
  apply (auto)
  done

value "1+(3::nat)"
value "1+(3::int)"
value "1-(3::nat)"
value "1-(3::int)"

end


subsection\<open>Pedersen Commitment Scheme\<close>

text\<open>The Pedersen commitment scheme \cite{BLP:conf/crypto/Pedersen91} is a commitment scheme based on a cyclic group. We use the
construction of cyclic groups from CryptHOL to formalise the commitment scheme. We prove perfect hiding
and computational binding, with a reduction to the discrete log problem. We a proof of the Pedersen commitment scheme
is realised in the instantiation of the Schnorr \<open>\<Sigma>\<close>-protocol with the general construction of commitment schemes
from \<open>\<Sigma>\<close>-protocols. The commitment scheme that is realised there however take the inverse of the message in the commitment
phase due to the construction of the simulator in the \<open>\<Sigma>\<close>-protocol proof. The two schemes are in some way equal however
as we do not have a well defined notion of equality for commitment schemes we keep this section of the formalisation. This
also serves as reference to the formal proof of the Pedersen commitment scheme we provide in \cite{DBLP:conf/post/ButlerAG19}.\<close>

theory Pedersen imports
  Commitment_Schemes
  "HOL-Number_Theory.Cong"
  Cyclic_Group_Ext
  Discrete_Log
  Number_Theory_Aux
  Uniform_Sampling
begin

locale pedersen_base =
  fixes \<G> :: "'grp cyclic_group" (structure)
  assumes prime_order: "prime (order \<G>)"
begin

lemma order_gt_0 [simp]: "order \<G> > 0"
  by (simp add: prime_gt_0_nat prime_order)

type_synonym 'grp' ck = "'grp'"
type_synonym 'grp' vk = "'grp'"
type_synonym plain = "nat"
type_synonym 'grp' commit = "'grp'"
type_synonym "opening" = "nat"

definition key_gen :: "('grp ck \<times> 'grp vk) spmf"
where
  "key_gen = do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    return_spmf (h, h)
  }"

definition commit :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (ck [^] m);
    return_spmf (c,d)
  }"

definition commit_inv :: "'grp ck \<Rightarrow> plain \<Rightarrow> ('grp commit \<times> opening) spmf"
where
  "commit_inv ck m = do {
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = (\<^bold>g [^] d) \<otimes> (inv ck [^] m);
    return_spmf (c,d)
  }"

definition verify :: "'grp vk \<Rightarrow> plain \<Rightarrow> 'grp commit \<Rightarrow> opening \<Rightarrow> bool"
where
  "verify v_key m c d = (c = (\<^bold>g [^] d \<otimes>  v_key [^] m))"

definition valid_msg :: "plain \<Rightarrow> bool"
  where "valid_msg msg \<equiv> (msg < order \<G>)"

definition dis_log_\ :: "('grp ck, plain, 'grp commit, opening) bind_adversary \<Rightarrow> 'grp ck \<Rightarrow> nat spmf"
where "dis_log_\ \ h = do {
  (c, m, d, m', d') \<leftarrow> \ h;
  _ :: unit \<leftarrow> assert_spmf (m \<noteq> m'  \<and> valid_msg m \<and> valid_msg m');
  _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes> h [^] m \<and> c = \<^bold>g [^] d' \<otimes> h [^] m');
  return_spmf  (if (m > m') then (nat ((int d' - int d) * inverse (m - m') (order \<G>) mod order \<G>)) else
                  (nat ((int d - int d') * inverse (m' - m) (order \<G>) mod order \<G>)))}"

sublocale ped_commit: abstract_commitment key_gen commit verify valid_msg .

sublocale discrete_log: dis_log _
  unfolding dis_log_def by(simp)

end

locale pedersen = pedersen_base + cyclic_group \<G>
begin

lemma mod_one_cancel: assumes "[int y * z * x = y' * x] (mod order \<G>)" and "[z * x = 1] (mod order \<G>)"
  shows "[int y = y' * x] (mod order \<G>)"
  by (metis assms Groups.mult_ac(2) cong_scalar_right cong_sym_eq cong_trans more_arith_simps(11) more_arith_simps(5))

lemma dis_log_break:
  fixes d d' m m' :: nat
  assumes c: " \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m' = \<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m"
    and y_less_order: "y < order \<G>"
    and m_ge_m': "m > m'"
    and m: "m < order \<G>"
  shows "y = nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)"
proof -
  have mm': "\<not> [m = m'] (mod order \<G>)"
    using m m_ge_m' basic_trans_rules(19) cong_less_modulus_unique_nat by blast
  hence gcd: "int (gcd ((m - m')) (order \<G>)) = 1"
    using assms(3) assms(4) prime_field prime_order by auto
  have "\<^bold>g [^] (d + y * m) = \<^bold>g [^] (d' + y * m')"
    using c by (simp add: nat_pow_mult nat_pow_pow)
  hence "[d + y * m = d' + y * m'] (mod order \<G>)"
    by(simp add: pow_generator_eq_iff_cong finite_carrier)
  hence "[int d + int y * int m = int d' + int y * int m'] (mod order \<G>)"
    using cong_int_iff by force
  from cong_diff[OF this cong_refl, of "int d + int y * int m'"]
  have "[int y * int (m - m') = int d' - int d] (mod order \<G>)" using m_ge_m'
    by(simp add: int_distrib of_nat_diff)
  hence *: "[int y * int (m - m') * (fst (bezw ((m - m')) (order \<G>))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: cong_scalar_right)
  hence "[int y * (int (m - m') * (fst (bezw ((m - m')) (order \<G>)))) = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    by (simp add: more_arith_simps(11))
  hence "[int y * 1 = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)"
    using inverse gcd
    by (smt Groups.mult_ac(2) Number_Theory_Aux.inverse Totient.of_nat_eq_1_iff * cong_def int_ops(9) mod_mult_right_eq mod_one_cancel)
  hence "[int y = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>)))] (mod order \<G>)" by simp
  hence "y mod order \<G> = (int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>"
    using cong_def zmod_int by auto
  thus ?thesis using y_less_order by simp
qed

lemma dis_log_break':
  assumes "y < order \<G>"
    and "\<not> m' < m"
    and "m \<noteq> m'"
    and m: "m' < order \<G>"
    and "\<^bold>g [^] d \<otimes> (\<^bold>g [^] y) [^] m = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] y) [^] m'"
  shows "y = nat ((int d - int d') * fst (bezw ((m' - m)) (order \<G>)) mod int (order \<G>))"
proof-
  have "m' > m" using assms
    using group_eq_pow_eq_mod nat_neq_iff order_gt_0  by blast
  thus ?thesis
    using dis_log_break[of d y m d' m' ]assms cong_sym_eq assms by blast
qed

lemma set_spmf_samp_uni [simp]: "set_spmf (sample_uniform (order \<G>)) = {x. x < order \<G>}"
  by(auto simp add: sample_uniform_def)

lemma correct:
  shows "spmf (ped_commit.correct_game m) True  = 1"
  using finite_carrier order_gt_0_iff_finite
  apply(simp add: abstract_commitment.correct_game_def Let_def commit_def verify_def)
    by(simp add: key_gen_def Let_def bind_spmf_const cong: bind_spmf_cong_simp)

theorem abstract_correct:
  shows "ped_commit.correct"
  unfolding abstract_commitment.correct_def using correct by simp

lemma perfect_hiding:
  shows "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
  including monad_normalisation
proof -
  obtain \1 \2 where [simp]: "\ = (\1, \2)" by(cases \)
  note [simp] = Let_def split_def
  have "ped_commit.hiding_game_ind_cpa (\1, \2) = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    ((m0, m1), \<sigma>) \<leftarrow> \1 vk;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    (c,d) \<leftarrow> commit ck (if b then m0 else m1);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: abstract_commitment.hiding_game_ind_cpa_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] x;
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
     b \<leftarrow> coin_spmf;
    d :: nat \<leftarrow> sample_uniform (order \<G>);
    let c = ((\<^bold>g [^] d) \<otimes> (h [^] (if b then m0 else m1)));
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b' = b)} ELSE coin_spmf"
      by(simp add: commit_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z \<otimes> (h [^] (if b then m0 else m1))) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
      by(simp add: bind_map_spmf o_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    b \<leftarrow> coin_spmf;
    z \<leftarrow> map_spmf (\<lambda>z. \<^bold>g [^] z) (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    return_spmf(guess = b)} ELSE coin_spmf"
    by(simp add: sample_uniform_one_time_pad)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    let h = (\<^bold>g [^] x);
    ((m0, m1), \<sigma>) \<leftarrow> \1 h;
    _ :: unit \<leftarrow> assert_spmf (valid_msg m0 \<and> valid_msg m1);
    z \<leftarrow> map_spmf (\<lambda>z.  \<^bold>g [^] z)  (sample_uniform (order \<G>));
    guess :: bool \<leftarrow> \2 z \<sigma>;
    map_spmf((=) guess) coin_spmf} ELSE coin_spmf"
      by(simp add: map_spmf_conv_bind_spmf)
  also have "... = coin_spmf"
     by(auto simp add: bind_spmf_const map_eq_const_coin_spmf try_bind_spmf_lossless2' scale_bind_spmf weight_spmf_le_1 scale_scale_spmf)
  ultimately show ?thesis by(simp add: spmf_of_set)
qed

theorem abstract_perfect_hiding:
  shows "ped_commit.perfect_hiding_ind_cpa \"
proof-
  have "spmf (ped_commit.hiding_game_ind_cpa \) True - 1/2 = 0"
    using perfect_hiding by fastforce
  thus ?thesis
    by(simp add: abstract_commitment.perfect_hiding_ind_cpa_def abstract_commitment.hiding_advantage_ind_cpa_def)
qed

lemma bind_output_cong:
  assumes "x < order \<G>"
  shows "(x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>)))
            \<longleftrightarrow> [x = nat ((int b - int ab) * fst (bezw (aa - ac) (order \<G>)) mod int (order \<G>))] (mod order \<G>)"
  using assms cong_less_modulus_unique_nat nat_less_iff by auto

lemma bind_game_eq_dis_log:
  shows "ped_commit.bind_game \ = discrete_log.dis_log (dis_log_\ \)"
proof-
  note [simp] = Let_def split_def
  have "ped_commit.bind_game \ = TRY do {
    (ck,vk) \<leftarrow> key_gen;
    (c, m, d, m', d') \<leftarrow> \ ck;
    _ :: unit \<leftarrow> assert_spmf(m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    let b = verify vk m c d;
    let b' = verify vk m' c d';
    _ :: unit \<leftarrow> assert_spmf (b \<and> b');
    return_spmf True} ELSE return_spmf False"
    by(simp add: abstract_commitment.bind_game_alt_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (Coset.order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf True} ELSE return_spmf False"
    by(simp add: verify_def key_gen_def)
  also have "... = TRY do {
    x :: nat \<leftarrow> sample_uniform (order \<G>);
    (c, m, d, m', d') \<leftarrow> \ (\<^bold>g [^] x);
    _ :: unit \<leftarrow> assert_spmf (m \<noteq> m' \<and> valid_msg m \<and> valid_msg m');
    _ :: unit \<leftarrow> assert_spmf (c = \<^bold>g [^] d \<otimes>  (\<^bold>g [^] x) [^] m \<and> c = \<^bold>g [^] d' \<otimes> (\<^bold>g [^] x) [^] m');
    return_spmf (x = (if (m > m') then (nat ((int d' - int d) * (fst (bezw ((m - m')) (order \<G>))) mod order \<G>)) else
                  (nat ((int d - int d') * (fst (bezw ((m' - m)) (order \<G>))) mod order \<G>))))} ELSE return_spmf False"
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)
     apply(auto simp add: valid_msg_def)
     apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
     apply(simp add: dis_log_break)
    apply(intro bind_spmf_cong[OF refl]; clarsimp?)+
    by(simp add: dis_log_break')
  ultimately show ?thesis
    apply(simp add: discrete_log.dis_log_def dis_log_\_def cong: bind_spmf_cong_simp)
    apply(intro try_spmf_cong bind_spmf_cong[OF refl]; clarsimp?)+
    using bind_output_cong by auto
qed

theorem pedersen_bind: "ped_commit.bind_advantage \ = discrete_log.advantage (dis_log_\ \)"
  unfolding abstract_commitment.bind_advantage_def discrete_log.advantage_def
  using bind_game_eq_dis_log by simp

end

locale pedersen_asymp =
  fixes \<G> :: "nat \<Rightarrow> 'grp cyclic_group"
  assumes pedersen: "\<And>\<eta>. pedersen (\<G> \<eta>)"
begin

sublocale pedersen "\<G> \<eta>" for \<eta> by(simp add: pedersen)

theorem pedersen_correct_asym:
 shows "ped_commit.correct n"
  using abstract_correct by simp

theorem pedersen_perfect_hiding_asym:
  shows "ped_commit.perfect_hiding_ind_cpa n (\ n)"
    by (simp add: abstract_perfect_hiding)

theorem pedersen_bind_asym:
  shows "negligible (\<lambda> n. ped_commit.bind_advantage n (\ n))
            \<longleftrightarrow> negligible (\<lambda> n. discrete_log.advantage n (dis_log_\ n (\ n)))"
  by(simp add: pedersen_bind)

end

end