(*  Title:      Doc/Corec/Corec.thy
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Andreas Lochbihler, ETH Zuerich
    Author:     Andrei Popescu, Middlesex University
    Author:     Dmitriy Traytel, ETH Zuerich

Tutorial for nonprimitively corecursive definitions.
*)

theory Corec
imports Main Datatypes.Setup "HOL-Library.BNF_Corec"
  "HOL-Library.FSet"
begin

section \<open>Introduction
  \label{sec:introduction}\<close>

text \<open>
Isabelle's (co)datatype package @{cite "isabelle-datatypes"} offers a convenient
syntax for introducing codatatypes. For example, the type of (infinite) streams
can be defined as follows (cf. \<^file>\<open>~~/src/HOL/Library/Stream.thy\<close>):
\<close>

    codatatype 'a stream =
      SCons (shd: 'a) (stl: "'a stream")

text \<open>
\noindent
The (co)datatype package also provides two commands, \keyw{primcorec} and
\keyw{prim\-corec\-ur\-sive}, for defining primitively corecursive functions.

This tutorial presents a definitional package for functions beyond
primitive corecursion. It describes @{command corec} and related commands:\
@{command corecursive}, @{command friend_of_corec}, and @{command coinduction_upto}.
It also covers the @{method corec_unique} proof method.
The package is not part of \<^theory>\<open>Main\<close>; it is located in
\<^file>\<open>~~/src/HOL/Library/BNF_Corec.thy\<close>.

The @{command corec} command generalizes \keyw{primcorec} in three main
respects. First, it allows multiple constructors around corecursive calls, where
\keyw{primcorec} expects exactly one. For example:
\<close>

    corec oneTwos :: "nat stream" where
      "oneTwos = SCons 1 (SCons 2 oneTwos)"

text \<open>
Second, @{command corec} allows other functions than constructors to appear in
the corecursive call context (i.e., around any self-calls on the right-hand side
of the equation). The requirement on these functions is that they must be
\emph{friendly}. Intuitively, a function is friendly if it needs to destruct
at most one constructor of input to produce one constructor of output.
We can register functions as friendly using the @{command friend_of_corec}
command, or by passing the \<open>friend\<close> option to @{command corec}. The
friendliness check relies on an internal syntactic check in combination with
a parametricity subgoal, which must be discharged manually (typically using
@{method transfer_prover} or @{method transfer_prover_eq}).

Third, @{command corec} allows self-calls that are not guarded by a constructor,
as long as these calls occur in a friendly context (a context consisting
exclusively of friendly functions) and can be shown to be terminating
(well founded). The mixture of recursive and corecursive calls in a single
function can be quite useful in practice.

Internally, the package synthesizes corecursors that take into account the
possible call contexts. The corecursor is accompanined by a corresponding,
equally general coinduction principle. The corecursor and the coinduction
principle grow in expressiveness as we interact with it. In process algebra
terminology, corecursion and coinduction take place \emph{up to} friendly
contexts.

The package fully adheres to the LCF philosophy @{cite mgordon79}: The
characteristic theorems associated with the specified corecursive functions are
derived rather than introduced axiomatically.
(Exceptionally, most of the internal proof obligations are omitted if the
\<open>quick_and_dirty\<close> option is enabled.)
The package is described in a pair of scientific papers
@{cite "blanchette-et-al-2015-fouco" and "blanchette-et-al-201x-amico"}. Some
of the text and examples below originate from there.

This tutorial is organized as follows:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item Section \ref{sec:introductory-examples}, ``Introductory Examples,''
describes how to specify corecursive functions and to reason about them.

\item Section \ref{sec:command-syntax}, ``Command Syntax,'' describes the syntax
of the commands offered by the package.

\item Section \ref{sec:generated-theorems}, ``Generated Theorems,'' lists the
theorems produced by the package's commands.

\item Section \ref{sec:proof-methods}, ``Proof Methods,'' briefly describes the
@{method corec_unique} and @{method transfer_prover_eq} proof methods.

\item Section \ref{sec:attribute}, ``Attribute,'' briefly describes the
@{attribute friend_of_corec_simps} attribute, which can be used to strengthen
the tactics underlying the @{command friend_of_corec} and @{command corec}
\<open>(friend)\<close> commands.

\item Section \ref{sec:known-bugs-and-limitations}, ``Known Bugs and
Limitations,'' concludes with known open issues.
\end{itemize}

Although it is more powerful than \keyw{primcorec} in many respects,
@{command corec} suffers from a number of limitations. Most notably, it does
not support mutually corecursive codatatypes, and it is less efficient than
\keyw{primcorec} because it needs to dynamically synthesize corecursors and
corresponding coinduction principles to accommodate the friends.

\newbox\boxA
\setbox\boxA=\hbox{\texttt{NOSPAM}}

\newcommand\authoremaili{\texttt{jasmin.blan{\color{white}NOSPAM}\kern-\wd\boxA{}chette@\allowbreak
gmail.\allowbreak com}}

Comments and bug reports concerning either the package or this tutorial should
be directed to the first author at \authoremaili{} or to the
\texttt{cl-isabelle-users} mailing list.
\<close>

section \<open>Introductory Examples
  \label{sec:introductory-examples}\<close>

text \<open>
The package is illustrated through concrete examples featuring different flavors
of corecursion. More examples can be found in the directory
\<^dir>\<open>~~/src/HOL/Corec_Examples\<close>.
\<close>

subsection \<open>Simple Corecursion
  \label{ssec:simple-corecursion}\<close>

text \<open>
The case studies by Rutten~@{cite rutten05} and Hinze~@{cite hinze10} on stream
calculi serve as our starting point. The following definition of pointwise sum
can be performed with either \keyw{primcorec} or @{command corec}:
\<close>

    primcorec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"

text \<open>
\noindent
Pointwise sum meets the friendliness criterion. We register it as a friend using
the @{command friend_of_corec} command. The command requires us to give a
specification of \<^const>\<open>ssum\<close> where a constructor (\<^const>\<open>SCons\<close>) occurs at
the outermost position on the right-hand side. Here, we can simply reuse the
\keyw{primcorec} specification above:
\<close>

    friend_of_corec ssum :: "('a :: plus) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
      "ssum xs ys = SCons (shd xs + shd ys) (ssum (stl xs) (stl ys))"
       apply (rule ssum.code)
      by transfer_prover

text \<open>
\noindent
The command emits two subgoals. The first subgoal corresponds to the equation we
specified and is trivial to discharge. The second subgoal is a parametricity
property that captures the the requirement that the function may destruct at
most one constructor of input to produce one constructor of output. This subgoal
can usually be discharged using the \<open>transfer_prover\<close> or
@{method transfer_prover_eq} proof method (Section~\ref{ssec:transfer-prover-eq}).
The latter replaces equality relations by their relator terms according to the
@{thm [source] relator_eq} theorem collection before it invokes
@{method transfer_prover}.

After registering \<^const>\<open>ssum\<close> as a friend, we can use it in the corecursive
call context, either inside or outside the constructor guard:
\<close>

    corec fibA :: "nat stream" where
      "fibA = SCons 0 (ssum (SCons 1 fibA) fibA)"

text \<open>\blankline\<close>

    corec fibB :: "nat stream" where
      "fibB = ssum (SCons 0 (SCons 1 fibB)) (SCons 0 fibB)"

text \<open>
Using the \<open>friend\<close> option, we can simultaneously define a function and
register it as a friend:
\<close>

    corec (friend)
      sprod :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sprod xs ys =
       SCons (shd xs * shd ys) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys))"

text \<open>\blankline\<close>

    corec (friend) sexp :: "nat stream \<Rightarrow> nat stream" where
      "sexp xs = SCons (2 ^^ shd xs) (sprod (stl xs) (sexp xs))"

text \<open>
\noindent
The parametricity subgoal is given to \<open>transfer_prover_eq\<close>
(Section~\ref{ssec:transfer-prover-eq}).

The \<^const>\<open>sprod\<close> and \<^const>\<open>sexp\<close> functions provide shuffle product and
exponentiation on streams. We can use them to define the stream of factorial
numbers in two different ways:
\<close>

    corec factA :: "nat stream" where
      "factA = (let zs = SCons 1 factA in sprod zs zs)"

text \<open>\blankline\<close>

    corec factB :: "nat stream" where
      "factB = sexp (SCons 0 factB)"

text \<open>
The arguments of friendly functions can be of complex types involving the
target codatatype. The following example defines the supremum of a finite set of
streams by primitive corecursion and registers it as friendly:
\<close>

    corec (friend) sfsup :: "nat stream fset \<Rightarrow> nat stream" where
      "sfsup X = SCons (Sup (fset (fimage shd X))) (sfsup (fimage stl X))"

text \<open>
\noindent
In general, the arguments may be any bounded natural functor (BNF)
@{cite "isabelle-datatypes"}, with the restriction that the target codatatype
(\<^typ>\<open>nat stream\<close>) may occur only in a \emph{live} position of the BNF. For
this reason, the following function, on unbounded sets, cannot be registered as
a friend:
\<close>

    primcorec ssup :: "nat stream set \<Rightarrow> nat stream" where
      "ssup X = SCons (Sup (image shd X)) (ssup (image stl X))"

subsection \<open>Nested Corecursion
  \label{ssec:nested-corecursion}\<close>

