theory Classes
imports Main Setup
begin

section \<open>Introduction\<close>

text \<open>
  Type classes were introduced by Wadler and Blott @{cite wadler89how}
  into the Haskell language to allow for a reasonable implementation
  of overloading\footnote{throughout this tutorial, we are referring
  to classical Haskell 1.0 type classes, not considering later
  additions in expressiveness}.  As a canonical example, a polymorphic
  equality function \<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> which is overloaded on
  different types for \<open>\<alpha>\<close>, which is achieved by splitting
  introduction of the \<open>eq\<close> function from its overloaded
  definitions by means of \<open>class\<close> and \<open>instance\<close>
  declarations: \footnote{syntax here is a kind of isabellized
  Haskell}

  \begin{quote}

  \<^noindent> \<open>class eq where\<close> \\
  \hspace*{2ex}\<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close>

  \<^medskip>\<^noindent> \<open>instance nat :: eq where\<close> \\
  \hspace*{2ex}\<open>eq 0 0 = True\<close> \\
  \hspace*{2ex}\<open>eq 0 _ = False\<close> \\
  \hspace*{2ex}\<open>eq _ 0 = False\<close> \\
  \hspace*{2ex}\<open>eq (Suc n) (Suc m) = eq n m\<close>

  \<^medskip>\<^noindent> \<open>instance (\<alpha>::eq, \<beta>::eq) pair :: eq where\<close> \\
  \hspace*{2ex}\<open>eq (x1, y1) (x2, y2) = eq x1 x2 \<and> eq y1 y2\<close>

  \<^medskip>\<^noindent> \<open>class ord extends eq where\<close> \\
  \hspace*{2ex}\<open>less_eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> \\
  \hspace*{2ex}\<open>less :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close>

  \end{quote}

  \<^noindent> Type variables are annotated with (finitely many) classes;
  these annotations are assertions that a particular polymorphic type
  provides definitions for overloaded functions.

  Indeed, type classes not only allow for simple overloading but form
  a generic calculus, an instance of order-sorted algebra
  @{cite "nipkow-sorts93" and "Nipkow-Prehofer:1993" and "Wenzel:1997:TPHOL"}.

  From a software engineering point of view, type classes roughly
  correspond to interfaces in object-oriented languages like Java; so,
  it is naturally desirable that type classes do not only provide
  functions (class parameters) but also state specifications
  implementations must obey.  For example, the \<open>class eq\<close>
  above could be given the following specification, demanding that
  \<open>class eq\<close> is an equivalence relation obeying reflexivity,
  symmetry and transitivity:

  \begin{quote}

  \<^noindent> \<open>class eq where\<close> \\
  \hspace*{2ex}\<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> \\
  \<open>satisfying\<close> \\
  \hspace*{2ex}\<open>refl: eq x x\<close> \\
  \hspace*{2ex}\<open>sym: eq x y \<longleftrightarrow> eq x y\<close> \\
  \hspace*{2ex}\<open>trans: eq x y \<and> eq y z \<longrightarrow> eq x z\<close>

  \end{quote}

  \<^noindent> From a theoretical point of view, type classes are
  lightweight modules; Haskell type classes may be emulated by SML
  functors @{cite classes_modules}.  Isabelle/Isar offers a discipline
  of type classes which brings all those aspects together:

  \begin{enumerate}
    \item specifying abstract parameters together with
       corresponding specifications,
    \item instantiating those abstract parameters by a particular
       type
    \item in connection with a ``less ad-hoc'' approach to overloading,
    \item with a direct link to the Isabelle module system:
      locales @{cite "kammueller-locales"}.
  \end{enumerate}

  \<^noindent> Isar type classes also directly support code generation in
  a Haskell like fashion. Internally, they are mapped to more
  primitive Isabelle concepts @{cite "Haftmann-Wenzel:2006:classes"}.

  This tutorial demonstrates common elements of structured
  specifications and abstract reasoning with type classes by the
  algebraic hierarchy of semigroups, monoids and groups.  Our
  background theory is that of Isabelle/HOL @{cite "isa-tutorial"}, for
  which some familiarity is assumed.
\<close>

section \<open>A simple algebra example \label{sec:example}\<close>

subsection \<open>Class definition\<close>

text \<open>
  Depending on an arbitrary type \<open>\<alpha>\<close>, class \<open>semigroup\<close> introduces a binary operator \<open>(\<otimes>)\<close> that is
  assumed to be associative:
\<close>