text \<open>
The package generally supports arbitrary codatatypes with multiple constructors
and nesting through other type constructors (BNFs). Consider the following type
of finitely branching Rose trees of potentially infinite depth:
\<close>

    codatatype 'a tree =
      Node (lab: 'a) (sub: "'a tree list")

text \<open>
We first define the pointwise sum of two trees analogously to \<^const>\<open>ssum\<close>:
\<close>

    corec (friend) tsum :: "('a :: plus) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "tsum t u =
       Node (lab t + lab u) (map (\<lambda>(t', u'). tsum t' u') (zip (sub t) (sub u)))"

text \<open>
\noindent
Here, \<^const>\<open>map\<close> is the standard map function on lists, and \<^const>\<open>zip\<close>
converts two parallel lists into a list of pairs. The \<^const>\<open>tsum\<close> function is
primitively corecursive. Instead of @{command corec} \<open>(friend)\<close>, we could
also have used \keyw{primcorec} and @{command friend_of_corec}, as we did for
\<^const>\<open>ssum\<close>.

Once \<^const>\<open>tsum\<close> is registered as friendly, we can use it in the corecursive
call context of another function:
\<close>

    corec (friend) ttimes :: "('a :: {plus,times}) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
      "ttimes t u = Node (lab t * lab u)
         (map (\<lambda>(t', u'). tsum (ttimes t u') (ttimes t' u)) (zip (sub t) (sub u)))"

text \<open>
All the syntactic convenience provided by \keyw{primcorec} is also supported by
@{command corec}, @{command corecursive}, and @{command friend_of_corec}. In
particular, nesting through the function type can be expressed using
\<open>\<lambda>\<close>-abstractions and function applications rather than through composition
(\<^term>\<open>(\<circ>)\<close>, the map function for \<open>\<Rightarrow>\<close>). For example:
\<close>

    codatatype 'a language =
      Lang (\<oo>: bool) (\<dd>: "'a \<Rightarrow> 'a language")

text \<open>\blankline\<close>

    corec (friend) Plus :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Plus r s = Lang (\<oo> r \<or> \<oo> s) (\<lambda>a. Plus (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) Times :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Times r s = Lang (\<oo> r \<and> \<oo> s)
         (\<lambda>a. if \<oo> r then Plus (Times (\<dd> r a) s) (\<dd> s a) else Times (\<dd> r a) s)"

text \<open>\blankline\<close>

    corec (friend) Star :: "'a language \<Rightarrow> 'a language" where
      "Star r = Lang True (\<lambda>a. Times (\<dd> r a) (Star r))"

text \<open>\blankline\<close>

    corec (friend) Inter :: "'a language \<Rightarrow> 'a language \<Rightarrow> 'a language" where
      "Inter r s = Lang (\<oo> r \<and> \<oo> s) (\<lambda>a. Inter (\<dd> r a) (\<dd> s a))"

text \<open>\blankline\<close>

    corec (friend) PLUS :: "'a language list \<Rightarrow> 'a language" where
      "PLUS xs = Lang (\<exists>x \<in> set xs. \<oo> x) (\<lambda>a. PLUS (map (\<lambda>r. \<dd> r a) xs))"

subsection \<open>Mixed Recursion--Corecursion
  \label{ssec:mixed-recursion-corecursion}\<close>

text \<open>
It is often convenient to let a corecursive function perform some finite
computation before producing a constructor. With mixed recursion--corecursion, a
finite number of unguarded recursive calls perform this calculation before
reaching a guarded corecursive call. Intuitively, the unguarded recursive call
can be unfolded to arbitrary finite depth, ultimately yielding a purely
corecursive definition. An example is the \<^term>\<open>primes\<close> function from Di
Gianantonio and Miculan @{cite "di-gianantonio-miculan-2003"}:
\<close>

    corecursive primes :: "nat \<Rightarrow> nat \<Rightarrow> nat stream" where
      "primes m n =
       (if (m = 0 \<and> n > 1) \<or> coprime m n then
          SCons n (primes (m * n) (n + 1))
        else
          primes m (n + 1))"
      apply (relation "measure (\<lambda>(m, n).
        if n = 0 then 1 else if coprime m n then 0 else m - n mod m)")
       apply (auto simp: mod_Suc diff_less_mono2 intro: Suc_lessI elim!: not_coprimeE)
      apply (metis dvd_1_iff_1 dvd_eq_mod_eq_0 mod_0 mod_Suc mod_Suc_eq mod_mod_cancel)
      done

text \<open>
\noindent
The @{command corecursive} command is a variant of @{command corec} that allows
us to specify a termination argument for any unguarded self-call.

When called with \<open>m = 1\<close> and \<open>n = 2\<close>, the \<^const>\<open>primes\<close>
function computes the stream of prime numbers. The unguarded call in the
\<open>else\<close> branch increments \<^term>\<open>n\<close> until it is coprime to the first
argument \<^term>\<open>m\<close> (i.e., the greatest common divisor of \<^term>\<open>m\<close> and
\<^term>\<open>n\<close> is \<open>1\<close>).

For any positive integers \<^term>\<open>m\<close> and \<^term>\<open>n\<close>, the numbers \<^term>\<open>m\<close> and
\<open>m * n + 1\<close> are coprime, yielding an upper bound on the number of times
\<^term>\<open>n\<close> is increased. Hence, the function will take the \<open>else\<close> branch at
most finitely often before taking the then branch and producing one constructor.
There is a slight complication when \<open>m = 0 \<and> n > 1\<close>: Without the first
disjunct in the \<open>if\<close> condition, the function could stall. (This corner
case was overlooked in the original example
@{cite "di-gianantonio-miculan-2003"}.)

In the following examples, termination is discharged automatically by
@{command corec} by invoking @{method lexicographic_order}:
\<close>

    corec catalan :: "nat \<Rightarrow> nat stream" where
      "catalan n =
       (if n > 0 then ssum (catalan (n - 1)) (SCons 0 (catalan (n + 1)))
        else SCons 1 (catalan 1))"

text \<open>\blankline\<close>

    corec collatz :: "nat \<Rightarrow> nat stream" where
      "collatz n = (if even n \<and> n > 0 then collatz (n div 2)
         else SCons n (collatz (3 * n + 1)))"

text \<open>
A more elaborate case study, revolving around the filter function on lazy lists,
is presented in \<^file>\<open>~~/src/HOL/Corec_Examples/LFilter.thy\<close>.
\<close>

subsection \<open>Self-Friendship
  \label{ssec:self-friendship}\<close>

text \<open>
The package allows us to simultaneously define a function and use it as its own
friend, as in the following definition of a ``skewed product'':
\<close>

    corec (friend)
      sskew :: "('a :: {plus,times}) stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
    where
      "sskew xs ys =
       SCons (shd xs * shd ys) (sskew (sskew xs (stl ys)) (sskew (stl xs) ys))"

text \<open>
\noindent
Such definitions, with nested self-calls on the right-hand side, cannot be
separated into a @{command corec} part and a @{command friend_of_corec} part.
\<close>

subsection \<open>Coinduction
  \label{ssec:coinduction}\<close>

text \<open>
Once a corecursive specification has been accepted, we normally want to reason
about it. The \<open>codatatype\<close> command generates a structural coinduction
principle that matches primitively corecursive functions. For nonprimitive
specifications, our package provides the more advanced proof principle of
\emph{coinduction up to congruence}---or simply \emph{coinduction up-to}.

The structural coinduction principle for \<^typ>\<open>'a stream\<close>, called
@{thm [source] stream.coinduct}, is as follows:
%
\begin{indentblock}
@{thm stream.coinduct[no_vars]}
\end{indentblock}
%
Coinduction allows us to prove an equality \<open>l = r\<close> on streams by
providing a relation \<open>R\<close> that relates \<open>l\<close> and \<open>r\<close> (first
premise) and that constitutes a bisimulation (second premise). Streams that are
related by a bisimulation cannot be distinguished by taking observations (via
the selectors \<^const>\<open>shd\<close> and \<^const>\<open>stl\<close>); hence they must be equal.

The coinduction up-to principle after registering \<^const>\<open>sskew\<close> as friendly is
available as @{thm [source] sskew.coinduct} and as one of the components of
the theorem collection @{thm [source] stream.coinduct_upto}:
%
\begin{indentblock}
@{thm sskew.coinduct[no_vars]}
\end{indentblock}
%
This rule is almost identical to structural coinduction, except that the
corecursive application of \<^term>\<open>R\<close> is generalized to
\<^term>\<open>stream.v5.congclp R\<close>.

The \<^const>\<open>stream.v5.congclp\<close> predicate is equipped with the following
introduction rules:

\begin{indentblock}
\begin{description}

\item[@{thm [source] sskew.cong_base}\rm:] ~ \\
@{thm sskew.cong_base[no_vars]}

\item[@{thm [source] sskew.cong_refl}\rm:] ~ \\
@{thm sskew.cong_refl[no_vars]}

\item[@{thm [source] sskew.cong_sym}\rm:] ~ \\
@{thm sskew.cong_sym[no_vars]}

\item[@{thm [source] sskew.cong_trans}\rm:] ~ \\
@{thm sskew.cong_trans[no_vars]}

\item[@{thm [source] sskew.cong_SCons}\rm:] ~ \\
@{thm sskew.cong_SCons[no_vars]}

\item[@{thm [source] sskew.cong_ssum}\rm:] ~ \\
@{thm sskew.cong_ssum[no_vars]}

\item[@{thm [source] sskew.cong_sprod}\rm:] ~ \\
@{thm sskew.cong_sprod[no_vars]}

\item[@{thm [source] sskew.cong_sskew}\rm:] ~ \\
@{thm sskew.cong_sskew[no_vars]}

\end{description}
\end{indentblock}
%
The introduction rules are also available as
@{thm [source] sskew.cong_intros}.

Notice that there is no introduction rule corresponding to \<^const>\<open>sexp\<close>,
because \<^const>\<open>sexp\<close> has a more restrictive result type than \<^const>\<open>sskew\<close>
(\<^typ>\<open>nat stream\<close> vs. \<^typ>\<open>('a :: {plus,times}) stream\<close>.

The version numbers, here \<open>v5\<close>, distinguish the different congruence
closures generated for a given codatatype as more friends are registered. As
much as possible, it is recommended to avoid referring to them in proof
documents.

Since the package maintains a set of incomparable corecursors, there is also a
set of associated coinduction principles and a set of sets of introduction
rules. A technically subtle point is to make Isabelle choose the right rules in
most situations. For this purpose, the package maintains the collection
@{thm [source] stream.coinduct_upto} of coinduction principles ordered by
increasing generality, which works well with Isabelle's philosophy of applying
the first rule that matches. For example, after registering \<^const>\<open>ssum\<close> as a
friend, proving the equality \<^term>\<open>l = r\<close> on \<^typ>\<open>nat stream\<close> might
require coinduction principle for \<^term>\<open>nat stream\<close>, which is up to
\<^const>\<open>ssum\<close>.

The collection @{thm [source] stream.coinduct_upto} is guaranteed to be complete
and up to date with respect to the type instances of definitions considered so
far, but occasionally it may be necessary to take the union of two incomparable
coinduction principles. This can be done using the @{command coinduction_upto}
command. Consider the following definitions:
\<close>

    codatatype ('a, 'b) tllist =
      TNil (terminal: 'b)
    | TCons (thd: 'a) (ttl: "('a, 'b) tllist")

text \<open>\blankline\<close>

    corec (friend) square_elems :: "(nat, 'b) tllist \<Rightarrow> (nat, 'b) tllist" where
      "square_elems xs =
       (case xs of
         TNil z \<Rightarrow> TNil z
       | TCons y ys \<Rightarrow> TCons (y ^^ 2) (square_elems ys))"

text \<open>\blankline\<close>

    corec (friend) square_terminal :: "('a, int) tllist \<Rightarrow> ('a, int) tllist" where
      "square_terminal xs =
       (case xs of
         TNil z \<Rightarrow> TNil (z ^^ 2)
       | TCons y ys \<Rightarrow> TCons y (square_terminal ys))"

text \<open>
At this point, @{thm [source] tllist.coinduct_upto} contains three variants of the
coinduction principles:
%
\begin{itemize}
\item \<^typ>\<open>('a, int) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>, and
  \<^const>\<open>square_terminal\<close>;
\item \<^typ>\<open>(nat, 'b) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>, and
  \<^const>\<open>square_elems\<close>;
\item \<^typ>\<open>('a, 'b) tllist\<close> up to \<^const>\<open>TNil\<close> and \<^const>\<open>TCons\<close>.
\end{itemize}
%
The following variant is missing:
%
\begin{itemize}
\item \<^typ>\<open>(nat, int) tllist\<close> up to \<^const>\<open>TNil\<close>, \<^const>\<open>TCons\<close>,
  \<^const>\<open>square_elems\<close>, and \<^const>\<open>square_terminal\<close>.
\end{itemize}
%
To generate it without having to define a new function with @{command corec},
we can use the following command:
\<close>

    coinduction_upto nat_int_tllist: "(nat, int) tllist"

text \<open>
\noindent
This produces the theorems
%
\begin{indentblock}
@{thm [source] nat_int_tllist.coinduct_upto} \\
@{thm [source] nat_int_tllist.cong_intros}
\end{indentblock}
%
(as well as the individually named introduction rules) and extends
the dynamic collections @{thm [source] tllist.coinduct_upto} and
@{thm [source] tllist.cong_intros}.
\<close>

subsection \<open>Uniqueness Reasoning
  \label{ssec:uniqueness-reasoning}\<close>

text \<open>
It is sometimes possible to achieve better automation by using a more
specialized proof method than coinduction. Uniqueness principles maintain a good
balance between expressiveness and automation. They exploit the property that a
corecursive definition is the unique solution to a fixpoint equation.

The @{command corec}, @{command corecursive}, and @{command friend_of_corec}
commands generate a property \<open>f.unique\<close> about the function of interest
\<^term>\<open>f\<close> that can be used to prove that any function that satisfies
\<^term>\<open>f\<close>'s corecursive specification must be equal to~\<^term>\<open>f\<close>. For example:
\[@{thm ssum.unique[no_vars]}\]

The uniqueness principles are not restricted to functions defined using
@{command corec} or @{command corecursive} or registered with
@{command friend_of_corec}. Suppose \<^term>\<open>t x\<close> is an arbitrary term
depending on \<^term>\<open>x\<close>. The @{method corec_unique} proof method, provided by our
tool, transforms subgoals of the form
\[\<^term>\<open>(\<forall>x. f x = H x f) \<Longrightarrow> f x = t x\<close>\]
into
\[\<^term>\<open>\<forall>x. t x = H x t\<close>\]
The higher-order functional \<^term>\<open>H\<close> must be such that \<^term>\<open>f x = H x f\<close>
would be a valid @{command corec} specification, but without nested self-calls
or unguarded (recursive) calls. Thus, @{method corec_unique} proves uniqueness
of \<^term>\<open>t\<close> with respect to the given corecursive equation regardless of how
\<^term>\<open>t\<close> was defined. For example:
\<close>

    lemma
      fixes f :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream"
      assumes "\<forall>xs ys. f xs ys =
        SCons (shd ys * shd xs) (ssum (f xs (stl ys)) (f (stl xs) ys))"
      shows "f = sprod"
        using assms
      proof corec_unique
        show "sprod = (\<lambda>xs ys :: nat stream.
            SCons (shd ys * shd xs) (ssum (sprod xs (stl ys)) (sprod (stl xs) ys)))"
          apply (rule ext)+
          apply (subst sprod.code)
          by simp
      qed

text \<open>
The proof method relies on some theorems generated by the package. If no function
over a given codatatype has been defined using @{command corec} or
@{command corecursive} or registered as friendly using @{command friend_of_corec},
the theorems will not be available yet. In such cases, the theorems can be
explicitly generated using the command
\<close>

    coinduction_upto stream: "'a stream"

section \<open>Command Syntax
  \label{sec:command-syntax}\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "corec"} & : & \<open>local_theory \<rightarrow> local_theory\<close> \\
  @{command_def "corecursive"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
\end{matharray}

\<^rail>\<open>
  (@@{command corec} | @@{command corecursive}) target? \<newline>
    @{syntax cr_options}? fix @'where' prop
  ;
  @{syntax_def cr_options}: '(' ((@{syntax plugins} | 'friend' | 'transfer') + ',') ')'
\<close>

\medskip

\noindent
The @{command corec} and @{command corecursive} commands introduce a corecursive
function over a codatatype.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition @{cite "isabelle-isar-ref"}.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The \<open>plugins\<close> option indicates which plugins should be enabled
(\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.

\item
The \<open>friend\<close> option indicates that the defined function should be
registered as a friend. This gives rise to additional proof obligations.

\item
The \<open>transfer\<close> option indicates that an unconditional transfer rule
should be generated and proved \<open>by transfer_prover\<close>. The
\<open>[transfer_rule]\<close> attribute is set on the generated theorem.
\end{itemize}

The @{command corec} command is an abbreviation for @{command corecursive}
with appropriate applications of @{method transfer_prover_eq}
(Section~\ref{ssec:transfer-prover-eq}) and @{method lexicographic_order} to
discharge any emerging proof obligations.
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "friend_of_corec"} & : & \<open>local_theory \<rightarrow> proof(prove)\<close>
\end{matharray}

\<^rail>\<open>
  @@{command friend_of_corec} target? \<newline>
    @{syntax foc_options}? fix @'where' prop
  ;
  @{syntax_def foc_options}: '(' ((@{syntax plugins} | 'transfer') + ',') ')'
\<close>

\medskip

\noindent
The @{command friend_of_corec} command registers a corecursive function as
friendly.

The syntactic entity \synt{target} can be used to specify a local context,
\synt{fix} denotes name with an optional type signature, and \synt{prop} denotes
a HOL proposition @{cite "isabelle-isar-ref"}.

The optional target is optionally followed by a combination of the following
options:

\begin{itemize}
\setlength{\itemsep}{0pt}

\item
The \<open>plugins\<close> option indicates which plugins should be enabled
(\<open>only\<close>) or disabled (\<open>del\<close>). By default, all plugins are enabled.

\item
The \<open>transfer\<close> option indicates that an unconditional transfer rule
should be generated and proved \<open>by transfer_prover\<close>. The
\<open>[transfer_rule]\<close> attribute is set on the generated theorem.
\end{itemize}
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-syntax}\<close>

text \<open>
\begin{matharray}{rcl}
  @{command_def "coinduction_upto"} & : & \<open>local_theory \<rightarrow> local_theory\<close>
\end{matharray}

\<^rail>\<open>
  @@{command coinduction_upto} target? name ':' type
\<close>

\medskip

\noindent
The @{command coinduction_upto} generates a coinduction up-to rule for a given
instance of a (possibly polymorphic) codatatype and notes the result with the
specified prefix.

The syntactic entity \synt{name} denotes an identifier and \synt{type} denotes a
type @{cite "isabelle-isar-ref"}.
\<close>

section \<open>Generated Theorems
  \label{sec:generated-theorems}\<close>

text \<open>
The full list of named theorems generated by the package can be obtained by
issuing the command \keyw{print_theorems} immediately after the datatype definition.
This list excludes low-level theorems that reveal internal constructions. To
make these accessible, add the line
\<close>

    declare [[bnf_internals]]
(*<*)
    declare [[bnf_internals = false]]
(*>*)

text \<open>
In addition to the theorem listed below for each command provided by the
package, all commands update the dynamic theorem collections

\begin{indentblock}
\begin{description}

\item[\<open>t.\<close>\hthm{coinduct_upto}]

\item[\<open>t.\<close>\hthm{cong_intros}]

\end{description}
\end{indentblock}
%
for the corresponding codatatype \<open>t\<close> so that they always contain the most
powerful coinduction up-to principles derived so far.
\<close>

subsection \<open>\keyw{corec} and \keyw{corecursive}
  \label{ssec:corec-and-corecursive-theorems}\<close>

text \<open>
For a function \<^term>\<open>f\<close> over codatatype \<open>t\<close>, the @{command corec} and
@{command corecursive} commands generate the following properties (listed for
\<^const>\<open>sexp\<close>, cf. Section~\ref{ssec:simple-corecursion}):

\begin{indentblock}
\begin{description}

\item[\<open>f.\<close>\hthm{code} \<open>[code]\<close>\rm:] ~ \\
@{thm sexp.code[no_vars]} \\
The \<open>[code]\<close> attribute is set by the \<open>code\<close> plugin
@{cite "isabelle-datatypes"}.

\item[\<open>f.\<close>\hthm{coinduct} \<open>[consumes 1, case_names t, case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]\<close>\rm:] ~ \\
@{thm sexp.coinduct[no_vars]}

\item[\<open>f.\<close>\hthm{cong_intros}\rm:] ~ \\
@{thm sexp.cong_intros[no_vars]}

\item[\<open>f.\<close>\hthm{unique}\rm:] ~ \\
@{thm sexp.unique[no_vars]} \\
This property is not generated for mixed recursive--corecursive definitions.

\item[\<open>f.\<close>\hthm{inner_induct}\rm:] ~ \\
This property is only generated for mixed recursive--corecursive definitions.
For \<^const>\<open>primes\<close> (Section~\ref{ssec:mixed-recursion-corecursion}, it reads as
follows: \\[\jot]
@{thm primes.inner_induct[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up \<open>f.cong_intros\<close> are available as

\begin{indentblock}
\begin{description}

\item[\<open>f.\<close>\hthm{cong_base}]

\item[\<open>f.\<close>\hthm{cong_refl}]

\item[\<open>f.\<close>\hthm{cong_sym}]

\item[\<open>f.\<close>\hthm{cong_trans}]

\item[\<open>f.\<close>\hthm{cong_C}\<open>\<^sub>1\<close>, \ldots, \<open>f.\<close>\hthm{cong_C}\<open>\<^sub>n\<close>] ~ \\
where \<open>C\<^sub>1\<close>, \<open>\<dots>\<close>, \<open>C\<^sub>n\<close> are \<open>t\<close>'s
constructors

\item[\<open>f.\<close>\hthm{cong_f}\<open>\<^sub>1\<close>, \ldots, \<open>f.\<close>\hthm{cong_f}\<open>\<^sub>m\<close>] ~ \\
where \<open>f\<^sub>1\<close>, \<open>\<dots>\<close>, \<open>f\<^sub>m\<close> are the available
friends for \<open>t\<close>

\end{description}
\end{indentblock}
\<close>

subsection \<open>\keyw{friend_of_corec}
  \label{ssec:friend-of-corec-theorems}\<close>

text \<open>
The @{command friend_of_corec} command generates the same theorems as
@{command corec} and @{command corecursive}, except that it adds an optional
\<open>friend.\<close> component to the names to prevent potential clashes (e.g.,
\<open>f.friend.code\<close>).
\<close>

subsection \<open>\keyw{coinduction_upto}
  \label{ssec:coinduction-upto-theorems}\<close>

text \<open>
The @{command coinduction_upto} command generates the following properties
(listed for \<open>nat_int_tllist\<close>):

\begin{indentblock}
\begin{description}

\item[\begin{tabular}{@ {}l@ {}}
  \<open>t.\<close>\hthm{coinduct_upto} \<open>[consumes 1, case_names t,\<close> \\
  \phantom{\<open>t.\<close>\hthm{coinduct_upto} \<open>[\<close>}\<open>case_conclusion D\<^sub>1 \<dots>
  D\<^sub>n]\<close>\rm:
\end{tabular}] ~ \\
@{thm nat_int_tllist.coinduct_upto[no_vars]}

\item[\<open>t.\<close>\hthm{cong_intros}\rm:] ~ \\
@{thm nat_int_tllist.cong_intros[no_vars]}

\end{description}
\end{indentblock}

\noindent
The individual rules making up \<open>t.cong_intros\<close> are available
separately as \<open>t.cong_base\<close>, \<open>t.cong_refl\<close>, etc.\
(Section~\ref{ssec:corec-and-corecursive-theorems}).
\<close>

section \<open>Proof Methods
  \label{sec:proof-methods}\<close>

subsection \<open>\textit{corec_unique}
  \label{ssec:corec-unique}\<close>

text \<open>
The @{method corec_unique} proof method can be used to prove the uniqueness of
a corecursive specification. See Section~\ref{ssec:uniqueness-reasoning} for
details.
\<close>

subsection \<open>\textit{transfer_prover_eq}
  \label{ssec:transfer-prover-eq}\<close>

text \<open>
The @{method transfer_prover_eq} proof method replaces the equality relation
\<^term>\<open>(=)\<close> with compound relator expressions according to
@{thm [source] relator_eq} before calling @{method transfer_prover} on the
current subgoal. It tends to work better than plain @{method transfer_prover} on
the parametricity proof obligations of @{command corecursive} and
@{command friend_of_corec}, because they often contain equality relations on
complex types, which @{method transfer_prover} cannot reason about.
\<close>

section \<open>Attribute
  \label{sec:attribute}\<close>

subsection \<open>\textit{friend_of_corec_simps}
  \label{ssec:friend-of-corec-simps}\<close>

text \<open>
The @{attribute friend_of_corec_simps} attribute declares naturality theorems
to be used by @{command friend_of_corec} and @{command corec} \<open>(friend)\<close> in
deriving the user specification from reduction to primitive corecursion.
Internally, these commands derive naturality theorems from the parametricity proof
obligations dischared by the user or the @{method transfer_prover_eq} method, but
this derivation fails if in the arguments of a higher-order constant a type variable
occurs on both sides of the function type constructor. The required naturality
theorem can then be declared with @{attribute friend_of_corec_simps}. See
\<^file>\<open>~~/src/HOL/Corec_Examples/Tests/Iterate_GPV.thy\<close> for an example.
\<close>

section \<open>Known Bugs and Limitations
  \label{sec:known-bugs-and-limitations}\<close>

text \<open>
This section lists the known bugs and limitations of the corecursion package at
the time of this writing.

\begin{enumerate}
\setlength{\itemsep}{0pt}

\item
\emph{Mutually corecursive codatatypes are not supported.}

\item
\emph{The signature of friend functions may not depend on type variables beyond
those that appear in the codatatype.}

\item
\emph{The internal tactics may fail on legal inputs.}
In some cases, this limitation can be circumvented using the
@{attribute friend_of_corec_simps} attribute
(Section~\ref{ssec:friend-of-corec-simps}).

\item
\emph{The \<open>transfer\<close> option is not implemented yet.}

\item
\emph{The constructor and destructor views offered by {\upshape\keyw{primcorec}}
are not supported by @{command corec} and @{command corecursive}.}

\item
\emph{There is no mechanism for registering custom plugins.}

\item
\emph{The package does not interact well with locales.}

\item
\emph{The undocumented \<open>corecUU_transfer\<close> theorem is not as polymorphic as
it could be.}

\item
\emph{All type variables occurring in the arguments of a friendly function must occur
as direct arguments of the type constructor of the resulting type.}

\end{enumerate}
\<close>

end


(*  Title:       CoreC++
    Author:      David von Oheimb, Tobias Nipkow, Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

section \<open>Auxiliary Definitions\<close>

theory Auxiliary
imports Complex_Main "HOL-Library.While_Combinator"
begin

declare
 option.splits[split]
 Let_def[simp]
 subset_insertI2 [simp]
 Cons_eq_map_conv [iff]

(* FIXME move and possibly turn into a general simproc *)
lemma nat_add_max_le[simp]:
  "((n::nat) + max i j \<le> m) = (n + i \<le> m \<and> n + j \<le> m)"
 by arith

lemma Suc_add_max_le[simp]:
  "(Suc(n + max i j) \<le> m) = (Suc(n + i) \<le> m \<and> Suc(n + j) \<le> m)"
by arith

notation Some  ("(\<lfloor>_\<rfloor>)")

lemma butlast_tail:
  "butlast (Xs@[X,Y]) = Xs@[X]"
by (induct Xs) auto

lemma butlast_noteq:"Cs \<noteq> [] \<Longrightarrow> butlast Cs \<noteq> Cs"
by(induct Cs)simp_all

lemma app_hd_tl:"\<lbrakk>Cs \<noteq> []; Cs = Cs' @ tl Cs\<rbrakk> \<Longrightarrow> Cs' = [hd Cs]"

apply (subgoal_tac "[hd Cs] @ tl Cs = Cs' @ tl Cs")
 apply fast
apply simp
done

  apply -
  apply (simp add:append_eq_append_conv2)
  apply (auto simp:in_set_conv_decomp)
     apply (subgoal_tac "hd (us @ C'#Ds') = C'")
      apply (case_tac us)
       apply simp
      apply fastforce
     apply simp
    apply (subgoal_tac "hd (us @ C'#Ds') = C'")
     apply (case_tac us)
      apply simp
     apply fastforce
    apply simp
   apply (subgoal_tac "hd (us @ C'#Cs') = C'")
    apply (case_tac us)
     apply simp
    apply fastforce
   apply (subgoal_tac "hd(C'#Ds') = C'")
    apply simp
   apply (simp (no_asm))
  apply (subgoal_tac "hd (us @ C'#Cs') = C'")
   apply (case_tac us)
    apply simp
   apply fastforce
  apply (subgoal_tac "hd(C'#Ds') = C'")
   apply simp
  apply (simp (no_asm))
  done

definition pick :: "'a set \<Rightarrow> 'a" where
  "pick A \<equiv> SOME x. x \<in> A"

lemma pick_is_element:"x \<in> A \<Longrightarrow> pick A \<in> A"
by (unfold pick_def,rule_tac x="x" in someI)

definition set2list :: "'a set \<Rightarrow> 'a list" where
  "set2list A \<equiv> fst (while (\<lambda>(Es,S). S \<noteq> {})
                       (\<lambda>(Es,S). let x = pick S in (x#Es,S-{x}))
                       ([],A) )"

lemma card_pick:"\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> Suc(card(A-{pick(A)})) = card A"
by (drule card_Suc_Diff1,auto dest!:pick_is_element simp:ex_in_conv)

lemma set2list_prop:"\<lbrakk>finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow>
  \<exists>xs. while (\<lambda>(Es,S). S \<noteq> {})
             (\<lambda>(Es,S). let x = pick S in (x#Es,S-{x}))
             ([],A) = (xs,{}) \<and> (set xs \<union> {} = A)"

apply(rule_tac P="(\<lambda>xs. (set(fst xs) \<union> snd xs = A))" and
               r="measure (card o snd)"  in while_rule)
apply(auto dest:pick_is_element)
apply(auto dest:card_pick simp:ex_in_conv measure_def inv_image_def)
done

lemma set2list_correct:"\<lbrakk>finite A; A \<noteq> {}; set2list A = xs\<rbrakk> \<Longrightarrow> set xs = A"
by (auto dest:set2list_prop simp:set2list_def)

subsection \<open>\<open>distinct_fst\<close>\<close>

definition distinct_fst :: "('a \<times> 'b) list \<Rightarrow> bool" where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"

apply (unfold distinct_fst_def)
apply (simp (no_asm))
done

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"

apply (unfold distinct_fst_def)
apply (auto simp:image_def)
done

lemma map_of_SomeI:
  "\<lbrakk> distinct_fst kxs; (k,x) \<in> set kxs \<rbrakk> \<Longrightarrow> map_of kxs k = Some x"
by (induct kxs) (auto simp:fun_upd_apply)

subsection \<open>Using @{term list_all2} for relations\<close>

definition fun_of :: "('a \<times> 'b) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" where
  "fun_of S \<equiv> \<lambda>x y. (x,y) \<in> S"

text \<open>Convenience lemmas\<close>

declare fun_of_def [simp]

lemma rel_list_all2_Cons [iff]:
  "list_all2 (fun_of S) (x#xs) (y#ys) =
   ((x,y) \<in> S \<and> list_all2 (fun_of S) xs ys)"
  by simp

lemma rel_list_all2_Cons1:
  "list_all2 (fun_of S) (x#xs) ys =
  (\<exists>z zs. ys = z#zs \<and> (x,z) \<in> S \<and> list_all2 (fun_of S) xs zs)"
  by (cases ys) auto

lemma rel_list_all2_Cons2:
  "list_all2 (fun_of S) xs (y#ys) =
  (\<exists>z zs. xs = z#zs \<and> (z,y) \<in> S \<and> list_all2 (fun_of S) zs ys)"
  by (cases xs) auto

lemma rel_list_all2_refl:
  "(\<And>x. (x,x) \<in> S) \<Longrightarrow> list_all2 (fun_of S) xs xs"
  by (simp add: list_all2_refl)

lemma rel_list_all2_antisym:
  "\<lbrakk> (\<And>x y. \<lbrakk>(x,y) \<in> S; (y,x) \<in> T\<rbrakk> \<Longrightarrow> x = y);
     list_all2 (fun_of S) xs ys; list_all2 (fun_of T) ys xs \<rbrakk> \<Longrightarrow> xs = ys"
  by (rule list_all2_antisym) auto

lemma rel_list_all2_trans:
  "\<lbrakk> \<And>a b c. \<lbrakk>(a,b) \<in> R; (b,c) \<in> S\<rbrakk> \<Longrightarrow> (a,c) \<in> T;
    list_all2 (fun_of R) as bs; list_all2 (fun_of S) bs cs\<rbrakk>
  \<Longrightarrow> list_all2 (fun_of T) as cs"
  by (rule list_all2_trans) auto

lemma rel_list_all2_update_cong:
  "\<lbrakk> i<size xs; list_all2 (fun_of S) xs ys; (x,y) \<in> S \<rbrakk>
  \<Longrightarrow> list_all2 (fun_of S) (xs[i:=x]) (ys[i:=y])"
  by (simp add: list_all2_update_cong)

lemma rel_list_all2_nthD:
  "\<lbrakk> list_all2 (fun_of S) xs ys; p < size xs \<rbrakk> \<Longrightarrow> (xs!p,ys!p) \<in> S"
  by (drule list_all2_nthD) auto

lemma rel_list_all2I:
  "\<lbrakk> length a = length b; \<And>n. n < length a \<Longrightarrow> (a!n,b!n) \<in> S \<rbrakk> \<Longrightarrow> list_all2 (fun_of S) a b"
  by (erule list_all2_all_nthI) simp

declare fun_of_def [simp del]

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*<*)
theory Chapter3_HoareHeap
imports "../../AutoCorres"
begin
(*>*)

subsection {* \texttt{swap} *}

text {*

  Here, we use AutoCorres to verify a C program that reads and writes to the heap.
  Our C function, \texttt{swap}, swaps two words in memory:

\lstinputlisting[language=C, firstline=15]{../../swap.c}

  Again, we translate the program using the C parser and AutoCorres.
*}

install_C_file "swap.c"
autocorres [heap_abs_syntax, ts_rules = nondet] "swap.c"
(*<*)
context swap begin
(*>*)

text {*
  Most heap operations in C programs consist of accessing a pointer.
  AutoCorres abstracts the global C heap by creating one heap for
  each type. (In our simple \texttt{swap} example, it creates only
  a @{typ word32} heap.) This makes verification easier as long as
  the program does not access the same memory as two different types.

  There are other operations that are relevant to program verification,
  such as changing the type that occupies a given region of memory.
  AutoCorres will not abstract any functions that use these operations,
  so verifying them will be more complicated (but still possible).
*}

text {*
  The C parser expresses \texttt{swap} like this:
*}

thm swap_body_def
text {* @{thm [display] swap_body_def} *}

text {*
  AutoCorres abstracts the function to this:
*}

thm swap'_def
text {* @{thm [display] swap'_def } *}

text {*
  There are some things to note:

  The function contains guards (assertions) that the pointers
  \texttt{a} and \texttt{b} are valid. We need to prove that
  these guards never fail when verifying \texttt{swap}.
  Conversely, when verifying any function that calls
  \texttt{swap}, we need to show that the arguments are
  valid pointers.

  We saw a monadic program in the previous section, but here
  the monad is actually being used to carry the program heap.
*}

(* FIXME: something about heap syntax here. *)

text {*
  Now we prove that \texttt{swap} is correct. We use @{term x}
  and @{term y} to ``remember'' the initial values so that we can
  talk about them in the postcondition.
*}
lemma "\<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply clarsimp
  txt {*
    The C parser and AutoCorres both model the C heap using functions,
    which takes a pointer to some object in memory. Heap updates are
    modelled using the functional update @{term fun_upd}:

      @{thm [display] fun_upd_def}

    To reason about functional updates, we use the rule fun\_upd\_apply.
  *}
  apply (simp add: fun_upd_apply)
  done

text {*
  Note that we have ``only'' proved that the function swaps its
  arguments. We have not proved that it does \emph{not} change
  any other state. This is a typical \emph{frame problem} with
  pointer reasoning. We can prove a more complete specification
  of \texttt{swap}:
*}
lemma "(\<And>x y s. P (s[a := x][b := y]) = P s) \<Longrightarrow>
       \<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<and> P s \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<and> P s \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

text {*
  In other words, if predicate @{term P} does not depend on the
  inputs to \texttt{swap}, it will continue to hold.

  \emph{Separation logic} provides a more structured approach
  to this problem.
*}

(*<*)
end
end
(*>*)


(*  Title:       Noninterference Security in Communicating Sequential Processes
    Author:      Pasquale Noce
                 Security Certification Specialist at Arjowiggins Security - Gep S.p.A.
                 pasquale dot noce at arjowiggins-it dot com
                 pasquale dot noce dot lavoro at gmail dot com
*)

header "CSP noninterference vs. generalized noninterference"

theory GeneralizedNoninterference
imports ClassicalNoninterference
begin

text {*
\null

The purpose of this section is to compare CSP noninterference security as defined previously with
McCullough's notion of generalized noninterference security as formulated in \cite{R4}. It will be
shown that this security property is weaker than both CSP noninterference security for a generic
process, and classical noninterference security for classical processes, viz. it is a necessary but
not sufficient condition for them. This renders CSP noninterference security preferable as an
extension of classical noninterference security to nondeterministic systems.

For clarity, all the constants and fact names defined in this section, with the possible exception
of datatype constructors and main theorems, contain prefix @{text g_}.
*}

subsection "Generalized noninterference"

text {*
The original formulation of generalized noninterference security as contained in \cite{R4} focuses
on systems whose events, split in inputs and outputs, are mapped into either of two security levels,
\emph{high} and \emph{low}. Such a system is said to be secure just in case, for any trace
@{text xs} and any high-level input @{text x}, the set of the \emph{possible low-level futures} of
@{text xs}, i.e. of the sequences of low-level events that may succeed @{text xs} in the traces of
the system, is equal to the set of the possible low-level futures of @{text "xs @ [x]"}.

This definition requires the following corrections:

\begin{itemize}

\item
Variable @{text x} must range over all high-level events rather than over high-level inputs alone,
since high-level outputs must not be allowed to affect low-level futures as well.

\item
For any @{text x}, the range of trace @{text xs} must be restricted to the traces of the system that
may be succeeded by @{text x}, viz. trace @{text xs} must be such that event list @{text "xs @ [x]"}
be itself a trace.
\\Otherwise, a system that admits both high-level and low-level events in its alphabet but never
accepts any high-level event, always accepting any low-level one instead, would turn out not to be
secure, which is paradoxical since \emph{high} can by no means affect \emph{low} in a system never
engaging in high-level events. The cause of the paradox is that, for each trace @{text xs} and each
high-level event @{text x} of such a system, the set of the possible low-level futures of @{text xs}
matches the Kleene closure of the set of low-level events, whereas the set of the possible low-level
futures of @{text "xs @ [x]"} matches the empty set as @{text "xs @ [x]"} is not a trace.

\end{itemize}

Observe that the latter correction renders it unnecessary to explicitly assume that event list
@{text xs} be a trace of the system, as this follows from the assumption that @{text "xs @ [x]"} be
such.

Here below is a formal definition of the notion of generalized noninterference security for
processes, amended in accordance with the previous considerations.

\null
*}

datatype g_level = High | Low

definition g_secure :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} =
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

text {*
\null

It is possible to prove that a weaker sufficient (as well as necessary, as obvious) condition for
generalized noninterference security is that the set of the possible low-level futures of trace
@{text xs} be included in the set of the possible low-level futures of trace @{text "xs @ [x]"},
because the latter is always included in the former.

In what follows, such security property is defined formally and its sufficiency for generalized
noninterference security to hold is demonstrated in the form of an introduction rule, which will
turn out to be useful in subsequent proofs.

\null
*}

definition g_secure_suff :: "'a process \<Rightarrow> ('a \<Rightarrow> g_level) \<Rightarrow> bool" where
"g_secure_suff P L \<equiv> \<forall>xs x. xs @ [x] \<in> traces P \<and> L x = High \<longrightarrow>
  {ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]} \<subseteq>
  {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]}"

lemma g_secure_suff_implies_g_secure:
  assumes S: "g_secure_suff P L"
  shows "g_secure P L"
proof (simp add: g_secure_def, (rule allI)+, rule impI, erule conjE)
  fix xs x
  assume
    A: "xs @ [x] \<in> traces P" and
    B: "L x = High"
  show "{ys'. \<exists>ys. xs @ ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]} =
    {ys'. \<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys . L y = Low]}"
   (is "{ys'. \<exists>ys. ?Q ys ys'} = {ys'. \<exists>ys. ?Q' ys ys'}")
  proof (rule equalityI, rule_tac [2] subsetI, simp_all, erule_tac [2] exE,
   erule_tac [2] conjE)
    show "{ys'. \<exists>ys. ?Q ys ys'} \<subseteq> {ys'. \<exists>ys. ?Q' ys ys'}"
     using S and A and B by (simp add: g_secure_suff_def)
  next
    fix ys ys'
    assume "xs @ x # ys \<in> traces P"
    moreover assume "ys' = [y\<leftarrow>ys. L y = Low]"
    hence "ys' = [y\<leftarrow>x # ys. L y = Low]" using B by simp
    ultimately have "?Q (x # ys) ys'" ..
    thus "\<exists>ys. ?Q ys ys'" ..
  qed
qed

subsection "Comparison between security properties"

text {*
In the continuation, it will be proven that CSP noninterference security is a sufficient condition
for generalized noninterference security for any process whose events are mapped into either
security domain @{text High} or @{text Low}, under the policy that @{text High} may not affect
@{text Low}.

Particularly, this is the case for any such classical process. This fact, along with the equivalence
between CSP noninterference security and classical noninterference security for classical processes,
is used to additionally prove that the classical noninterference security of a deterministic state
machine is a sufficient condition for the generalized noninterference security of the corresponding
classical process under the aforesaid policy.

\null
*}

definition g_I :: "(g_level \<times> g_level) set" where
"g_I \<equiv> {(High, High), (Low, Low), (Low, High)}"

lemma g_I_refl: "refl g_I"
proof (simp add: refl_on_def, rule allI)
  fix x
  show "(x, x) \<in> g_I" by (cases x, simp_all add: g_I_def)
qed

lemma g_sinks: "sinks g_I L High xs \<subseteq> {High}"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "sinks g_I L High xs \<subseteq> {High}"
  show "sinks g_I L High (xs @ [x]) \<subseteq> {High}"
  proof (cases "L x")
    assume "L x = High"
    thus ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "\<not> ((High, L x) \<in> g_I \<or> (\<exists>v \<in> sinks g_I L High xs. (v, L x) \<in> g_I))"
    proof (rule notI, simp add: B, erule disjE)
      assume "(High, Low) \<in> g_I"
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    next
      assume "\<exists>v \<in> sinks g_I L High xs. (v, Low) \<in> g_I"
      then obtain v where C: "v \<in> sinks g_I L High xs" and D: "(v, Low) \<in> g_I" ..
      have "v \<in> {High}" using A and C ..
      hence "(High, Low) \<in> g_I" using D by simp
      moreover have "(High, Low) \<notin> g_I" by (simp add: g_I_def)
      ultimately show False by contradiction
    qed
    thus ?thesis using A by simp
  qed
qed

lemma g_ipurge_tr: "ipurge_tr g_I L High xs = [x\<leftarrow>xs. L x = Low]"
proof (induction xs rule: rev_induct, simp)
  fix x xs
  assume A: "ipurge_tr g_I L High xs = [x'\<leftarrow>xs. L x' = Low]"
  show "ipurge_tr g_I L High (xs @ [x]) = [x'\<leftarrow>xs @ [x]. L x' = Low]"
  proof (cases "L x")
    assume B: "L x = High"
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs"
     by (simp add: g_I_def)
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low]"
     using B by simp
    ultimately show ?thesis using A by simp
  next
    assume B: "L x = Low"
    have "L x \<notin> sinks g_I L High (xs @ [x])"
    proof (rule notI, simp only: B)
      have "sinks g_I L High (xs @ [x]) \<subseteq> {High}" by (rule g_sinks)
      moreover assume "Low \<in> sinks g_I L High (xs @ [x])"
      ultimately have "Low \<in> {High}" ..
      thus False by simp
    qed
    hence "ipurge_tr g_I L High (xs @ [x]) = ipurge_tr g_I L High xs @ [x]"
     by simp
    moreover have "[x'\<leftarrow>xs @ [x]. L x' = Low] = [x'\<leftarrow>xs. L x' = Low] @ [x]"
     using B by simp
    ultimately show ?thesis using A by simp
  qed
qed

theorem secure_implies_g_secure:
  assumes S: "secure P g_I L"
  shows "g_secure P L"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xs x ys ys'
  assume "xs @ [x] \<in> traces P"
  hence "\<exists>X. ([x], X) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain X where "([x], X) \<in> futures P xs" ..
  moreover assume "xs @ ys \<in> traces P"
  hence "\<exists>Y. (ys, Y) \<in> futures P xs"
   by (simp add: traces_def Domain_iff futures_def)
  then obtain Y where "(ys, Y) \<in> futures P xs" ..
  ultimately have "(x # ipurge_tr g_I L (L x) ys,
    ipurge_ref g_I L (L x) ys Y) \<in> futures P xs"
   (is "(_, ?Y') \<in> futures P xs") using S by (simp add: secure_def)
  moreover assume "L x = High" and A: "ys' = [y\<leftarrow>ys. L y = Low]"
  ultimately have "(x # ys', ?Y') \<in> futures P xs" by (simp add: g_ipurge_tr)
  hence "\<exists>Y'. (x # ys', Y') \<in> futures P xs" ..
  hence "xs @ x # ys' \<in> traces P"
   by (simp add: traces_def Domain_iff futures_def)
  moreover have "ys' = [y\<leftarrow>ys'. L y = Low]" using A by simp
  ultimately have "xs @ x # ys' \<in> traces P \<and> ys' = [y\<leftarrow>ys'. L y = Low]" ..
  thus "\<exists>ys. xs @ x # ys \<in> traces P \<and> ys' = [y\<leftarrow>ys. L y = Low]" ..
qed

theorem c_secure_implies_g_secure:
 "c_secure step out s\<^sub>0 g_I L \<Longrightarrow> g_secure (c_process step out s\<^sub>0) (c_dom L)"
by (rule secure_implies_g_secure, rule c_secure_implies_secure, rule g_I_refl)

text {*
\null

Since the definition of generalized noninterference security does not impose any explicit
requirement on process refusals, intuition suggests that this security property is likely to be
generally weaker than CSP noninterference security for nondeterministic processes, which are such
that even a complete specification of their traces leaves underdetermined their refusals. This is
not the case for deterministic processes, so the aforesaid security properties might in principle
be equivalent as regards such processes.

However, a counterexample proving the contrary is provided by a deterministic state machine
resembling systems \emph{A} and \emph{B} described in \cite{R4}, section 3.1. This machine is proven
not to be classical noninterference-secure, whereas the corresponding classical process turns out to
be generalized noninterference-secure, which proves that the generalized noninterference security of
a classical process is not a sufficient condition for the classical noninterference security of the
associated deterministic state machine.

This result, along with the equivalence between CSP noninterference security and classical
noninterference security for classical processes, is then used to demonstrate that the generalized
noninterference security of the aforesaid classical process does not entail its CSP noninterference
security, which proves that generalized noninterference security is actually not a sufficient
condition for CSP noninterference security even in the case of deterministic processes.

The remainder of this section is dedicated to the construction of such counterexample.

\null
*}

datatype g_state = Even | Odd

datatype g_action = Any | Count

primrec g_step :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state" where
"g_step s Any = (case s of Even \<Rightarrow> Odd | Odd \<Rightarrow> Even)" |
"g_step s Count = s"

primrec g_out :: "g_state \<Rightarrow> g_action \<Rightarrow> g_state option" where
"g_out _ Any = None" |
"g_out s Count = Some s"

primrec g_D :: "g_action \<Rightarrow> g_level" where
"g_D Any = High" |
"g_D Count = Low"

definition g_s\<^sub>0 :: g_state where
"g_s\<^sub>0 \<equiv> Even"

lemma g_secure_counterexample:
 "g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D)"
proof (rule g_secure_suff_implies_g_secure, simp add: g_secure_suff_def, (rule allI)+,
 rule impI, rule subsetI, simp, erule exE, (erule conjE)+)
  fix xps x p yps yps'
  assume "xps @ [(x, p)] \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>X. (xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain X where "(xps @ [(x, p)], X) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst (xps @ [(x, p)]))"
   by (rule c_failures_tr)
  moreover assume "c_dom g_D (x, p) = High"
  hence "x = Any" by (cases x, simp_all add: c_dom_def)
  ultimately have "xps @ [(x, p)] = c_tr g_step g_out g_s\<^sub>0 (map fst xps @ [Any])"
   (is "_ = _ (?xs @ _)") by simp
  moreover assume "xps @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
  hence "\<exists>Y. (xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_traces)
  then obtain Y where "(xps @ yps, Y) \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "(yps, Y) \<in> futures (c_process g_step g_out g_s\<^sub>0) xps"
   by (simp add: c_futures_failures)
  hence "yps = c_tr g_step g_out (foldl g_step g_s\<^sub>0 ?xs) (map fst yps)"
   (is "_ = c_tr _ _ _ ?ys") by (rule c_futures_tr)
  hence "yps =
    c_tr g_step g_out (foldl g_step (foldl g_step g_s\<^sub>0 (?xs @ [Any])) [Any]) ?ys"
   (is "_ = c_tr _ _ (foldl _ ?s _) _") by (cases "foldl g_step g_s\<^sub>0 ?xs", simp_all)
  hence "c_tr g_step g_out ?s [Any] @ yps = c_tr g_step g_out ?s ([Any] @ ?ys)"
   (is "?yp @ _ = _") by (simp only: c_tr_append)
  moreover have "(c_tr g_step g_out ?s ([Any] @ ?ys),
    {(x, p). p \<noteq> g_out (foldl g_step ?s ([Any] @ ?ys)) x})
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (c_tr g_step g_out g_s\<^sub>0 (?xs @ [Any]))"
   (is "(_, ?Y') \<in> _") by (rule c_tr_futures)
  ultimately have "(?yp @ yps, ?Y')
    \<in> futures (c_process g_step g_out g_s\<^sub>0) (xps @ [(x, p)])"
   by simp
  hence "(xps @ (x, p) # ?yp @ yps, ?Y') \<in> c_failures g_step g_out g_s\<^sub>0"
   by (simp add: c_futures_failures)
  hence "\<exists>Y'. (xps @ (x, p) # ?yp @ yps, Y') \<in> c_failures g_step g_out g_s\<^sub>0" ..
  hence "xps @ (x, p) # ?yp @ yps \<in> traces (c_process g_step g_out g_s\<^sub>0)"
   (is "?P (?yp @ yps)") by (simp add: c_traces)
  moreover assume "yps' = [yp\<leftarrow>yps. c_dom g_D yp = Low]"
  hence "yps' = [yp\<leftarrow>?yp @ yps. c_dom g_D yp = Low]"
   (is "?Q (?yp @ yps)") by (simp add: c_tr_singleton c_dom_def)
  ultimately have "?P (?yp @ yps) \<and> ?Q (?yp @ yps)" ..
  thus "\<exists>yps. ?P yps \<and> ?Q yps" ..
qed

lemma not_c_secure_counterexample:
 "\<not> c_secure g_step g_out g_s\<^sub>0 g_I g_D"
proof (simp add: c_secure_def)
  have "g_out (foldl g_step g_s\<^sub>0 [Any]) Count = Some Odd"
   (is "?f Count [Any] = _") by (simp add: g_s\<^sub>0_def)
  moreover have
    "g_out (foldl g_step g_s\<^sub>0 (c_ipurge g_I g_D (g_D Count) [Any])) Count =
    Some Even"
   (is "?g Count [Any] = _") by (simp add: g_I_def g_s\<^sub>0_def)
  ultimately have "?f Count [Any] \<noteq> ?g Count [Any]" by simp
  thus "\<exists>x xs. ?f x xs \<noteq> ?g x xs" by blast
qed

theorem not_g_secure_implies_c_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  c_secure g_step g_out g_s\<^sub>0 g_I g_D)"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule not_c_secure_counterexample)

theorem not_g_secure_implies_secure:
 "\<not> (g_secure (c_process g_step g_out g_s\<^sub>0) (c_dom g_D) \<longrightarrow>
  secure (c_process g_step g_out g_s\<^sub>0) g_I (c_dom g_D))"
proof (simp, rule conjI, rule g_secure_counterexample)
qed (rule notI, drule secure_implies_c_secure, erule contrapos_pp,
 rule not_c_secure_counterexample)

end


theory operators_deriv
  imports operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

subsection \<open>Derivative and Coherence\<close>

(**In this section we investigate two related operators, namely the `derivative' (or `derived set')
and the (Cantorian) `coherence' of a set. The derivative of a set is the set of its accumulation (aka. limit)
points. The coherence of a set X is the set formed by those limit points of X belonging to X.
For the derivative operator we draw upon the works by Kuratowski @{cite Kuratowski-1} and
(in more detail) by Zarycki @{cite Zarycki-3}; cf.~also McKinsey \& Tarski @{cite AOT}.
For the (Cantorian) coherence operator we follow the treatment given by Zarycki in @{cite Zarycki-2}.*)

subsubsection \<open>Derivative conditions\<close>

(**The derivative conditions overlap partly with Kuratowski closure conditions @{cite Kuratowski-1}.
We try to make both notations coincide when possible.*)

abbreviation "Der_1 \<phi>  \<equiv> Cl_1 \<phi>"
abbreviation "Der_1a \<phi> \<equiv> Cl_1a \<phi>"
abbreviation "Der_1b \<phi> \<equiv> Cl_1b \<phi>"
abbreviation "Der_2 \<phi>  \<equiv> Cl_5 \<phi>" (**follows from Cl-2*)
abbreviation "Der_3 \<phi>  \<equiv> Cl_3 \<phi>"
abbreviation "Der_4 \<phi>  \<equiv> Cl_4' \<phi>"
definition   "Der_4e \<phi> \<equiv> \<forall>A. \<phi>(\<phi> A) \<^bold>\<preceq> (\<phi> A \<^bold>\<or> A)"
definition   "Der_5 \<phi> \<equiv> \<forall>A. (\<phi> A \<^bold>\<preceq> A) \<and> (A \<^bold>\<preceq> \<phi>\<^sup>d A) \<longrightarrow> (A \<^bold>\<approx> \<^bold>\<bottom> \<or> A \<^bold>\<approx> \<^bold>\<top>)"

(**Some remarks:
Condition Der-2 basically says (when assuming other derivative axioms) that the space is dense-in-itself,
i.e. that all points are accumulation points (no point is isolated) w.r.t the whole space.
Der-4 is a weakened (left-to-right) variant of Cl-4.
Condition Der-4e corresponds to a (weaker) condition than Der-4 and is used in more recent literature
(in particular in the works of Leo Esakia @{cite Esakia}).
When other derivative axioms are assumed, Der-5 above as used by Zarycki @{cite Zarycki-3} says that
the only clopen sets in the space are the top and bottom elements (empty set and universe, resp.).
We verify some properties:*)

lemma Der4e_rel: "Der_4 \<phi> \<Longrightarrow> Der_4e \<phi>" by (simp add: IDEMb_def Der_4e_def conn)
lemma PD1: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B" using MONO_def MONO_ADDIb by auto
lemma PD2: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d B" using CI1b MONO_def MONO_MULTa dual_def by fastforce
lemma PD3: "Der_1b \<phi> \<Longrightarrow> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> \<phi> A \<^bold>\<and> \<phi> B" unfolding conn by (metis (no_types, lifting) PD1)
lemma PD4: "Der_1 \<phi> \<Longrightarrow> \<forall>A B. (\<phi> A \<^bold>\<leftharpoonup> \<phi> B) \<^bold>\<preceq> \<phi>(A \<^bold>\<leftharpoonup> B)" using Cl_6_def PC6 by metis
lemma PD5: "Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>(\<^bold>\<midarrow>(\<phi> A))) \<^bold>\<preceq> \<phi>(\<^bold>\<midarrow>(\<phi> A))" unfolding IDEMb_def by blast
(**Observe that the lemmas below require Der-2 as premise:*)
lemma PD6: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi> A" unfolding ADDI_def dNOR_def dual_def conn by fastforce
lemma PD7: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi>(\<phi> A)" by (metis (mono_tags, lifting) PC1 PD1 PD6)
lemma PD8: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<preceq> \<phi> A" by (meson IDEMb_def PD7)
lemma PD9: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>\<^sup>d(\<phi> A)" by (metis CI4' IDEMa_def PC1 PD2 PD6)
lemma PD10: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<phi>\<^sup>d A \<^bold>\<preceq> \<phi>(\<phi>\<^sup>d A)" using CI4' IDEMa_def PD6 by metis
lemma PD11: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. \<^bold>\<midarrow>(\<phi> A) \<^bold>\<preceq> \<phi>(\<^bold>\<midarrow>(\<phi> A))" using IDEMb_def PD6 dual_def unfolding conn by metis
lemma PD12: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi> \<Longrightarrow> \<forall>A. (\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" proof -
 assume der1: "Der_1 \<phi>" and der2: "Der_2 \<phi>" and der4: "Der_4 \<phi>"
  { fix A
    from der1 have "let M=\<^bold>\<midarrow>A ; N=\<^bold>\<midarrow>(\<phi> A) in \<phi>(M \<^bold>\<or> N) \<^bold>\<approx> (\<phi> M) \<^bold>\<or> (\<phi> N)" unfolding ADDI_def by simp
    hence aux: "\<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A))) \<^bold>\<approx> \<^bold>\<midarrow>(\<phi> (\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def conn by simp
    have "(\<phi>\<^sup>d A \<^bold>\<and> \<phi> A) = (\<phi>\<^sup>d A \<^bold>\<and> \<phi>\<^sup>d(\<phi> A))" using PD6 PD9 der1 der2 der4 unfolding conn by metis
    also have "... = \<^bold>\<midarrow>(\<phi>(\<^bold>\<midarrow>A) \<^bold>\<or> \<phi>(\<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def conn by simp
    also from aux have "... = \<^bold>\<midarrow>(\<phi> (\<^bold>\<midarrow>A \<^bold>\<or> \<^bold>\<midarrow>(\<phi> A)))" unfolding dual_def by blast
    also have "... = \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" unfolding dual_def conn by simp
    finally have "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> (\<phi> A))" by simp
 } thus ?thesis by simp
qed

(**The conditions below can serve to axiomatize a derivative operator. Different authors consider different
sets of conditions. We define below some corresponding to Zarycki @{cite Zarycki-3}, Kuratowski @{cite Kuratowski-1}
@{cite Zarycki-2}, McKinsey \& Tarski @{cite AOT}, and Esakia @{cite Esakia}, respectively.*)
abbreviation "\
z \<phi>  \<equiv> Der_1 \<phi> \<and> Der_2 \<phi> \<and> Der_3 \<phi> \<and> Der_4 \<phi> \<and> Der_5 \<phi>"
abbreviation "\
k \<phi>  \<equiv> Der_1 \<phi> \<and> Der_2 \<phi> \<and> Der_3 \<phi> \<and> Der_4 \<phi>"
abbreviation "\
mt \<phi> \<equiv> Der_1 \<phi>           \<and> Der_3 \<phi> \<and> Der_4 \<phi>"
abbreviation "\
e \<phi>  \<equiv> Der_1 \<phi>           \<and> Der_3 \<phi> \<and> Der_4e \<phi>"

(**Our `default' derivative operator will coincide with @{text "\
k"} from Kuratowski (also Zarycki).
However, for proving theorems we will employ the weaker variant Der-4e instead of Der-4 whenever possible.
We start by defining a dual operator and verifying some dualities; we then define conversion operators.
Observe that conditions Der-2 and  Der-5 are not used in the rest of this subsection.
Der-2 will be required later when working with the coherence operator.*)
abbreviation "\
 \<phi> \<equiv> \
k \<phi>"
abbreviation "\<Sigma> \<phi> \<equiv> Int_1 \<phi> \<and> Int_3 \<phi> \<and> Int_4' \<phi> \<and> Int_5 \<phi>" (**'dual-derivative' operator*)

lemma SD_dual1: "\<Sigma>(\<phi>) \<Longrightarrow> \
(\<phi>\<^sup>d)" using IC1 IC4' IC3 IC5 by simp
lemma SD_dual2: "\<Sigma>(\<phi>\<^sup>d) \<Longrightarrow> \
(\<phi>)" using IC1 IC4' IC3 IC5 dual_symm by metis
lemma DS_dual1: "\
(\<phi>) \<Longrightarrow> \<Sigma>(\<phi>\<^sup>d)" using CI1 CI4' CI3 CI5 by simp
lemma DS_dual2: "\
(\<phi>\<^sup>d) \<Longrightarrow> \<Sigma>(\<phi>)" using CI1 CI4' CI3 CI5 dual_symm by metis
lemma DS_dual: "\
(\<phi>) = \<Sigma>(\<phi>\<^sup>d)"  using SD_dual2 DS_dual1 by smt

(**Closure operator as derived from derivative.*)
definition Cl_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<C>\<^sub>D") where  "\<C>\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<or> \<D>(A)"
(**Verify properties:*)
lemma CD1a: "Der_1a \<D> \<Longrightarrow> Cl_1a (\<C>\<^sub>D \<D>)" unfolding Cl_der_def ADDI_a_def conn by auto

(**Interior operator as derived from (dual) derivative.*)
definition Int_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\\<^sub>D") where "\\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<and> \<D>\<^sup>d(A)"
(**Verify definition:*)
lemma Int_der_def2: "\\<^sub>D \<D> = (\<lambda>\<phi>. \<phi> \<^bold>\<leftharpoonup> \<D>(\<^bold>\<midarrow>\<phi>))" unfolding Int_der_def dual_def conn by simp
lemma dual_der1: "\<C>\<^sub>D \<D> \<equiv> (\\<^sub>D \<D>)\<^sup>d" unfolding Cl_der_def Int_der_def dual_def conn by simp
lemma dual_der2: "\\<^sub>D \<D> \<equiv> (\<C>\<^sub>D \<D>)\<^sup>d" unfolding Cl_der_def Int_der_def dual_def conn by simp
(**Verify properties:*)
lemma ID1: "Der_1 \<D> \<Longrightarrow> Int_1 (\\<^sub>D \<D>)" using Int_der_def MULT_def ADDI_def CI1 unfolding conn by auto
lemma ID1a: "Der_1a \<D> \<Longrightarrow> Int_1b (\\<^sub>D \<D>)" by (simp add: CI1a dual_der2 CD1a)
lemma ID1b: "Der_1b \<D> \<Longrightarrow> Int_1a (\\<^sub>D \<D>)" by (simp add: CI1b dual_der2 CD1b)
lemma ID2: "Int_2 (\\<^sub>D \<D>)" unfolding Int_der_def dEXP_def conn by simp
lemma ID3: "Der_3 \<D> \<Longrightarrow> Int_3 (\\<^sub>D \<D>)" by (simp add: CI3 CD3 dual_der2)
lemma ID4: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" using CI4 CD4 dual_der2 by simp
lemma ID4a: "Der_1a \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" by (simp add: CI4 dual_der2 CD4a)
lemma "Der_1b \<D> \<Longrightarrow> Der_4 \<D> \<Longrightarrow> Int_4 (\\<^sub>D \<D>)" nitpick oops (*countermodel*)

(**Border operator as derived from (dual) derivative.*)
definition Br_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\\<^sub>D") where "\\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<leftharpoonup> \<D>\<^sup>d(A)"
(**Verify definition:*)
lemma Br_der_def2: "\\<^sub>D \<D> = (\<lambda>A. A \<^bold>\<and> \<D>(\<^bold>\<midarrow>A))" unfolding Br_der_def dual_def conn by simp
(**Verify properties:*)
lemma BD1: "Der_1 \<D> \<Longrightarrow> Br_1 (\\<^sub>D \<D>)" using Br_der_def Br_1_def CI1 MULT_def conn by auto
lemma BD2: "Der_3 \<D> \<Longrightarrow> Br_2 (\\<^sub>D \<D>)" using Br_der_def Br_2_def CI3 dNOR_def unfolding conn by auto
lemma BD3: "Der_1b \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Br_3 (\\<^sub>D \<D>)" using dual_def Der_4e_def MONO_ADDIb MONO_def  unfolding Br_der_def Br_3_def conn by smt

(**Frontier operator as derived from derivative.*)
definition Fr_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<F>\<^sub>D") where "\<F>\<^sub>D \<D> \<equiv> \<lambda>A. (A \<^bold>\<leftharpoonup> \<D>\<^sup>d(A)) \<^bold>\<or> (\<D>(A) \<^bold>\<leftharpoonup> A)"
(**Verify definition:*)
lemma Fr_der_def2: "\<F>\<^sub>D \<D> = (\<lambda>A. (A \<^bold>\<or> \<D>(A)) \<^bold>\<and> (\<^bold>\<midarrow>A \<^bold>\<or> \<D>(\<^bold>\<midarrow>A)))" unfolding Fr_der_def dual_def conn by auto
(**Verify properties:*)
lemma FD1a: "Der_1a \<D> \<Longrightarrow> Fr_1a(\<F>\<^sub>D \<D>)" unfolding Fr_1a_def Fr_der_def using CI1a MULT_b_def conn by auto
lemma FD1b: "Der_1b \<D> \<Longrightarrow> Fr_1b(\<F>\<^sub>D \<D>)" unfolding Fr_1b_def Fr_der_def using CI1b MULT_a_def conn by smt
lemma FD1: "Der_1 \<D> \<Longrightarrow> Fr_1(\<F>\<^sub>D \<D>)" unfolding Fr_1_def Fr_der_def using CI1 MULT_def conn by auto
lemma FD2: "Fr_2(\<F>\<^sub>D \<D>)" using dual_def dual_symm unfolding Fr_2_def Fr_der_def conn by metis
lemma FD3: "Der_3 \<D> \<Longrightarrow> Fr_3(\<F>\<^sub>D \<D>)" by (simp add: NOR_def Fr_der_def conn)
lemma FD4: "Der_1 \<D> \<Longrightarrow> Der_4e \<D> \<Longrightarrow> Fr_4(\<F>\<^sub>D \<D>)" by (metis CD1b CD2 CD4 Cl_8_def Cl_der_def Fr_4_def Fr_der_def2 PC1 PC8 meet_def)

(**Note that the derivative operation cannot be obtained from interior, closure, border, nor frontier.
In this respect the derivative is a fundamental operation.*)

subsubsection \<open>Infinitary conditions\<close>

(**The corresponding infinitary condition on derivative operators is inherited from the one for closure.*)
abbreviation "Der_inf \<phi> \<equiv> Cl_inf(\<phi>)"

lemma CD_inf: "Der_inf \<phi> \<Longrightarrow> Cl_inf(\<C>\<^sub>D \<phi>)" unfolding iADDI_a_def by (smt Cl_der_def Fr_2_def Ra_restr_ex compl_def dom_compl_def2 iDM_b join_def meet_def supremum_def)
lemma ID_inf: "Der_inf \<phi> \<Longrightarrow> Int_inf(\\<^sub>D \<phi>)" by (simp add: CD_inf dual_der2 iADDI_MULT_dual1)

(**This condition is indeed strong enough as to entail closure of some fixed-point predicates under infimum/supremum.*)
lemma fp_ID_inf_closed: "Der_inf \<phi> \<Longrightarrow> infimum_closed (fp (\\<^sub>D \<phi>))" by (metis (full_types) ID2 ID_inf Ra_restr_all dEXP_def iMULT_b_def inf_char)
lemma fp_CD_sup_closed: "Der_inf \<phi> \<Longrightarrow> supremum_closed (fp (\<C>\<^sub>D \<phi>))" by (metis (full_types) CD_inf Cl_der_def Ra_restr_ex iADDI_a_def join_def supremum_def)

subsubsection \<open>Coherence conditions\<close>
(**We finish this section by introducing the `coherence' operator (Cantor's `Koherenz') as discussed
by Zarycki in @{cite Zarycki-2}. As happens with the derivative operator, the coherence operator cannot
be derived from interior, closure, border, nor frontier.*)

definition "Kh_1 \<phi> \<equiv> ADDI_b \<phi>"
definition "Kh_2 \<phi> \<equiv> dEXP \<phi>"
definition "Kh_3 \<phi> \<equiv> \<forall>A. \<phi>(\<phi>\<^sup>d A) \<^bold>\<approx> \<phi>\<^sup>d(\<phi> A)"

lemma PK1: "Kh_1 \<phi> \<equiv> MONO \<phi>" using ADDI_b_def Kh_1_def MONO_ADDIb by auto
lemma PK2: "Kh_1 \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using MULT_a_def MONO_MULTa PK1 by auto
lemma PK3: "Kh_2 \<phi> \<Longrightarrow> \<phi> \<^bold>\<bottom> \<^bold>\<approx> \<^bold>\<bottom>" using Kh_2_def dEXP_def unfolding conn by auto
lemma PK4: "Kh_1 \<phi> \<Longrightarrow>  Kh_3 \<phi> \<Longrightarrow> \<phi> \<^bold>\<top> \<^bold>\<approx> \<^bold>\<top>" using MONO_def PK1 dual_def unfolding Kh_3_def conn by metis
lemma PK5: "Kh_2 \<phi> \<Longrightarrow>  \<forall>A. \<phi>(\<^bold>\<midarrow>A) \<^bold>\<preceq> \<^bold>\<midarrow>(\<phi> A)" unfolding Kh_2_def dEXP_def conn by metis
lemma PK6: "Kh_1 \<phi> \<Longrightarrow> Kh_2 \<phi> \<Longrightarrow>  \<forall>A B. \<phi>(A \<^bold>\<leftharpoonup> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<leftharpoonup> (\<phi> B)" unfolding conn by (metis (no_types, lifting) Kh_2_def dEXP_def MONO_def PK1)

(**Coherence operator as derived from derivative (requires conditions Der-2 and Der-4).*)
definition Kh_der::"(\<sigma>\<Rightarrow>\<sigma>)\<Rightarrow>(\<sigma>\<Rightarrow>\<sigma>)" ("\<K>\<^sub>D") where "\<K>\<^sub>D \<D> \<equiv> \<lambda>A. A \<^bold>\<and> (\<D> A)"
(**Verify properties:*)
lemma KD1: "Der_1 \<phi> \<Longrightarrow> Kh_1 (\<K>\<^sub>D \<phi>)" using PC1 PD3 PK2 ADDI_def Kh_der_def unfolding conn by (metis (full_types))
lemma KD2: "Kh_2 (\<K>\<^sub>D \<phi>)" by (simp add: Kh_2_def dEXP_def Kh_der_def conn)
lemma KD3: "Der_1 \<phi> \<Longrightarrow> Der_2 \<phi> \<Longrightarrow> Der_4 \<phi>  \<Longrightarrow> Kh_3 (\<K>\<^sub>D \<phi>)" proof -
 assume der1: "Der_1 \<phi>" and der2: "Der_2 \<phi>" and der4: "Der_4 \<phi>"
  { fix A
    from der1 have aux1: "let M=A ; N=(\<phi>\<^sup>d A) in \<phi>(M \<^bold>\<or> N) \<^bold>\<approx> (\<phi> M \<^bold>\<or> \<phi> N)" unfolding ADDI_def by simp
    from der1 der2 der4 have aux2: "(\<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A) \<^bold>\<approx> \<phi>\<^sup>d(A \<^bold>\<and> \<phi> A)" using PD12 by simp
    have "(\<K>\<^sub>D \<phi>)((\<K>\<^sub>D \<phi>)\<^sup>d A) = (\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> (\<^bold>\<midarrow>A)) \<^bold>\<and> \<phi> (\<^bold>\<midarrow>(\<^bold>\<midarrow>A \<^bold>\<and> \<phi> (\<^bold>\<midarrow>A))))" unfolding Kh_der_def dual_def by simp
    also have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> \<phi>(A \<^bold>\<or> \<phi>\<^sup>d A)" unfolding dual_def conn by simp
    also from aux1 have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A \<^bold>\<or> \<phi>(\<phi>\<^sup>d A))" unfolding conn by meson
    also have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> \<phi>\<^sup>d A" using PD6 PD8 der1 der2 der4 unfolding conn by blast
    also have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> (\<phi>\<^sup>d A \<^bold>\<and> \<phi> A)" using PD6 der1 der2 unfolding conn by blast
    also have "... = (A \<^bold>\<or> \<phi>\<^sup>d A) \<^bold>\<and> (\<phi> A)" unfolding conn by auto
    also from aux2 have "... = (A \<^bold>\<and> \<phi> A) \<^bold>\<or> \<phi>\<^sup>d(A \<^bold>\<and> \<phi> A)" unfolding dual_def conn by meson
    also have "... = \<^bold>\<midarrow>(\<^bold>\<midarrow>(A \<^bold>\<and> \<phi> A) \<^bold>\<and> \<phi> (\<^bold>\<midarrow>(A \<^bold>\<and> \<phi> A)))" unfolding dual_def conn by simp
    also have "... = (\<K>\<^sub>D \<phi>)\<^sup>d((\<K>\<^sub>D \<phi>) A)" unfolding Kh_der_def dual_def by simp
    finally have "(\<K>\<^sub>D \<phi>)((\<K>\<^sub>D \<phi>)\<^sup>d A) \<^bold>\<approx> (\<K>\<^sub>D \<phi>)\<^sup>d((\<K>\<^sub>D \<phi>) A)" by simp
 } thus ?thesis unfolding Kh_3_def by simp
qed

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/TBA/operators_deriv.thy


section \<open>Examples for WS1S (Singleton Semantics)\<close>

(*<*)
theory WS1S_Alt_Examples
imports Formula_Derivatives.WS1S_Alt_Formula
begin
(*>*)

abbreviation (input) FImp where "FImp \<phi> \<psi> \<equiv> FOr (FNot \<phi>) \<psi>"

definition "Thm idx \<phi> = check_eqv idx \<phi> (FBool True)"

export_code Thm in SML module_name Thm

abbreviation FTrue ("\<top>") where "FTrue \<equiv> FBool True"
abbreviation FFalse ("\<bottom>") where "FFalse \<equiv> FBool False"

notation FImp (infixr "-->" 25)
notation (output) FO ("1")
notation (output) SO ("2")
notation FEx ("\<exists>\<^sub>_ _" [10] 10)
notation FAll ("\<forall>\<^sub>_ _" [10] 10)
notation FNot ("\<not> _" [40] 40)
notation FOr (infixr "\<or>" 30)
notation FAnd (infixr "\<and>" 35)
abbreviation FLess ("x\<^sub>_ < x\<^sub>_" [65, 66] 65) where "FLess m1 m2 \<equiv> FBase (Less m1 m2)"
abbreviation FIn ("x\<^sub>_ \<in> X\<^bsub>_\<^esub>" [65, 66] 65) where "FIn m M \<equiv> FBase (In m M)"
abbreviation FQ ("[x\<^sub>_]" [66] 65) where "FQ m \<equiv> FBase (Fo m)"

declare check_eqv_code[code del]

(*true in M2L, false in WS1S*)
definition "M2L = (FEx SO (FAll FO (FBase (In 0 0))) :: formula)"
(*false in M2L, true in WS1S*)
definition "\<Phi> = (FAll FO (FEx FO (FBase (Less 1 0))) :: formula)"

lemma "Thm (Abs_idx (0, 1)) (FNot M2L)"
  by (simp add: M2L_def Thm_def) check_equiv

lemma "Thm (Abs_idx (0, 0)) \<Phi>"
  by (simp add: Thm_def \<Phi>_def) check_equiv

abbreviation Globally ("\<box>_" [40] 40) where "Globally P == %n. FAll FO (FImp (FNot (FBase (Less (n+1) 0))) (P 0))"
abbreviation Future ("\<diamond>_" [40] 40) where "Future P == %n. FEx FO (FAnd (FNot (FBase (Less (n+1) 0))) (P 0))"
abbreviation IMP (infixr "\<rightarrow>" 50) where "IMP P1 P2 == %n. FImp (P1 n) (P2 n)"

definition \<Psi> :: "nat \<Rightarrow> formula" where
  "\<Psi> n = FAll FO (((\<box>(foldr (\<lambda>i \<phi>. (\<lambda>m. FBase (In m i)) \<rightarrow> \<phi>) [0..<n] (\<lambda>m. FBase (In m n)))) \<rightarrow>
     foldr (\<lambda>i \<phi>. (\<box>(\<lambda>m. FBase (In m i))) \<rightarrow> \<phi>) [0..<n] (\<box>(\<lambda>m. FBase (In m n)))) 0)"

lemma "Thm (Abs_idx (0, 1)) (\<Psi> 0)"
  by (simp add: Thm_def \<Psi>_def) check_equiv

lemma "Thm (Abs_idx (0, 2)) (\<Psi> 1)"
  by (simp add: Thm_def \<Psi>_def) check_equiv

lemma "Thm (Abs_idx (0, 3)) (\<Psi> 2)"
  by (simp add: Thm_def \<Psi>_def numeral_nat) check_equiv

lemma "Thm (Abs_idx (0, 4)) (\<Psi> 3)"
  by (simp add: Thm_def \<Psi>_def numeral_nat) check_equiv

lemma "Thm (Abs_idx (0, 5)) (\<Psi> 4)"
  by (simp add: Thm_def \<Psi>_def numeral_nat) check_equiv

lemma "Thm (Abs_idx (0, 6)) (\<Psi> 5)"
  by (simp add: Thm_def \<Psi>_def numeral_nat) check_equiv

(*<*)
end
(*>*)