class %quote semigroup =
  fixes mult :: "\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>"    (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

text \<open>
  \<^noindent> This @{command class} specification consists of two parts:
  the \qn{operational} part names the class parameter (@{element
  "fixes"}), the \qn{logical} part specifies properties on them
  (@{element "assumes"}).  The local @{element "fixes"} and @{element
  "assumes"} are lifted to the theory toplevel, yielding the global
  parameter @{term [source] "mult :: \<alpha>::semigroup \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>"} and the
  global theorem @{fact "semigroup.assoc:"}~@{prop [source] "\<And>x y z ::
  \<alpha>::semigroup. (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"}.
\<close>

subsection \<open>Class instantiation \label{sec:class_inst}\<close>

text \<open>
  The concrete type \<^typ>\<open>int\<close> is made a \<^class>\<open>semigroup\<close> instance
  by providing a suitable definition for the class parameter \<open>(\<otimes>)\<close> and a proof for the specification of @{fact assoc}.  This is
  accomplished by the @{command instantiation} target:
\<close>

instantiation %quote int :: semigroup
begin

definition %quote
  mult_int_def: "i \<otimes> j = i + (j::int)"

instance %quote proof
  fix i j k :: int have "(i + j) + k = i + (j + k)" by simp
  then show "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
    unfolding mult_int_def .
qed

end %quote

text \<open>
  \<^noindent> @{command instantiation} defines class parameters at a
  particular instance using common specification tools (here,
  @{command definition}).  The concluding @{command instance} opens a
  proof that the given parameters actually conform to the class
  specification.  Note that the first proof step is the @{method
  standard} method, which for such instance proofs maps to the @{method
  intro_classes} method.  This reduces an instance judgement to the
  relevant primitive proof goals; typically it is the first method
  applied in an instantiation proof.

  From now on, the type-checker will consider \<^typ>\<open>int\<close> as a \<^class>\<open>semigroup\<close> automatically, i.e.\ any general results are immediately
  available on concrete instances.

  \<^medskip> Another instance of \<^class>\<open>semigroup\<close> yields the natural
  numbers:
\<close>

instantiation %quote nat :: semigroup
begin

primrec %quote mult_nat where
  "(0::nat) \<otimes> n = n"
  | "Suc m \<otimes> n = Suc (m \<otimes> n)"

instance %quote proof
  fix m n q :: nat
  show "m \<otimes> n \<otimes> q = m \<otimes> (n \<otimes> q)"
    by (induct m) auto
qed

end %quote

text \<open>
  \<^noindent> Note the occurrence of the name \<open>mult_nat\<close> in the
  primrec declaration; by default, the local name of a class operation
  \<open>f\<close> to be instantiated on type constructor \<open>\<kappa>\<close> is
  mangled as \<open>f_\<kappa>\<close>.  In case of uncertainty, these names may be
  inspected using the @{command "print_context"} command.
\<close>

subsection \<open>Lifting and parametric types\<close>

text \<open>
  Overloaded definitions given at a class instantiation may include
  recursion over the syntactic structure of types.  As a canonical
  example, we model product semigroups using our simple algebra:
\<close>

instantiation %quote prod :: (semigroup, semigroup) semigroup
begin

definition %quote
  mult_prod_def: "p\<^sub>1 \<otimes> p\<^sub>2 = (fst p\<^sub>1 \<otimes> fst p\<^sub>2, snd p\<^sub>1 \<otimes> snd p\<^sub>2)"

instance %quote proof
  fix p\<^sub>1 p\<^sub>2 p\<^sub>3 :: "\<alpha>::semigroup \<times> \<beta>::semigroup"
  show "p\<^sub>1 \<otimes> p\<^sub>2 \<otimes> p\<^sub>3 = p\<^sub>1 \<otimes> (p\<^sub>2 \<otimes> p\<^sub>3)"
    unfolding mult_prod_def by (simp add: assoc)
qed

end %quote

text \<open>
  \<^noindent> Associativity of product semigroups is established using
  the definition of \<open>(\<otimes>)\<close> on products and the hypothetical
  associativity of the type components; these hypotheses are
  legitimate due to the \<^class>\<open>semigroup\<close> constraints imposed on the
  type components by the @{command instance} proposition.  Indeed,
  this pattern often occurs with parametric types and type classes.
\<close>

subsection \<open>Subclassing\<close>

text \<open>
  We define a subclass \<open>monoidl\<close> (a semigroup with a left-hand
  neutral) by extending \<^class>\<open>semigroup\<close> with one additional
  parameter \<open>neutral\<close> together with its characteristic property:
\<close>

class %quote monoidl = semigroup +
  fixes neutral :: "\<alpha>" ("\<one>")
  assumes neutl: "\<one> \<otimes> x = x"

text \<open>
  \<^noindent> Again, we prove some instances, by providing suitable
  parameter definitions and proofs for the additional specifications.
  Observe that instantiations for types with the same arity may be
  simultaneous:
\<close>

instantiation %quote nat and int :: monoidl
begin

definition %quote
  neutral_nat_def: "\<one> = (0::nat)"

definition %quote
  neutral_int_def: "\<one> = (0::int)"

instance %quote proof
  fix n :: nat
  show "\<one> \<otimes> n = n"
    unfolding neutral_nat_def by simp
next
  fix k :: int
  show "\<one> \<otimes> k = k"
    unfolding neutral_int_def mult_int_def by simp
qed

end %quote

instantiation %quote prod :: (monoidl, monoidl) monoidl
begin

definition %quote
  neutral_prod_def: "\<one> = (\<one>, \<one>)"

instance %quote proof
  fix p :: "\<alpha>::monoidl \<times> \<beta>::monoidl"
  show "\<one> \<otimes> p = p"
    unfolding neutral_prod_def mult_prod_def by (simp add: neutl)
qed

end %quote

text \<open>
  \<^noindent> Fully-fledged monoids are modelled by another subclass,
  which does not add new parameters but tightens the specification:
\<close>

class %quote monoid = monoidl +
  assumes neutr: "x \<otimes> \<one> = x"

instantiation %quote nat and int :: monoid
begin

instance %quote proof
  fix n :: nat
  show "n \<otimes> \<one> = n"
    unfolding neutral_nat_def by (induct n) simp_all
next
  fix k :: int
  show "k \<otimes> \<one> = k"
    unfolding neutral_int_def mult_int_def by simp
qed

end %quote

instantiation %quote prod :: (monoid, monoid) monoid
begin

instance %quote proof
  fix p :: "\<alpha>::monoid \<times> \<beta>::monoid"
  show "p \<otimes> \<one> = p"
    unfolding neutral_prod_def mult_prod_def by (simp add: neutr)
qed

end %quote

text \<open>
  \<^noindent> To finish our small algebra example, we add a \<open>group\<close> class with a corresponding instance:
\<close>

class %quote group = monoidl +
  fixes inverse :: "\<alpha> \<Rightarrow> \<alpha>"    ("(_\<div>)" [1000] 999)
  assumes invl: "x\<div> \<otimes> x = \<one>"

instantiation %quote int :: group
begin

definition %quote
  inverse_int_def: "i\<div> = - (i::int)"

instance %quote proof
  fix i :: int
  have "-i + i = 0" by simp
  then show "i\<div> \<otimes> i = \<one>"
    unfolding mult_int_def neutral_int_def inverse_int_def .
qed

end %quote

section \<open>Type classes as locales\<close>

subsection \<open>A look behind the scenes\<close>

text \<open>
  The example above gives an impression how Isar type classes work in
  practice.  As stated in the introduction, classes also provide a
  link to Isar's locale system.  Indeed, the logical core of a class
  is nothing other than a locale:
\<close>

class %quote idem =
  fixes f :: "\<alpha> \<Rightarrow> \<alpha>"
  assumes idem: "f (f x) = f x"

text \<open>
  \<^noindent> essentially introduces the locale
\<close> (*<*)setup %invisible \<open>Sign.add_path "foo"\<close>
(*>*)
locale %quote idem =
  fixes f :: "\<alpha> \<Rightarrow> \<alpha>"
  assumes idem: "f (f x) = f x"

text \<open>\<^noindent> together with corresponding constant(s):\<close>

consts %quote f :: "\<alpha> \<Rightarrow> \<alpha>"

text \<open>
  \<^noindent> The connection to the type system is done by means of a
  primitive type class \<open>idem\<close>, together with a corresponding
  interpretation:
\<close>

interpretation %quote idem_class:
  idem "f :: (\<alpha>::idem) \<Rightarrow> \<alpha>"
(*<*)sorry(*>*)

text \<open>
  \<^noindent> This gives you the full power of the Isabelle module system;
  conclusions in locale \<open>idem\<close> are implicitly propagated
  to class \<open>idem\<close>.
\<close> (*<*)setup %invisible \<open>Sign.parent_path\<close>
(*>*)
subsection \<open>Abstract reasoning\<close>

text \<open>
  Isabelle locales enable reasoning at a general level, while results
  are implicitly transferred to all instances.  For example, we can
  now establish the \<open>left_cancel\<close> lemma for groups, which
  states that the function \<open>(x \<otimes>)\<close> is injective:
\<close>

lemma %quote (in group) left_cancel: "x \<otimes> y = x \<otimes> z \<longleftrightarrow> y = z"
proof
  assume "x \<otimes> y = x \<otimes> z"
  then have "x\<div> \<otimes> (x \<otimes> y) = x\<div> \<otimes> (x \<otimes> z)" by simp
  then have "(x\<div> \<otimes> x) \<otimes> y = (x\<div> \<otimes> x) \<otimes> z" using assoc by simp
  then show "y = z" using neutl and invl by simp
next
  assume "y = z"
  then show "x \<otimes> y = x \<otimes> z" by simp
qed

text \<open>
  \<^noindent> Here the \qt{@{keyword "in"} \<^class>\<open>group\<close>} target
  specification indicates that the result is recorded within that
  context for later use.  This local theorem is also lifted to the
  global one @{fact "group.left_cancel:"} @{prop [source] "\<And>x y z ::
  \<alpha>::group. x \<otimes> y = x \<otimes> z \<longleftrightarrow> y = z"}.  Since type \<open>int\<close> has been
  made an instance of \<open>group\<close> before, we may refer to that
  fact as well: @{prop [source] "\<And>x y z :: int. x \<otimes> y = x \<otimes> z \<longleftrightarrow> y =
  z"}.
\<close>

subsection \<open>Derived definitions\<close>

text \<open>
  Isabelle locales are targets which support local definitions:
\<close>

primrec %quote (in monoid) pow_nat :: "nat \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" where
  "pow_nat 0 x = \<one>"
  | "pow_nat (Suc n) x = x \<otimes> pow_nat n x"

text \<open>
  \<^noindent> If the locale \<open>group\<close> is also a class, this local
  definition is propagated onto a global definition of @{term [source]
  "pow_nat :: nat \<Rightarrow> \<alpha>::monoid \<Rightarrow> \<alpha>::monoid"} with corresponding theorems

  @{thm pow_nat.simps [no_vars]}.

  \<^noindent> As you can see from this example, for local definitions
  you may use any specification tool which works together with
  locales, such as Krauss's recursive function package
  @{cite krauss2006}.
\<close>

subsection \<open>A functor analogy\<close>

text \<open>
  We introduced Isar classes by analogy to type classes in functional
  programming; if we reconsider this in the context of what has been
  said about type classes and locales, we can drive this analogy
  further by stating that type classes essentially correspond to
  functors that have a canonical interpretation as type classes.
  There is also the possibility of other interpretations.  For
  example, \<open>list\<close>s also form a monoid with \<open>append\<close> and
  \<^term>\<open>[]\<close> as operations, but it seems inappropriate to apply to
  lists the same operations as for genuinely algebraic types.  In such
  a case, we can simply make a particular interpretation of monoids
  for lists:
\<close>

interpretation %quote list_monoid: monoid append "[]"
  proof qed auto

text \<open>
  \<^noindent> This enables us to apply facts on monoids
  to lists, e.g. @{thm list_monoid.neutl [no_vars]}.

  When using this interpretation pattern, it may also
  be appropriate to map derived definitions accordingly:
\<close>

primrec %quote replicate :: "nat \<Rightarrow> \<alpha> list \<Rightarrow> \<alpha> list" where
  "replicate 0 _ = []"
  | "replicate (Suc n) xs = xs @ replicate n xs"

interpretation %quote list_monoid: monoid append "[]" rewrites
  "monoid.pow_nat append [] = replicate"
proof -
  interpret monoid append "[]" ..
  show "monoid.pow_nat append [] = replicate"
  proof
    fix n
    show "monoid.pow_nat append [] n = replicate n"
      by (induct n) auto
  qed
qed intro_locales

text \<open>
  \<^noindent> This pattern is also helpful to reuse abstract
  specifications on the \emph{same} type.  For example, think of a
  class \<open>preorder\<close>; for type \<^typ>\<open>nat\<close>, there are at least two
  possible instances: the natural order or the order induced by the
  divides relation.  But only one of these instances can be used for
  @{command instantiation}; using the locale behind the class \<open>preorder\<close>, it is still possible to utilise the same abstract
  specification again using @{command interpretation}.
\<close>

subsection \<open>Additional subclass relations\<close>

text \<open>
  Any \<open>group\<close> is also a \<open>monoid\<close>; this can be made
  explicit by claiming an additional subclass relation, together with
  a proof of the logical difference:
\<close>

subclass %quote (in group) monoid
proof
  fix x
  from invl have "x\<div> \<otimes> x = \<one>" by simp
  with assoc [symmetric] neutl invl have "x\<div> \<otimes> (x \<otimes> \<one>) = x\<div> \<otimes> x" by simp
  with left_cancel show "x \<otimes> \<one> = x" by simp
qed

text \<open>
  The logical proof is carried out on the locale level.  Afterwards it
  is propagated to the type system, making \<open>group\<close> an instance
  of \<open>monoid\<close> by adding an additional edge to the graph of
  subclass relations (\figref{fig:subclass}).

  \begin{figure}[htbp]
   \begin{center}
     \small
     \unitlength 0.6mm
     \begin{picture}(40,60)(0,0)
       \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
       \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
       \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
       \put(40,00){\makebox(0,0){\<open>group\<close>}}
       \put(20,55){\vector(0,-1){10}}
       \put(15,35){\vector(-1,-1){10}}
       \put(25,35){\vector(1,-3){10}}
     \end{picture}
     \hspace{8em}
     \begin{picture}(40,60)(0,0)
       \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
       \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
       \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
       \put(40,00){\makebox(0,0){\<open>group\<close>}}
       \put(20,55){\vector(0,-1){10}}
       \put(15,35){\vector(-1,-1){10}}
       \put(05,15){\vector(3,-1){30}}
     \end{picture}
     \caption{Subclass relationship of monoids and groups:
        before and after establishing the relationship
        \<open>group \<subseteq> monoid\<close>;  transitive edges are left out.}
     \label{fig:subclass}
   \end{center}
  \end{figure}

  For illustration, a derived definition in \<open>group\<close> using \<open>pow_nat\<close>
\<close>

definition %quote (in group) pow_int :: "int \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" where
  "pow_int k x = (if k >= 0
    then pow_nat (nat k) x
    else (pow_nat (nat (- k)) x)\<div>)"

text \<open>
  \<^noindent> yields the global definition of @{term [source] "pow_int ::
  int \<Rightarrow> \<alpha>::group \<Rightarrow> \<alpha>::group"} with the corresponding theorem @{thm
  pow_int_def [no_vars]}.
\<close>

subsection \<open>A note on syntax\<close>

text \<open>
  As a convenience, class context syntax allows references to local
  class operations and their global counterparts uniformly; type
  inference resolves ambiguities.  For example:
\<close>

context %quote semigroup
begin

term %quote "x \<otimes> y" \<comment> \<open>example 1\<close>
term %quote "(x::nat) \<otimes> y" \<comment> \<open>example 2\<close>

end  %quote

term %quote "x \<otimes> y" \<comment> \<open>example 3\<close>

text \<open>
  \<^noindent> Here in example 1, the term refers to the local class
  operation \<open>mult [\<alpha>]\<close>, whereas in example 2 the type
  constraint enforces the global class operation \<open>mult [nat]\<close>.
  In the global context in example 3, the reference is to the
  polymorphic global class operation \<open>mult [?\<alpha> :: semigroup]\<close>.
\<close>

section \<open>Further issues\<close>

subsection \<open>Type classes and code generation\<close>

text \<open>
  Turning back to the first motivation for type classes, namely
  overloading, it is obvious that overloading stemming from @{command
  class} statements and @{command instantiation} targets naturally
  maps to Haskell type classes.  The code generator framework
  @{cite "isabelle-codegen"} takes this into account.  If the target
  language (e.g.~SML) lacks type classes, then they are implemented by
  an explicit dictionary construction.  As example, let's go back to
  the power function:
\<close>

definition %quote example :: int where
  "example = pow_int 10 (-2)"

text \<open>
  \<^noindent> This maps to Haskell as follows:
\<close>
text %quote \<open>
  @{code_stmts example (Haskell)}
\<close>

text \<open>
  \<^noindent> The code in SML has explicit dictionary passing:
\<close>
text %quote \<open>
  @{code_stmts example (SML)}
\<close>

text \<open>
  \<^noindent> In Scala, implicits are used as dictionaries:
\<close>
text %quote \<open>
  @{code_stmts example (Scala)}
\<close>

subsection \<open>Inspecting the type class universe\<close>

text \<open>
  To facilitate orientation in complex subclass structures, two
  diagnostics commands are provided:

  \begin{description}

    \item[@{command "print_classes"}] print a list of all classes
      together with associated operations etc.

    \item[@{command "class_deps"}] visualizes the subclass relation
      between all classes as a Hasse diagram.  An optional first sort argument
      constrains the set of classes to all subclasses of this sort,
      an optional second sort argument to all superclasses of this sort.

  \end{description}
\<close>

end


(*  Title:       A General Method for the Proof of Theorems on Tail-recursive Functions
    Author:      Pasquale Noce, Security Certification Specialist at Arjowiggins Security
                 (pasquale dot noce at arjowiggins-it dot com)
*)

header "Method rationale"

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

text {*
Tail-recursive function definitions are sometimes more intuitive and
straightforward than alternatives, and this alone would be enough to make them
preferable in such cases for the mere purposes of functional programming. However,
proving theorems about them with a formal proof assistant like Isabelle may be
roundabout because of the peculiar form of the resulting recursion induction
rules.

Let:

\begin{itemize}

\item
@{text f_naive} be a tail-recursive function of type
@{text "'a\<^sub>1 \<Rightarrow> ... \<Rightarrow> 'a\<^sub>n \<Rightarrow> 'b"}.

\item
@{text a} be an @{text n}-tuple of values of types @{text "'a\<^sub>1"}, ...,
@{text "'a\<^sub>n"} such that the computation of @{text "f_naive a"}, say outputting
value @{text b}, involves at least one recursive call -- which is what happens in
general for significant inputs (e.g. those complying with initial conditions for
accumulator arguments), as otherwise a non-recursive function definition would be
sufficient.

\item
@{text "a\<^sub>1"}, ..., @{text "a\<^sub>m"} be the sequence of the intermediate
@{text n}-tuples of values of types @{text "'a\<^sub>1"}, ..., @{text "'a\<^sub>n"} arising from
the computation of @{text "f_naive a"}.

\item
@{text "f_naive X\<^sub>1 = f_naive X'\<^sub>1"}, ..., @{text "f_naive X\<^sub>m = f_naive X'\<^sub>m"},
@{text "f_naive X = Y"} be the sequence (possibly with repetitions) of the
equations involved in the computation of @{text "f_naive a"} -- which implies
that, putting @{text "a\<^sub>0 = a"}, they are satisfied for
@{text "(X\<^sub>1, X'\<^sub>1) = (a\<^sub>0, a\<^sub>1)"}, ..., @{text "(X\<^sub>m, X'\<^sub>m) = (a\<^sub>m\<^sub>-\<^sub>1, a\<^sub>m)"},
@{text "(X, Y) = (a\<^sub>m, b)"}, respectively.

\end{itemize}

That being stated, suppose that theorem @{text "P (f_naive a)"} has to be proven.
If recursion induction is applied to such goal, for each @{text "i \<in> {1..m}"},
the recursive equation @{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"} gives rise to subgoal
@{text "P (f_naive X'\<^sub>i) \<Longrightarrow> P (f_naive X\<^sub>i)"}, trivially discharged by
simplification. On the contrary, the non-recursive equation
@{text "f_naive X = Y"} brings about the generation of subgoal
@{text "P (f_naive X)"}, which is intractable unless it trivially follows from
either the equation or the form of pattern @{text X}.

Indeed, in non-trivial cases such as the case studies examined in this paper, this
formula even fails to be a theorem, thus being hopeless as a goal, since it is
false for some values of its variables. The reason for this is that non-trivial
properties of the output of tail-recursive functions depend on the input as well
as on the whole recursive call pipeline leading from the input to the output, and
all of this information corresponds to missing necessary assumptions in subgoal
@{text "P (f_naive X)"}.

Therefore, for a non-trivial theorem @{text "P (f_naive a)"}, recursion induction
is rather applicable to some true conditional statement
@{text "f_inv x \<longrightarrow> P (f_naive x)"} complying with both of the following
requirements:

\begin{itemize}

\item
subgoal @{text "f_inv X \<longrightarrow> P (f_naive X)"} arising from equation
@{text "f_naive X = Y"} be tractable, and

\item
formula @{text "f_inv a"} can be shown to be true, so that theorem
@{text "P (f_naive a)"} can be inferred from conditional
@{text "f_inv a \<longrightarrow> P (f_naive a)"} by \emph{modus ponens}.

\end{itemize}

Observe that the antecedent of the conditional may not have the form
@{text "f_inv (f_naive x)"}. Otherwise, the latter requirement would ask for
proving formula @{text "f_inv (f_naive a)"}, which would be at least as hard to
prove as formula @{text "P (f_naive a)"} being the former a sufficient condition
for the latter. Hence, the same problem as that originating from the proof of
formula @{text "P (f_naive a)"} would have to be solved again, which would give
rise to a \emph{regressio ad infinitum}.

The latter requirement entails that formula @{text "f_inv a\<^sub>0"} holds. Moreover,
for each @{text "i \<in> {1..m}"}, in the proof of conditional
@{text "f_inv x \<longrightarrow> P (f_naive x)"} by recursion induction, the recursive equation
@{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"} brings about the generation of subgoal
@{text "f_inv X'\<^sub>i \<longrightarrow> P (f_naive X'\<^sub>i) \<Longrightarrow> f_inv X\<^sub>i \<longrightarrow> P (f_naive X\<^sub>i)"}. Assuming
that formula @{text "f_inv a\<^sub>i\<^sub>-\<^sub>1"} holds, it turns out that the conclusion
antecedent @{text "f_inv X\<^sub>i"} may not be shown to be false, as @{text n}-tuple
@{text "a\<^sub>i\<^sub>-\<^sub>1"} matches pattern @{text "X\<^sub>i"}; thus, the conclusion consequent
@{text "P (f_naive X\<^sub>i)"} has to be proven.

In non-trivial cases, this requires that the assumption antecedent
@{text "f_inv X'\<^sub>i"} be derived from the conclusion antecedent @{text "f_inv X\<^sub>i"}
used as a further assumption, so that the assumption consequent
@{text "P (f_naive X'\<^sub>i)"} -- matching @{text "P (f_naive X\<^sub>i)"} by virtue of
equation @{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"} -- can be proven by
\emph{modus ponens}. This in turn requires that @{text "f_inv X\<^sub>i"} imply
@{text "f_inv X'\<^sub>i"}, i.e. that @{text "f_inv x\<^sub>i"} imply @{text "f_inv x'\<^sub>i"} for any
pair of @{text n}-tuples @{text "x\<^sub>i"}, @{text "x'\<^sub>i"} matching patterns @{text "X\<^sub>i"},
@{text "X'\<^sub>i"} with respect to the same value assignment. But such are
@{text n}-tuples @{text "a\<^sub>i\<^sub>-\<^sub>1"}, @{text "a\<^sub>i"} as they solve equation
@{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"}, so that the supposed truth of
@{text "f_inv a\<^sub>i\<^sub>-\<^sub>1"} entails that of @{text "f_inv a\<^sub>i"}.

Hence, by induction, all of formulae @{text "f_inv a"}, @{text "f_inv a\<^sub>1"}, ...,
@{text "f_inv a\<^sub>m"} turn out to be true. On the other hand, the former requirement
is verified if either the antecedent @{text "f_inv X"} can be shown to be false,
which would entail its falsity for any @{text n}-tuple matching pattern @{text X},
or else the consequent @{text "P (f_naive X)"} can be shown to be true using the
antecedent as an assumption. Since formula @{text "f_inv a\<^sub>m"} is true and
@{text n}-tuple @{text "a\<^sub>m"} matches pattern @{text X}, the case that actually
occurs is the second one.

Thus, the former requirement is equivalent to asking for an introduction rule to
be proven -- in fact, a conditional with a contradiction as antecedent may not be
used as an introduction rule -- having the form
@{text "f_inv X \<Longrightarrow> P (f_naive X)"}, or rather
@{text "\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_naive x)"} for a suitable predicate
@{text f_form} satisfied by any @{text n}-tuple matching pattern @{text X}. In
the degenerate case in which the rule can be shown to be true for
@{text "f_form = (\<lambda>x. True)"}, it admits to be put into the simpler equivalent
form @{text "f_inv x \<Longrightarrow> P (f_naive x)"}.

An even more important consequence of the previous argument is that in non-trivial
cases, the task of proving conditional @{text "f_inv x \<longrightarrow> P (f_naive x)"} by
recursion induction requires that @{text "f_inv X'\<^sub>i"} be derived from
@{text "f_inv X\<^sub>i"} for each recursive equation @{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"},
where @{text "i \<in> {1..m}"}.

Let:

\begin{itemize}

\item
@{text 'a} be the Cartesian product of types @{text "'a\<^sub>1"}, ..., @{text "'a\<^sub>n"}.

\item
@{text f_set} be the inductive set of type @{text "'a \<Rightarrow> 'a set"} defined by
introduction rules @{text "x \<in> f_set x"},
@{text "X\<^sub>1 \<in> f_set x \<Longrightarrow> X'\<^sub>1 \<in> f_set x"}, ...,
@{text "X\<^sub>m \<in> f_set x \<Longrightarrow> X'\<^sub>m \<in> f_set x"} -- where patterns @{text "X\<^sub>1"},
@{text "X'\<^sub>1"}, ..., @{text "X\<^sub>m"}, @{text "X'\<^sub>m"} are now viewed as values of type
@{text 'a}.

\end{itemize}

Then, the problem of discharging the above proof obligation on predicate
@{text f_inv} is at least as hard as that of proving by rule induction
introduction rule @{text "\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y"} -- which states that
for any @{text x} such that @{text "f_inv x"} is true, @{text f_inv} is an
invariant over inductive set @{text "f_set x"}, i.e. @{text "f_inv y"} is true for
each @{text "y \<in> f_set x"}.

In fact, the application of rule induction to this goal generates subgoals
@{text "f_inv x \<Longrightarrow> f_inv x"},
@{text "\<lbrakk>X\<^sub>1 \<in> f_set x; f_inv X\<^sub>1; f_inv x\<rbrakk> \<Longrightarrow> f_inv X'\<^sub>1"}, ...,
@{text "\<lbrakk>X\<^sub>m \<in> f_set x; f_inv X\<^sub>m; f_inv x\<rbrakk> \<Longrightarrow> f_inv X'\<^sub>m"}; the first is trivial,
and such would also be the other ones if rules @{text "f_inv X\<^sub>1 \<Longrightarrow> f_inv X'\<^sub>1"},
..., @{text "f_inv X\<^sub>m \<Longrightarrow> f_inv X'\<^sub>m"} were available.

Furthermore, suppose that the above invariance property of predicate @{text f_inv}
have been proven; then, the proof of conditional
@{text "f_inv x \<longrightarrow> P (f_naive x)"} by recursion induction can be made unnecessary
by slightly refining the definition of function @{text f_naive}, as shown in the
continuation.

Let @{text f_aux} be the tail-recursive function of type @{text "'a \<Rightarrow> 'a"} whose
definition is obtained from that of @{text f_naive} by treating as fixed points
the patterns to which non-recursive equations apply as well as those to which no
equation applies, if any -- i.e. by replacing recursive equation
@{text "f_naive X\<^sub>i = f_naive X'\<^sub>i"} with @{text "f_aux X\<^sub>i = f_aux X'\<^sub>i"} for each
@{text "i \<in> {1..m}"} and non-recursive equation @{text "f_naive X = Y"} with
@{text "f_aux X = X"}.

Then, define function @{text f} by means of a non-recursive equation
@{text "f x = f_out (f_aux (f_in x))"}, where:

\begin{itemize}

\item
@{text f_in} is a function of type @{text "'a' \<Rightarrow> 'a"}, for a suitable type
@{text 'a'}, whose range contains all the significant inputs of function
@{text f_naive}.

\item
@{text f_out} is a function of type @{text "'a \<Rightarrow> 'b"} mapping the outputs of
@{text f_aux} to those of @{text f_naive}, i.e. the values of type @{text 'a}
matching pattern @{text X} to those of type @{text 'b} matching pattern
@{text Y} with respect to the same value assignment.

\end{itemize}

The definitions of functions @{text f_aux} and @{text f_out} entail that equation
@{text "f_naive x = f_out (f_aux x)"} holds for any @{text x}. Particularly,
@{text "f_naive a = f_out (f_aux a)"}; thus, being @{text a'} an inverse image of
@{text a} under @{text f_in}, viz. @{text "a = f_in a'"}, it follows that
@{text "f_naive a = f a'"}. As a result, theorem @{text "P (f_naive a)"} may be
rewritten as @{text "P (f a')"}.

For any @{text x}, @{text "f_set x"} is precisely the set of the values
recursively input to function @{text f_aux} in the computation of
@{text "f_aux x"}, including @{text x} itself, and it can easily be ascertained
that @{text "f_aux x"} is such a value. In fact, the equation invoked last in the
computation of @{text "f_aux x"} must be a non-recursive one, so that it has the
form @{text "f_aux X = X"}, since all non-recursive equations in the definition
of @{text f_aux} apply to fixed points. Thus, being @{text "f_aux x"} the output
of the computation, the right-hand side of the equation, i.e. the pattern
@{text X} also input to function @{text f_aux} in the left-hand side, is
instantiated to value @{text "f_aux x"}.

Therefore, @{text "f_aux x \<in> f_set x"} for any @{text x}. Observe that the
argument rests on the assumption that whatever @{text x} is given, a sequence of
equations leading from @{text x} to @{text "f_aux x"} be actually available -- and
what is more, nothing significant could be proven on @{text "f_aux x"} for any
@{text x} for which its value were undefined, and then arbitrary. The trick of
making the definition of @{text f_aux} total by adding equations for the patterns
not covered in the definition of @{text f_naive}, if any, guarantees that this
assumption be satisfied.

An additional consequence of the previous argument is that
@{text "f_aux (f_aux x) = f_aux x"} for any @{text x}, i.e. function @{text f_aux}
is idempotent. If introduction rule @{text "\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_naive x)"}
is rewritten by applying equation @{text "f_naive x = f_out (f_aux x)"},
instantiating free variable @{text x} to @{text "f_aux x"}, and then applying the
idempotence of function @{text f_aux}, the result is formula
@{text "\<lbrakk>f_inv (f_aux x); f_form (f_aux x)\<rbrakk> \<Longrightarrow> P (f_out (f_aux x))"}, which is
nothing but an instantiation of introduction rule
@{text "\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)"}.

Observe that this rule is just a refinement of a rule whose proof is required for
proving conditional @{text "f_inv x \<longrightarrow> P (f_naive x)"} by recursion induction, so
that it does not give rise to any additional proof obligation. Moreover, it
contains neither function @{text f_naive} nor @{text f_aux}, thus its proof does
not require recursion induction with respect to the corresponding induction rules.

The instantiation of such refined introduction rule with value @{text "f_aux a"}
is @{text "\<lbrakk>f_inv (f_aux a); f_form (f_aux a)\<rbrakk> \<Longrightarrow> P (f_out (f_aux a))"}, which by
virtue of equality @{text "a = f_in a'"} and the definition of function @{text f}
is equivalent to formula
@{text "\<lbrakk>f_inv (f_aux a); f_form (f_aux a)\<rbrakk> \<Longrightarrow> P (f a')"}. Therefore, the rule is
sufficient to prove theorem @{text "P (f a')"} -- hence making unnecessary the
proof of conditional @{text "f_inv x \<longrightarrow> P (f_naive x)"} by recursion induction,
as mentioned previously -- provided the instantiated assumptions
@{text "f_inv (f_aux a)"}, @{text "f_form (f_aux a)"} can be shown to be true.

This actually is the case: the former assumption can be derived from formulae
@{text "f_aux a \<in> f_set a"}, @{text "f_inv a"} and the invariance of predicate
@{text f_inv} over @{text "f_set a"}, while the latter can be proven by recursion
induction, as by construction goal @{text "f_form X"} is trivial for any pattern
@{text X} to which some non-recursive equation in the definition of function
@{text f_naive} applies. If further non-recursive equations whose patterns do not
satisfy predicate @{text f_form} have been added to the definition of
@{text f_aux} to render it total, rule inversion can be applied to exclude that
@{text "f_aux a"} may match any of such patterns, again using formula
@{text "f_aux a \<in> f_set a"}.
*}

section "Method summary"

text {*
The general method developed so far can be schematized as follows.

Let @{text f_naive} be a tail-recursive function of type
@{text "'a\<^sub>1 \<Rightarrow> ... \<Rightarrow> 'a\<^sub>n \<Rightarrow> 'b"}, and @{text "P (f_naive a\<^sub>1 ... a\<^sub>n)"} be a
non-trivial theorem having to be proven on this function.

In order to accomplish such task, the following procedure shall be observed.

\begin{itemize}

\item
\emph{Step 1} --- Refine the definition of @{text f_naive} into that of an
auxiliary tail-recursive function @{text f_aux} of type @{text "'a \<Rightarrow> 'a"}, where
@{text 'a} is a product or record type with types @{text "'a\<^sub>1"}, ..., @{text "'a\<^sub>n"}
as components, by treating as fixed points the patterns to which non-recursive
equations apply as well as those to which no equation applies, if any.

\item
\emph{Step 2} --- Define a function @{text f} of type @{text "'a' \<Rightarrow> 'b"} by means
of a non-recursive equation @{text "f x = f_out (f_aux (f_in x))"}, where
@{text f_in} is a function of type @{text "'a' \<Rightarrow> 'a"} (possibly matching the
identity function) whose range contains all the significant inputs of function
@{text f_naive}, and @{text f_out} is a function of type @{text "'a \<Rightarrow> 'b"}
mapping the outputs of @{text f_aux} to those of @{text f_naive}.
\\Then, denoting with @{text a} the value of type @{text 'a} with components
@{text "a\<^sub>1"}, ..., @{text "a\<^sub>n"}, and with @{text a'} an inverse image of @{text a}
under function @{text f_in}, the theorem to be proven takes the equivalent form
@{text "P (f a')"}.

\item
\emph{Step 3} --- Let @{text "f_aux X\<^sub>1 = f_aux X'\<^sub>1"}, ...,
@{text "f_aux X\<^sub>m = f_aux X'\<^sub>m"} be the recursive equations in the definition of
function @{text f_aux}.
\\Then, define an inductive set @{text f_set} of type @{text "'a \<Rightarrow> 'a set"} with
introduction rules @{text "x \<in> f_set x"},
@{text "X\<^sub>1 \<in> f_set x \<Longrightarrow> X'\<^sub>1 \<in> f_set x"}, ...,
@{text "X\<^sub>m \<in> f_set x \<Longrightarrow> X'\<^sub>m \<in> f_set x"}.
\\If the right-hand side of some recursive equation contains conditionals in the
form of @{text "if"} or @{text case} constructs, the corresponding introduction
rule can be split into as many rules as the possible mutually exclusive cases;
each of such rules shall then provide for the related case as an additional
assumption.

\item
\emph{Step 4} --- Prove lemma @{text "f_aux x \<in> f_set x"}; a general inference
scheme, independent of the specific function @{text f_aux}, applies to this proof.
\\First, prove lemma @{text "y \<in> f_set x \<Longrightarrow> f_set y \<subseteq> f_set x"}, which can easily
be done by rule induction.
\\Next, applying recursion induction to goal @{text "f_aux x \<in> f_set x"} and then
simplifying, a subgoal @{text "X\<^sub>i \<in> f_set X\<^sub>i"} arises for each non-recursive
equation @{text "f_aux X\<^sub>i = X\<^sub>i"}, while a subgoal
@{text "f_aux X'\<^sub>j \<in> f_set X'\<^sub>j \<Longrightarrow> f_aux X'\<^sub>j \<in> f_set X\<^sub>j"} arises for each recursive
equation @{text "f_aux X\<^sub>j = f_aux X'\<^sub>j"}.
\\The former subgoals can be proven by introduction rule @{text "x \<in> f_set x"}, the
latter ones as follows: rule instantiations @{text "X\<^sub>j \<in> f_set X\<^sub>j"} and
@{text "X\<^sub>j \<in> f_set X\<^sub>j \<Longrightarrow> X'\<^sub>j \<in> f_set X\<^sub>j"} imply formula @{text "X'\<^sub>j \<in> f_set X\<^sub>j"};
thus @{text "f_set X'\<^sub>j \<subseteq> f_set X\<^sub>j"} by the aforesaid lemma; from this and subgoal
assumption @{text "f_aux X'\<^sub>j \<in> f_set X'\<^sub>j"}, subgoal conclusion
@{text "f_aux X'\<^sub>j \<in> f_set X\<^sub>j"} ensues.
\\As regards recursive equations containing conditionals, the above steps have to
be preceded by a case distinction, so as to obtain further assumptions sufficient
for splitting such conditionals.

\item
\emph{Step 5} --- Define a predicate @{text f_inv} of type @{text "'a \<Rightarrow> bool"} in
such a way as to meet the proof obligations prescribed by the following steps.

\item
\emph{Step 6} --- Prove lemma @{text "f_inv a"}.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate @{text f_inv}.

\item
\emph{Step 7} --- Prove introduction rule @{text "f_inv x \<Longrightarrow> P (f_out x)"}, or
rather @{text "\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)"}, where @{text f_form} is a
suitable predicate of type @{text "'a \<Rightarrow> bool"} satisfied by any pattern to which
some non-recursive equation in the definition of function @{text f_naive} applies.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate @{text f_inv}.

\item
\emph{Step 8} --- In case an introduction rule of the second form has been proven
in step 7, prove lemma @{text "f_form (f_aux a)"} by recursion induction.
\\If the definition of function @{text f_aux} resulting from step 1 contains
additional non-recursive equations whose patterns do not satisfy predicate
@{text f_form}, rule inversion can be applied to exclude that @{text "f_aux a"}
may match any of such patterns, using instantiation @{text "f_aux a \<in> f_set a"} of
the lemma proven in step 4.

\item
\emph{Step 9} --- Prove by rule induction introduction rule
@{text "\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y"}, which states the invariance of
predicate @{text f_inv} over inductive set @{text "f_set x"} for any @{text x}
satisfying @{text f_inv}.
\\In case of failure, return to step 5 so as to suitably change the definition of
predicate @{text f_inv}.
\\Observe that the order in which the proof obligations related to predicate
@{text f_inv} are distributed among steps 6 to 9 is ascending in the effort
typically required to discharge them. The reason why this strategy is advisable is
that in case one step fails, which forces to revise the definition of predicate
@{text f_inv} and then also the proofs already worked out, such proofs will be the
least demanding ones so as to minimize the effort required for their revision.

\item
\emph{Step 10} --- Prove theorem @{text "P (f a')"} by means of the following
inference scheme.
\\First, derive formula @{text "f_inv (f_aux a)"} from introduction rule
@{text "\<lbrakk>y \<in> f_set x; f_inv x\<rbrakk> \<Longrightarrow> f_inv y"} and formulae
@{text "f_aux a \<in> f_set a"}, @{text "f_inv a"}.
\\Then, derive formula @{text "P (f_out (f_aux a))"} from either introduction rule
@{text "f_inv x \<Longrightarrow> P (f_out x)"} or @{text "\<lbrakk>f_inv x; f_form x\<rbrakk> \<Longrightarrow> P (f_out x)"}
and formulae @{text "f_inv (f_aux a)"}, @{text "f_form (f_aux a)"} (in the latter
case).
\\Finally, derive theorem @{text "P (f a')"} from formulae
@{text "P (f_out (f_aux a))"}, @{text "a = f_in a'"} and the definition of
function @{text f}.

\end{itemize}

In the continuation, the application of this method is illustrated by analyzing
two case studies drawn from an exercise comprised in Isabelle online course
material; see \cite{R5}. The salient points of definitions and proofs are
commented; for additional information see Isabelle documentation, particularly
\cite{R1}, \cite{R2}, \cite{R3}, and \cite{R4}.
*}

(*<*)
end
(*>*)


section \<open>Operation semantics of HCSP.\<close>

theory Op_SL
  imports Syntax_SL
begin

type_synonym now = real
type_synonym 'a history = "time \<Rightarrow> 'a pair_state"

subsection \<open>Five kinds of events for HCSP processes\<close>
datatype event =
  Tau
| In cname real
| Out cname real
| IO cname real
| Delay time

subsection \<open>Auxiliary functions needed to be introduced first.\<close>

text \<open>Two events are compatible if they are In-Out pairs.\<close>
primrec compat :: "event \<Rightarrow> event \<Rightarrow> bool" where
  "compat Tau ev = False"
| "compat (In ch val) ev = (if ev = Out ch val then True else False)"
| "compat (Out ch val) ev = (if ev = In ch val then True else False)"
| "compat (IO ch val) ev = False"
| "compat (Delay d) ev = False"

text \<open>handshake between an In-Out pair is an IO event.\<close>
primrec handshake :: "event \<Rightarrow> event \<Rightarrow> event" where
  "handshake Tau ev = Tau"
| "handshake (In ch val) ev = (if ev = Out ch val then IO ch val else Tau)"
| "handshake (Out ch val) ev = (if ev = In ch val then IO ch val else Tau)"
| "handshake (IO ch val) ev = Tau"
| "handshake (Delay d) ev = Tau"

text \<open>Set of channels of a procedure\<close>
primrec chansetC :: "'a comm => string set" where
  "chansetC (ch[!]e) = {ch}"
| "chansetC (ch[?]e) = {ch}"

primrec chanset :: "'a proc \<Rightarrow> string set" where
  "chanset (Cm r) = chansetC r"
| "chanset Skip = {}"
| "chanset (e := f) = {}"
| "chanset (P; Q) = chanset P \<union> chanset Q"
| "chanset (IF b P) = chanset P"
| "chanset (P \<sqinter> Q) = chanset P \<union> chanset Q"
| "chanset (c \<rightarrow> P [] d \<rightarrow> Q) = chansetC c  \<union> chansetC d  \<union> chanset P \<union> chanset Q"
| "chanset (P *&& Inv) = chanset P"
| "chanset (P * NUM n) = chanset P"
| "chanset (<ODEs && Inv & b>) = {}"
| "chanset (P [] c \<rightarrow> Q) = chanset P \<union> chanset Q \<union> chansetC c"

subsection \<open>Definitions for ODEs\<close>

text \<open>The semantics of an ODE is the value of the vector field.\<close>
fun ODE_sem :: "'a::finite ODE \<Rightarrow> 'a state \<Rightarrow> 'a state" where
  "ODE_sem (odeone x e) = (\<lambda> s. (\<chi> i. if i = x then evalE_df e s else 0))"
| "ODE_sem (odes ode1, ode2) = (\<lambda> s. ODE_sem ode1 s + ODE_sem ode2 s)"

definition ODE_pair_state :: "'a::finite ODE \<Rightarrow> 'a state \<Rightarrow> 'a pair_state" where
  "ODE_pair_state ode u = (u, ODE_sem ode u)"

text \<open>From a pair-state \<nu> and a state u, obtain a new state \<omega> by replacing
the part of \<nu> specified by the differential equation with the differential
equation evaluated on u.\<close>
definition execute_ODE :: "'a::finite ODE \<Rightarrow> 'a pair_state \<Rightarrow> 'a state \<Rightarrow> 'a pair_state" where
  "execute_ODE ode \<nu> u =
    (THE \<omega>. Vagree \<omega> \<nu> (- ODE_vars ode) \<and> Vagree \<omega> (ODE_pair_state ode u) (ODE_vars ode))"

text \<open>Construct a concrete solution for the ODE.\<close>
definition concrete_sol :: "'a::finite ODE \<Rightarrow> 'a pair_state \<Rightarrow> 'a state \<Rightarrow> 'a pair_state" where
  "concrete_sol ode \<nu> u =
     (\<chi> i. (if i \<in> ODE_vars ode then u else fst \<nu>) $ i,
      \<chi> i. (if i \<in> ODE_vars ode then ODE_sem ode u else snd \<nu>) $ i)"

lemma execute_ODE_exists:
  "\<exists> \<omega>. Vagree  \<omega> \<nu> (- ODE_vars ode) \<and> (Vagree \<omega> (ODE_pair_state ode u) (ODE_vars ode))"
  by(rule exI[where x="(concrete_sol ode \<nu> u)"],
     auto simp add: concrete_sol_def ODE_pair_state_def Vagree_def)

lemma execute_ODE_agree:
  "Vagree (execute_ODE ode \<nu> u) \<nu> (- ODE_vars ode) \<and>
   Vagree (execute_ODE ode \<nu> u) (ODE_pair_state ode u) (ODE_vars ode)"
  unfolding execute_ODE_def Let_def
  apply (rule theI[where a = "concrete_sol ode \<nu> u"], auto)
  apply (simp add:concrete_sol_def ODE_pair_state_def Vagree_def Let_def)+
  using exE[OF execute_ODE_exists, of \<nu> ode u]
  by (auto simp add: concrete_sol_def ODE_pair_state_def Vagree_def vec_eq_iff)

lemma execute_ODE_concrete:
  "execute_ODE ode \<nu> u = concrete_sol ode \<nu> u"
  apply (simp add:concrete_sol_def)
  apply (rule Vagree_eq)
  using execute_ODE_agree[of ode \<nu> u]
  unfolding Vagree_def ODE_pair_state_def by auto

text \<open>The solution of ode at time interval {0..t} with respect to initial state \<nu>\<close>
definition ODE_solution :: "'a::finite ODE \<Rightarrow> real \<Rightarrow> 'a pair_state \<Rightarrow> (real \<Rightarrow> 'a state) \<Rightarrow> bool" where
  "ODE_solution ode t \<nu> v \<longleftrightarrow>
    (v has_vderiv_on (\<lambda>t. ODE_sem ode (v t))) {0..t} \<and> v 0 = fst \<nu>"

definition ODE_solution_in_dom :: "'a::finite ODE \<Rightarrow> real \<Rightarrow> 'a pair_state \<Rightarrow> 'a fform \<Rightarrow> (real \<Rightarrow> 'a state) \<Rightarrow> bool" where
  "ODE_solution_in_dom ode t \<nu> b v \<longleftrightarrow>
    (v solves_ode (\<lambda>_. ODE_sem ode)) {0..t} {x. b (execute_ODE ode \<nu> x)} \<and> v 0 = fst \<nu>"

text \<open>\<nu> is the initial state, b is the domain, and i is the invariant\<close>
definition ODE_inv_in_dom :: "'a :: finite ODE \<Rightarrow>'a pair_state \<Rightarrow> 'a fform \<Rightarrow> 'a fform \<Rightarrow> bool" where
  "ODE_inv_in_dom ode \<nu> b i \<longleftrightarrow> (\<forall> d \<ge> 0. \<forall> sol.
    ODE_solution ode d \<nu> sol \<longrightarrow>
    (\<forall> t. t \<ge> 0 \<and> t < d \<longrightarrow> b (execute_ODE ode \<nu> (sol t))) \<longrightarrow>
    (\<forall> t. t \<ge> 0 \<and> t \<le> d \<longrightarrow> i (execute_ODE ode \<nu> (sol t))))"

(*
text \<open>With a change of differential variables in the second state\<close>
definition the_first_state :: "'a :: finite ODE \<Rightarrow>'a pair_state \<Rightarrow> 'a pair_state"
  where "the_first_state ode \<nu> = execute_ODE ode \<nu> (ODE_solution ode 0 \<nu> 0)"
*)

fun update_fst :: "'a::finite pair_state \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a pair_state" where
  "update_fst u a r = ((\<chi> i. if i = a then r else fst u $ i), snd u)"

fun update_snd :: "'a::finite pair_state \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a pair_state" where
  "update_snd u a r = (fst u, (\<chi> i. if i = a then r else snd u $ i))"

text \<open>Update the value of f between a and a+d to f a.\<close>
fun extend_history :: "'a::finite history \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a history" where
  "extend_history f a d = (\<lambda> t. if t > a \<and> t \<le> a + d then f a else f t)"

subsection \<open>Small step semantics for HCSP\<close>

text \<open>semP P t h (e, P2, t2, h2) means a single step starting at program P changes
the program to P2, changes time t to t2, and history h to h2, while outputting event e.\<close>
inductive semP :: "'a::finite proc \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> (event \<times> 'a proc \<times> now \<times> 'a history) \<Rightarrow> bool" where
  skip: "semP Skip now f (Tau, Skip, now, f)"
| assign: "semP (x := e) now f
    (Tau, Skip, now, (\<lambda>t. if t = now then update_fst (f t) x (evalE e (f t)) else f t))"
| Dassign: "semP (DAss x e) now f
    (Tau, Skip, now, (\<lambda>t. if t = now then update_snd (f t) x (evalE e (f t)) else f t))"
\<comment> \<open>Finish execution of an ODE\<close>
| continuousF: "([\<not>]b) (execute_ODE ode (f now) (fst (f now))) \<Longrightarrow>
    semP (<ode && Inv&b>) now f (Tau, Skip, now, (\<lambda>t. if t = now then execute_ODE ode (f now) (fst (f now)) else f t))"
\<comment> \<open>Partial execution of an ODE\<close>
| continuousT: "d > 0 \<Longrightarrow> ODE_solution_in_dom ode d (f now) b sol \<Longrightarrow>
    semP (<ode && Inv&b>) now f (Delay d, <ode && Inv&b>, now+d,
       (\<lambda>t. if t \<le> now+d \<and> t > now then
              execute_ODE ode (f now) (sol (t-now))
            else f t))"
| sequenceL: "semP P now f (ev, P', now', f') \<and> P' \<noteq> Skip \<Longrightarrow>
              semP (P; Q) now f (ev, P'; Q, now', f')"
| sequenceR: "semP P now f (ev, P', now', f') \<and> P' = Skip \<Longrightarrow>
              semP (P; Q) now f (ev, Q, now', f')"
| conditionT: " b (f now) \<Longrightarrow> semP (IF b P) now f (Tau, P, now, f)"
| conditionF: "\<not>b (f now) \<Longrightarrow> semP (IF b P) now f (Tau, Skip, now, f)"
| IChoiceL: "semP (P \<sqinter> Q) now f (Tau, P, now, f)"
| IChoiceR: "semP (P \<sqinter> Q) now f (Tau, Q, now, f)"
| EChoiceL: "semP (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f (Out ch (evalE e (f now)), P, now, f)"
| EChoiceR: "semP (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f (In dh c, (x := (Real c); P), now, f)"
| EChoiceW: "d\<ge>0 \<Longrightarrow> semP (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f
              (Delay d, (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q), now + d, extend_history f now d)"
| repetition0: "semP (P *&& Inv) now f (Tau, Skip, now, f)"
| repetitionk: "semP P now f (ev, P', now', f') \<and> P' \<noteq> Skip \<Longrightarrow>
                semP (P *&& Inv) now f (ev, (P'; P *&& Inv), now', f')"
| repetitionk1: "semP P now f (ev, P', now', f') \<and> P' = Skip \<Longrightarrow>
                 semP (P *&& Inv) now f (ev, P *&& Inv, now',f')"
| outputC : "semP (Cm (ch[!]e)) now f (Out ch (evalE e (f now)), Skip, now, f)"
| outputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch[!]e)) now f
            (Delay d, Cm (ch[!]e), now + d, extend_history f now d)"
| inputC : "semP (Cm (ch[?]x)) now f (In ch c, x := (Real c), now, f)"
| inputW : "d\<ge>0 \<Longrightarrow> semP (Cm (ch[?]x)) now f
            (Delay d, Cm (ch[?]x), now + d, extend_history f now d)"

inductive semPP :: "'a::finite procP \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> 'a history \<Rightarrow>
                    (event \<times> 'a procP \<times> now \<times> 'a history \<times> 'a history) \<Rightarrow> bool" where
\<comment> \<open>Swap\<close>
  parallel0: "semPP (P||Q) now f g (eve, P'||Q', now', f', g') \<Longrightarrow> semPP (Q||P) now g f (eve, Q'||P', now', g', f')"
\<comment> \<open>Handshake on the two sides\<close>
| parallel1: "semP P now f (evp, P', now, f') \<and> semP Q now g (evq, Q', now, g') \<and> compat evp evq \<Longrightarrow>
              semPP (P||Q) now f g (handshake evp evq, P'||Q', now, f', g')"
\<comment> \<open>Execution on P only\<close>
| parallel2 : "semP P now f (evp, P', now', f')
             \<and> ((evp = Tau) \<or>
                (\<exists>ch c. evp = Out ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q)) \<or>
                (\<exists>ch c. evp = In ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q)) \<or>
                (\<exists>ch c. evp = IO ch c \<and> \<not>(ch \<in> chanset P \<inter> chanset Q))) \<Longrightarrow>
             semPP (P||Q) now f g (evp, P'||Q, now', f', g)"
\<comment> \<open>Delay on both sides\<close>
| parallel3 : "semP P now f (Delay d, P', now + d, f')
              \<and> semP Q now g (Delay d, Q', now + d, g') \<Longrightarrow>
             semPP (P||Q) now f g (Delay d, P'||Q', now + d, (\<lambda>t. if t \<le> now + d \<and> t \<ge> now then f' t else f t),
                (\<lambda>t. if t \<le> now + d \<and> t \<ge> now then g' t else g t))"

subsection \<open>Big-step semantics\<close>

text \<open>Continuous evolution domain: assume b is an open formula, otherwise
the escaping point cannot be found.\<close>

inductive semB :: "'a :: finite proc \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> bool" where
  skipB: "semB Skip now f now f"
| assignB: "semB (x := e) now f
    now (\<lambda>t. if t = now then update_fst (f t) x (evalE e (f t)) else f t)"
| DassignB: "semB (DAss x e) now f
    now (\<lambda>t. if t = now then update_snd (f t) x (evalE e (f t)) else f t)"
(*| continuousBF: "let sol = ODE_solution ode 0 (f now) in
      ([\<not>]b) (execute_ODE ode (f now) (sol 0)) \<Longrightarrow> semB (<ode && Inv&b>) now f
    now (\<lambda>t. if t = now then (execute_ODE ode (f now) ((ODE_solution ode 0 (f now)) 0))  else f t)"
*)
| continuous: "d \<ge> 0 \<Longrightarrow> ODE_solution ode d (f now) sol \<Longrightarrow>
    (\<forall> t. t \<ge> 0 \<and> t < d \<longrightarrow> b (execute_ODE ode (f now) (sol t))) \<Longrightarrow> \<not> b (execute_ODE ode (f now) (sol d)) \<Longrightarrow>
    semB (<ode && Inv&b>) now f
      (now + d) (\<lambda>t. if t \<le> now + d \<and> t \<ge> now then
                       execute_ODE ode (f now) (sol (t-now))
                     else f t)"
| sequenceB: "semB P now f now' f' \<and> semB Q now' f' now'' f'' \<Longrightarrow> semB (P; Q) now f now'' f''"
| conditionBT: " b (f now) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (IF b P) now f now_d f_d"
| conditionBF: "\<not>b (f now) \<Longrightarrow> semB (IF b P) now f now f"
| IChoiceBL: "semB P now f now' f' \<Longrightarrow> semB (P \<sqinter> Q) now f now' f'"
| IChoiceBR: "semB Q now f now' f' \<Longrightarrow> semB (P \<sqinter> Q) now f now' f'"
| EChoiceL: "d \<ge> 0 \<Longrightarrow> semB P (now + d) (extend_history f now d) now' f' \<Longrightarrow>
             semB (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f now' f'"
| EChoiceR: "d \<ge> 0 \<Longrightarrow> semB (x := (Real c); Q) (now + d) (extend_history f now d) now' f' \<Longrightarrow>
             semB (ch [!] e \<rightarrow> P [] dh [?] x \<rightarrow> Q) now f now' f'"
| repetitionN0B: "N = (0::nat) \<Longrightarrow> semB (P * NUM N) now f now f"
| repetitionNkB: "N > (0::nat) \<Longrightarrow> semB P now f now_d f_d \<Longrightarrow> semB (P * NUM (N-1)) now_d f_d now_dd f_dd \<Longrightarrow>
                  semB (P * NUM N) now f now_dd f_dd"
| repetitionB: "\<exists>N. semB (P * NUM N) now f now_dd f_dd \<Longrightarrow> semB (P*&&Inv) now f now_dd f_dd"
| outputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch[!]e)) now f (now+d) (extend_history f now d)"
| inputBC: "d\<ge>0 \<Longrightarrow> semB (Cm (ch[?]x)) now f (now + d)
            (\<lambda>t. if t < now + d \<and> t > now then f now
                 else if t = now + d then update_fst (f now) x c
                 else f t)"
(*Notice: no real meaning of c in the inputBC. It will not be used actually without a synchronized output.*)

text \<open>There are four cases for semantics of parallel composition.\<close>
inductive semBP :: "'a::finite procP \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> now \<Rightarrow> 'a history \<Rightarrow> bool" where
  parallelB1: "semB P nowp fp nowp' fp' \<Longrightarrow> semB Q nowq fq nowq' fq' \<Longrightarrow> chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
               semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"
| parallelB2: "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semB U nowp' fp' nowu' fu' \<Longrightarrow> semB V nowq' fq' nowv' fv' \<Longrightarrow> chanset P \<noteq> {} \<and> chanset Q \<noteq> {} \<Longrightarrow>
               chanset U = {} \<and> chanset V = {} \<Longrightarrow>
               semBP ((P; U) || (Q; V)) nowp fp nowq fq  nowu' fu' nowv' fv'"
| parallelB3: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semBP (P; Cm (ch[?]x) || Q; Cm (ch[!]e)) nowp fp nowq fq
               (max nowp' nowq')
               (\<lambda>t. if nowp' < t \<and> t < max nowp' nowq' then fp' nowp'
                    else if t = max nowp' nowq' then update_fst (fp' nowp') x (evalE e (fp' nowp'))
                    else fp' t)
               (max nowp' nowq')
               (\<lambda>t. if nowq' < t \<and> t \<le> max nowp' nowq' then fq' nowq' else fq' t)"
| parallelB4: "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
               semBP (P; Cm (ch[!]e) || Q; Cm (ch[?]x)) nowp fp nowq fq
               (max nowp' nowq')
               (\<lambda>t. if nowp' < t \<and> t \<le> max nowp' nowq' then fp' nowp' else fp' t)
               (max nowp' nowq')
               (\<lambda>t. if nowq' < t \<and> t < max nowp' nowq' then fq' nowq'
                    else if t = max nowp' nowq' then update_fst (fq' nowq') x (evalE e (fq' nowq'))
                    else fq' t)"

inductive_cases [elim!]:
  "semB Skip now f now' f'"
  "semB (DAss x e) now f now' f'"
  "semB (x := e) now f now' f'"
  "semB (P; Q) now f now' f'"
  "semB (IF b P) now f  now' f'"
  "semB (P \<sqinter> Q) now f now' f'"
  "semB (<ode && Inv&b>) now f now' f'"
  "semB (P*&&Inv) now f now' f'"
  "semB (P* NUM N) now f now' f'"

inductive_cases [elim!]:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq'"

subsection \<open>Properties related to semantics\<close>

lemma sem1:
  "semB P now f now' f' \<Longrightarrow> now \<le> now'"
  by (induct rule: semB.induct, auto)

lemma semDass:
  "semB (DAss x e) now f now' f' \<Longrightarrow> now' = now \<and> f' = (\<lambda>t. if t = now then update_snd (f t) x (evalE e (f t)) else f t)"
  using semB.DassignB[of x e now f] by auto

lemma semB1:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow> nowp \<le> nowp' \<and> nowq \<le> nowq'"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case
    using sem1 by blast
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case by (metis order_trans sem1)
qed (metis le_max_iff_disj)+

lemma sem2:
  "semB P now f now' f' \<Longrightarrow> \<forall>t. t < now \<or> t > now' \<longrightarrow> f t = f' t"
proof (induct rule: semB.induct)
   case (sequenceB P now f now' f' Q now'' f'')
  then show ?case by (metis (full_types) le_less_trans not_le sem1)
next
   case (EChoiceL d P now f now' f' ch e dh x Q)
  then show ?case
    by (smt extend_history.simps sem1)
next
  case (EChoiceR d x c Q now f now' f' ch e P dh)
  then show ?case by (smt extend_history.simps sem1)
next
  case (repetitionNkB N P now f now_d f_d now_dd f_dd)
  then show ?case  by (metis (full_types) le_less_trans less_eq_real_def sem1)
qed auto

lemma semB2:
  "semBP (P||Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
    (\<forall>t. t < nowp \<or> t > nowp' \<longrightarrow> (fp t = fp' t)) \<and>
    (\<forall>t. t < nowq \<or> t > nowq' \<longrightarrow> (fq t = fq' t))"
proof (induct rule: semBP.induct)
  case (parallelB1 P nowp fp nowp' fp' Q nowq fq nowq' fq')
  then show ?case
    using sem2 by blast
next
  case (parallelB2 P Q nowp fp nowq fq nowp' fp' nowq' fq' U nowu' fu' V nowv' fv')
  then show ?case  by (smt sem1 sem2 semB1)
next
  case (parallelB3 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch x e)
  then show ?case by (smt semB1)
next
  case (parallelB4 P Q nowp fp nowq fq nowp' fp' nowq' fq' ch e x)
  then show ?case by (smt semB1)
qed

lemma semB3:
  "semBP (P || Q) nowp fp nowq fq nowp' fp' nowq' fq' \<Longrightarrow>
   chanset P = {} \<and> chanset Q = {} \<Longrightarrow>
   semB P nowp fp nowp' fp' \<and> semB Q nowq fq nowq' fq'"
  by (induct rule: semBP.cases; simp add: chanset_def)

end


theory Submission
  imports Defs
begin

lemma record_updates [simp]:
  "pc (update_pc st i l) = (pc st) (i := l)"
  "pc (update_x st i v) = pc st"
  "pc (update_y st i v) = pc st"
  "x (update_pc st i l) = x st"
  "x (update_x st i v) = (x st) (i := v)"
  "y (update_y st i v) = (y st) (i := v)"
  "y (update_pc st i l) = y st"
  "x (update_y st i v) = x st"
  "y (update_x st i v) = y st"
  by (simp_all add: update_pc_def update_x_def update_y_def)

lemma x_assigned:
  assumes "reachable st"
  shows   "\<forall>i. Proc i \<longrightarrow> pc st j \<noteq> assign_x \<longrightarrow> x st j = 1"
  using assms by induction auto

lemma N_gt_0: "N > 0"
  using Proc_def proc_0 by auto

theorem reachable_safe: "reachable st \<Longrightarrow> safe st"
proof (induction rule: reachable.induct)
  case (y_step st i)
  show ?case
  proof (cases "Proc i")
    case True
    show ?thesis
    proof (cases "\<exists>j. Proc j \<and> j \<noteq> i \<and> pc st j \<noteq> finished")
      case True
      thus ?thesis
        by (auto simp: safe_def)
    next
      case False
      have "x st ((i + 1) mod N) = 1"
      proof -
        from y_step have "Proc ((i + 1) mod N)"
          using N_gt_0 by (simp add: Proc_def)
        moreover from this have "pc st ((i + 1) mod N) \<noteq> assign_x"
          using False y_step by auto
        ultimately show "x st ((i + 1) mod N) = 1"
          using x_assigned y_step by auto
      qed
      thus ?thesis
        using \<open>Proc i\<close> by (auto simp: safe_def)
    qed
  qed (use y_step in \<open>auto simp: safe_def\<close>)
qed (use proc_0 in \<open>auto simp: safe_def\<close>)

end


(*  Title:       Omega Automata
*)

header {* Omega Automata *}

theory OmegaAutomaton
imports Main LTS SemiAutomaton
        "../Libs/Automata_Merz/Buchi"
begin

text {* This theory defines omega automata. *}

datatype ('q, 'a, 'more) OmegaAutomaton =
   ExOmegaAutomaton "('q, 'a, 'more) SemiAutomaton_rec_scheme"
                    "(('q, 'a, 'more) SemiAutomaton_rec_scheme \<Rightarrow> ('q word) \<Rightarrow> bool)"
 | UnOmegaAutomaton "('q, 'a, 'more) SemiAutomaton_rec_scheme"
                    "(('q, 'a, 'more) SemiAutomaton_rec_scheme \<Rightarrow> ('q word) \<Rightarrow> bool)"

fun OmegaAutomaton_accept where
  "OmegaAutomaton_accept (ExOmegaAutomaton \ a_fun) w =
     (\<exists>r. SemiAutomaton_is_inf_run \ w r \<and> a_fun \ r)"
 | "OmegaAutomaton_accept (UnOmegaAutomaton \ a_fun) w =
     (\<forall>r. SemiAutomaton_is_inf_run \ w r \<longrightarrow> a_fun \ r)"

definition OmegaAutomaton_\<L> where
  "OmegaAutomaton_\<L> A = {w. OmegaAutomaton_accept A w}"

record ('q,'a) Buchi_rec =
  "('q, 'a) SemiAutomaton_rec" +
  \<F> :: "'q set"           -- "The set of accepting states"

definition SemiAutomaton_to_Buchi ::
  "('q, 'a, _) SemiAutomaton_rec_scheme \<Rightarrow> 'q set \<Rightarrow> ('q, 'a) Buchi_rec" where
  "SemiAutomaton_to_Buchi \ F =  \<lparr> \<Q> = \<Q> \, \<Sigma> = \<Sigma> \, \<Delta> = \<Delta> \, \ = \ \, \<F> = F \<rparr>"

lemma SemiAutomaton_to_Buchi_\<Q>[simp]:
  "\<Q> (SemiAutomaton_to_Buchi \ F) = \<Q> \" unfolding SemiAutomaton_to_Buchi_def by simp

lemma SemiAutomaton_to_Buchi_\<Sigma>[simp]:
  "\<Sigma> (SemiAutomaton_to_Buchi \ F) = \<Sigma> \" unfolding SemiAutomaton_to_Buchi_def by simp

lemma SemiAutomaton_to_Buchi_\[simp]:
  "\ (SemiAutomaton_to_Buchi \ F) = \ \" unfolding SemiAutomaton_to_Buchi_def by simp

lemma SemiAutomaton_to_Buchi_\<Delta>[simp]:
  "\<Delta> (SemiAutomaton_to_Buchi \ F) = \<Delta> \" unfolding SemiAutomaton_to_Buchi_def by simp

lemma SemiAutomaton_to_Buchi_\<delta>[simp]:
  "\<delta> (SemiAutomaton_to_Buchi \ F) = \<delta> \" unfolding \<delta>_def by simp

lemma SemiAutomaton_to_Buchi_\<F>[simp]:
  "\<F> (SemiAutomaton_to_Buchi \ F) = F" unfolding SemiAutomaton_to_Buchi_def by simp

definition BuchiAutomaton :: "('q, 'a, _) Buchi_rec_scheme \<Rightarrow> ('q, 'a, _) OmegaAutomaton" where
  "BuchiAutomaton \ = ExOmegaAutomaton \ (\<lambda>\ r. buchi_accepting (\<F> \) r)"

definition BuchiAutomaton' :: "('q, 'a, _) Buchi_rec_scheme \<Rightarrow> ('q, 'a, _) OmegaAutomaton" where
  "BuchiAutomaton' \ = ExOmegaAutomaton \ (\<lambda>\ r. buchi_accepting' (\<F> \) r)"

subsection {* To Merz *}

definition SemiAutomaton_to_ndtable_ext :: "_ \<Rightarrow> ('q, 'a, _) SemiAutomaton_rec_scheme \<Rightarrow> ('q, 'a, _) ndtable_scheme" where
  "SemiAutomaton_to_ndtable_ext m \ =
   \<lparr> initial = \ \, trans = (\<lambda>q a. {q'. (q, a, q') \<in> \<Delta> \}), \<dots> = m\<rparr>"

abbreviation "SemiAutomaton_to_ndtable \<equiv> (SemiAutomaton_to_ndtable_ext ())"

lemma SemiAutomaton_to_ndtable_ext___SemiAutomaton_to_Buchi[simp] :
  "SemiAutomaton_to_ndtable_ext m (SemiAutomaton_to_Buchi \ F) =
   SemiAutomaton_to_ndtable_ext m \"
unfolding SemiAutomaton_to_ndtable_ext_def by simp

lemma SemiAutomaton_to_ndtable_ext_\ [simp]:
  "initial (SemiAutomaton_to_ndtable_ext m \) = \ \"
unfolding SemiAutomaton_to_ndtable_ext_def by simp

lemma SemiAutomaton_to_ndtable_ext_\<Delta> [simp]:
  "(q' \<in> (trans (SemiAutomaton_to_ndtable_ext m \) q a)) = ((q, a, q') \<in> \<Delta> \)"
unfolding SemiAutomaton_to_ndtable_ext_def by simp

lemma SemiAutomaton_to_ndtable_ext___nd_exec_fragment [simp] :
  "nd_exec_fragment (SemiAutomaton_to_ndtable_ext m \) inp run \<longleftrightarrow>
   LTS_is_fin_run (\<Delta> \) inp run"
unfolding nd_exec_fragment_def LTS_is_fin_run_def
by simp

lemma SemiAutomaton_to_ndtable_ext___nd_execution [simp] :
  "nd_execution (SemiAutomaton_to_ndtable_ext m \) inp run \<longleftrightarrow>
   LTS_is_inf_run (\<Delta> \) inp run"
unfolding nd_execution_def LTS_is_inf_run_def  by simp

lemma SemiAutomaton_to_ndtable_ext___nd_run [simp] :
  "nd_run (SemiAutomaton_to_ndtable_ext m \) inp run \<longleftrightarrow>
   SemiAutomaton_is_inf_run \ inp run"
unfolding nd_run_def SemiAutomaton_is_inf_run_def by auto

lemma SemiAutomaton_to_ndtable_ext___det_table [simp] :
assumes "\ \ \<noteq> {}"
shows "det_table (SemiAutomaton_to_ndtable_ext m \) \<longleftrightarrow>
       SemiAutomaton_is_deterministic \"
using assms
unfolding det_table_def atmost_one_def SemiAutomaton_is_deterministic_def LTS_is_deterministic_def
by auto

lemma SemiAutomaton_to_ndtable_ext___det_table_impl :
  "SemiAutomaton_is_deterministic \ \<Longrightarrow> det_table (SemiAutomaton_to_ndtable_ext m \)"
unfolding det_table_def atmost_one_def
          SemiAutomaton_is_deterministic_def LTS_is_deterministic_def
by auto

lemma (in SemiAutomaton) SemiAutomaton_to_ndtable___states_of :
  "states_of (SemiAutomaton_to_ndtable_ext m \) \<subseteq> \<Q> \"
unfolding states_of_def SemiAutomaton_to_ndtable_ext_def
using \<Delta>_consistent \_consistent
by auto

lemma SemiAutomaton_to_ndtable_ext___one_step [simp] :
  "one_step (SemiAutomaton_to_ndtable_ext m \) =
   LTS_forget_labels (\<Delta> \)"
unfolding one_step_def LTS_forget_labels_def
by simp

definition BuchiAutomaton_to_ndbuchi :: "('q, 'a, _) Buchi_rec_scheme \<Rightarrow> ('q, 'a) ndbuchi" where
  "BuchiAutomaton_to_ndbuchi \ =
   SemiAutomaton_to_ndtable_ext \<lparr>accept = \<F> \\<rparr> \"

lemma BuchiAutomaton_to_ndbuchi_alt_def :
  "BuchiAutomaton_to_ndbuchi \ =
   \<lparr> initial = \ \, trans = (\<lambda>q a. {q'. (q, a, q') \<in> \<Delta> \}), accept = \<F> \\<rparr>"
unfolding BuchiAutomaton_to_ndbuchi_def SemiAutomaton_to_ndtable_ext_def by simp

lemma BuchiAutomaton_to_ndbuchi___accept[simp]:
  "accept (BuchiAutomaton_to_ndbuchi \) = \<F> \"
  unfolding BuchiAutomaton_to_ndbuchi_alt_def by simp

lemmas BuchiAutomaton_to_ndbuchi___accept'[simp] =
  BuchiAutomaton_to_ndbuchi___accept[unfolded BuchiAutomaton_to_ndbuchi_def]

lemma BuchiAutomaton_to_ndbuchi___initial[simp]:
  "initial (BuchiAutomaton_to_ndbuchi \) = \ \"
  unfolding BuchiAutomaton_to_ndbuchi_alt_def by simp

lemma BuchiAutomaton_to_ndbuchi_correct :
  "OmegaAutomaton_\<L> (BuchiAutomaton \) =
   buchi_language (BuchiAutomaton_to_ndbuchi \)"
unfolding buchi_language_def OmegaAutomaton_\<L>_def BuchiAutomaton_def
by (simp add: set_eq_iff BuchiAutomaton_to_ndbuchi_def)

lemma BuchiAutomaton_to_ndbuchi_correct' :
  "OmegaAutomaton_\<L> (BuchiAutomaton' \) =
   buchi_language' (BuchiAutomaton_to_ndbuchi \)"
unfolding buchi_language'_def OmegaAutomaton_\<L>_def BuchiAutomaton'_def
by (simp add: set_eq_iff BuchiAutomaton_to_ndbuchi_def)

definition comb_BuchiAutomaton ::
  "('q1, 'a, _) Buchi_rec_scheme \<Rightarrow>
   ('q2, 'a, _) Buchi_rec_scheme \<Rightarrow> ('q1 + 'q2, 'a) Buchi_rec" where
"comb_BuchiAutomaton \1 \2 == SemiAutomaton_to_Buchi (comb_SemiAutomaton \1 \2)
   ((\<F> \1) <+> (\<F> \2))"

lemma BuchiAutomaton_to_ndbuchi_comb [simp] :
   "BuchiAutomaton_to_ndbuchi (comb_BuchiAutomaton \1 \2) =
    buchi_union (BuchiAutomaton_to_ndbuchi \1) (BuchiAutomaton_to_ndbuchi \2)"
apply (simp add: BuchiAutomaton_to_ndbuchi_def comb_BuchiAutomaton_def
         buchi_union_def SemiAutomaton_to_ndtable_ext_def LTS_comb_def)
apply (rule ext)
apply (rule ext)
apply (auto simp add: set_eq_iff split: sum.splits)
done

lemma BuchiAutomaton_comb_correct :
  "OmegaAutomaton_\<L> (BuchiAutomaton (comb_BuchiAutomaton \1 \2)) =
   OmegaAutomaton_\<L> (BuchiAutomaton \1) \<union> OmegaAutomaton_\<L> (BuchiAutomaton \2)"
by (simp add: BuchiAutomaton_to_ndbuchi_correct buchi_union)

lemma BuchiAutomaton_comb_correct' :
  "OmegaAutomaton_\<L> (BuchiAutomaton' (comb_BuchiAutomaton \1 \2)) =
   OmegaAutomaton_\<L> (BuchiAutomaton' \1) \<union> OmegaAutomaton_\<L> (BuchiAutomaton' \2)"
by (simp add: BuchiAutomaton_to_ndbuchi_correct' buchi_union')

end