theory Examples3
imports Examples
begin

subsection {* Third Version: Local Interpretation
  \label{sec:local-interpretation} *}

text {* In the above example, the fact that @{term "op \<le>"} is a partial
  order for the integers was used in the second goal to
  discharge the premise in the definition of @{text "op \<sqsubset>"}.  In
  general, proofs of the equations not only may involve definitions
  from the interpreted locale but arbitrarily complex arguments in the
  context of the locale.  Therefore it would be convenient to have the
  interpreted locale conclusions temporarily available in the proof.
  This can be achieved by a locale interpretation in the proof body.
  The command for local interpretations is \isakeyword{interpret}.  We
  repeat the example from the previous section to illustrate this. *}

  interpretation %visible int: partial_order "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool"
    where "int.less x y = (x < y)"
  proof -
    show "partial_order (op \<le> :: int \<Rightarrow> int \<Rightarrow> bool)"
      by unfold_locales auto
    then interpret int: partial_order "op \<le> :: [int, int] \<Rightarrow> bool" .
    show "int.less x y = (x < y)"
      unfolding int.less_def by auto
  qed

text {* The inner interpretation is immediate from the preceding fact
  and proved by assumption (Isar short hand ``.'').  It enriches the
  local proof context by the theorems
  also obtained in the interpretation from Section~\ref{sec:po-first},
  and @{text int.less_def} may directly be used to unfold the
  definition.  Theorems from the local interpretation disappear after
  leaving the proof context --- that is, after the succeeding
  \isakeyword{next} or \isakeyword{qed} statement. *}

subsection {* Further Interpretations *}

text {* Further interpretations are necessary for
  the other locales.  In @{text lattice} the operations~@{text \<sqinter>}
  and~@{text \<squnion>} are substituted by @{term "min :: int \<Rightarrow> int \<Rightarrow> int"}
  and @{term "max :: int \<Rightarrow> int \<Rightarrow> int"}.  The entire proof for the
  interpretation is reproduced to give an example of a more
  elaborate interpretation proof.  Note that the equations are named
  so they can be used in a later example.  *}

  interpretation %visible int: lattice "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool"
    where int_min_eq: "int.meet x y = min x y"
      and int_max_eq: "int.join x y = max x y"
  proof -
    show "lattice (op \<le> :: int \<Rightarrow> int \<Rightarrow> bool)"
      txt {* \normalsize We have already shown that this is a partial
        order, *}
      apply unfold_locales
      txt {* \normalsize hence only the lattice axioms remain to be
        shown.
        @{subgoals [display]}
        By @{text is_inf} and @{text is_sup}, *}
      apply (unfold int.is_inf_def int.is_sup_def)
      txt {* \normalsize the goals are transformed to these
        statements:
        @{subgoals [display]}
        This is Presburger arithmetic, which can be solved by the
        method @{text arith}. *}
      by arith+
    txt {* \normalsize In order to show the equations, we put ourselves
      in a situation where the lattice theorems can be used in a
      convenient way. *}
    then interpret int: lattice "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool" .
    show "int.meet x y = min x y"
      by (bestsimp simp: int.meet_def int.is_inf_def)
    show "int.join x y = max x y"
      by (bestsimp simp: int.join_def int.is_sup_def)
  qed

text {* Next follows that @{text "op \<le>"} is a total order, again for
  the integers. *}

  interpretation %visible int: total_order "op \<le> :: int \<Rightarrow> int \<Rightarrow> bool"
    by unfold_locales arith

text {* Theorems that are available in the theory at this point are shown in
  Table~\ref{tab:int-lattice}.  Two points are worth noting:

\begin{table}
\hrule
\vspace{2ex}
\begin{center}
\begin{tabular}{l}
  @{thm [source] int.less_def} from locale @{text partial_order}: \\
  \quad @{thm int.less_def} \\
  @{thm [source] int.meet_left} from locale @{text lattice}: \\
  \quad @{thm int.meet_left} \\
  @{thm [source] int.join_distr} from locale @{text distrib_lattice}: \\
  \quad @{thm int.join_distr} \\
  @{thm [source] int.less_total} from locale @{text total_order}: \\
  \quad @{thm int.less_total}
\end{tabular}
\end{center}
\hrule
\caption{Interpreted theorems for~@{text \<le>} on the integers.}
\label{tab:int-lattice}
\end{table}

\begin{itemize}
\item
  Locale @{text distrib_lattice} was also interpreted.  Since the
  locale hierarchy reflects that total orders are distributive
  lattices, the interpretation of the latter was inserted
  automatically with the interpretation of the former.  In general,
  interpretation traverses the locale hierarchy upwards and interprets
  all encountered locales, regardless whether imported or proved via
  the \isakeyword{sublocale} command.  Existing interpretations are
  skipped avoiding duplicate work.
\item
  The predicate @{term "op <"} appears in theorem @{thm [source]
  int.less_total}
  although an equation for the replacement of @{text "op \<sqsubset>"} was only
  given in the interpretation of @{text partial_order}.  The
  interpretation equations are pushed downwards the hierarchy for
  related interpretations --- that is, for interpretations that share
  the instances of parameters they have in common.
\end{itemize}
  *}

text {* The interpretations for a locale $n$ within the current
  theory may be inspected with \isakeyword{print\_interps}~$n$.  This
  prints the list of instances of $n$, for which interpretations exist.
  For example, \isakeyword{print\_interps} @{term partial_order}
  outputs the following:
\begin{small}
\begin{alltt}
  int! : partial_order "op \(\le\)"
\end{alltt}
\end{small}
  Of course, there is only one interpretation.
  The interpretation qualifier on the left is decorated with an
  exclamation point.  This means that it is mandatory.  Qualifiers
  can either be \emph{mandatory} or \emph{optional}, designated by
  ``!'' or ``?'' respectively.  Mandatory qualifiers must occur in a
  name reference while optional ones need not.  Mandatory qualifiers
  prevent accidental hiding of names, while optional qualifiers can be
  more convenient to use.  For \isakeyword{interpretation}, the
  default is ``!''.
*}

section {* Locale Expressions \label{sec:expressions} *}

text {*
  A map~@{term \<phi>} between partial orders~@{text \<sqsubseteq>} and~@{text \<preceq>}
  is called order preserving if @{text "x \<sqsubseteq> y"} implies @{text "\<phi> x \<preceq>
  \<phi> y"}.  This situation is more complex than those encountered so
  far: it involves two partial orders, and it is desirable to use the
  existing locale for both.

  A locale for order preserving maps requires three parameters: @{text
  le}~(\isakeyword{infixl}~@{text \<sqsubseteq>}) and @{text
  le'}~(\isakeyword{infixl}~@{text \<preceq>}) for the orders and~@{text \<phi>}
  for the map.

  In order to reuse the existing locale for partial orders, which has
  the single parameter~@{text le}, it must be imported twice, once
  mapping its parameter to~@{text le} from the new locale and once
  to~@{text le'}.  This can be achieved with a compound locale
  expression.

  In general, a locale expression is a sequence of \emph{locale instances}
  separated by~``$\textbf{+}$'' and followed by a \isakeyword{for}
  clause.
  An instance has the following format:
\begin{quote}
  \textit{qualifier} \textbf{:} \textit{locale-name}
  \textit{parameter-instantiation}
\end{quote}
  We have already seen locale instances as arguments to
  \isakeyword{interpretation} in Section~\ref{sec:interpretation}.
  As before, the qualifier serves to disambiguate names from
  different instances of the same locale.  While in
  \isakeyword{interpretation} qualifiers default to mandatory, in
  import and in the \isakeyword{sublocale} command, they default to
  optional.

  Since the parameters~@{text le} and~@{text le'} are to be partial
  orders, our locale for order preserving maps will import the these
  instances:
\begin{small}
\begin{alltt}
  le: partial_order le
  le': partial_order le'
\end{alltt}
\end{small}
  For matter of convenience we choose to name parameter names and
  qualifiers alike.  This is an arbitrary decision.  Technically, qualifiers
  and parameters are unrelated.

  Having determined the instances, let us turn to the \isakeyword{for}
  clause.  It serves to declare locale parameters in the same way as
  the context element \isakeyword{fixes} does.  Context elements can
  only occur after the import section, and therefore the parameters
  referred to in the instances must be declared in the \isakeyword{for}
  clause.  The \isakeyword{for} clause is also where the syntax of these
  parameters is declared.

  Two context elements for the map parameter~@{text \<phi>} and the
  assumptions that it is order preserving complete the locale
  declaration. *}

  locale order_preserving =
    le: partial_order le + le': partial_order le'
      for le (infixl "\<sqsubseteq>" 50) and le' (infixl "\<preceq>" 50) +
    fixes \<phi>
    assumes hom_le: "x \<sqsubseteq> y \<Longrightarrow> \<phi> x \<preceq> \<phi> y"

text (in order_preserving) {* Here are examples of theorems that are
  available in the locale:

  \hspace*{1em}@{thm [source] hom_le}: @{thm hom_le}

  \hspace*{1em}@{thm [source] le.less_le_trans}: @{thm le.less_le_trans}

  \hspace*{1em}@{thm [source] le'.less_le_trans}:
  @{thm [display, indent=4] le'.less_le_trans}
  While there is infix syntax for the strict operation associated to
  @{term "op \<sqsubseteq>"}, there is none for the strict version of @{term
  "op \<preceq>"}.  The abbreviation @{text less} with its infix syntax is only
  available for the original instance it was declared for.  We may
  introduce the abbreviation @{text less'} with infix syntax~@{text \<prec>}
  with the following declaration: *}

  abbreviation (in order_preserving)
    less' (infixl "\<prec>" 50) where "less' \<equiv> partial_order.less le'"

text (in order_preserving) {* Now the theorem is displayed nicely as
  @{thm [source]  le'.less_le_trans}:
  @{thm [display, indent=2] le'.less_le_trans} *}

text {* There are short notations for locale expressions.  These are
  discussed in the following. *}

subsection {* Default Instantiations *}

text {*
  It is possible to omit parameter instantiations.  The
  instantiation then defaults to the name of
  the parameter itself.  For example, the locale expression @{text
  partial_order} is short for @{text "partial_order le"}, since the
  locale's single parameter is~@{text le}.  We took advantage of this
  in the \isakeyword{sublocale} declarations of
  Section~\ref{sec:changing-the-hierarchy}. *}

subsection {* Implicit Parameters \label{sec:implicit-parameters} *}

text {* In a locale expression that occurs within a locale
  declaration, omitted parameters additionally extend the (possibly
  empty) \isakeyword{for} clause.

  The \isakeyword{for} clause is a general construct of Isabelle/Isar
  to mark names occurring in the preceding declaration as ``arbitrary
  but fixed''.  This is necessary for example, if the name is already
  bound in a surrounding context.  In a locale expression, names
  occurring in parameter instantiations should be bound by a
  \isakeyword{for} clause whenever these names are not introduced
  elsewhere in the context --- for example, on the left hand side of a
  \isakeyword{sublocale} declaration.

  There is an exception to this rule in locale declarations, where the
  \isakeyword{for} clause serves to declare locale parameters.  Here,
  locale parameters for which no parameter instantiation is given are
  implicitly added, with their mixfix syntax, at the beginning of the
  \isakeyword{for} clause.  For example, in a locale declaration, the
  expression @{text partial_order} is short for
\begin{small}
\begin{alltt}
  partial_order le \isakeyword{for} le (\isakeyword{infixl} "\(\sqsubseteq\)" 50)\textrm{.}
\end{alltt}
\end{small}
  This short hand was used in the locale declarations throughout
  Section~\ref{sec:import}.
 *}

text{*
  The following locale declarations provide more examples.  A
  map~@{text \<phi>} is a lattice homomorphism if it preserves meet and
  join. *}

  locale lattice_hom =
    le: lattice + le': lattice le' for le' (infixl "\<preceq>" 50) +
    fixes \<phi>
    assumes hom_meet: "\<phi> (x \<sqinter> y) = le'.meet (\<phi> x) (\<phi> y)"
      and hom_join: "\<phi> (x \<squnion> y) = le'.join (\<phi> x) (\<phi> y)"

text {* The parameter instantiation in the first instance of @{term
  lattice} is omitted.  This causes the parameter~@{text le} to be
  added to the \isakeyword{for} clause, and the locale has
  parameters~@{text le},~@{text le'} and, of course,~@{text \<phi>}.

  Before turning to the second example, we complete the locale by
  providing infix syntax for the meet and join operations of the
  second lattice.
*}

  context lattice_hom
  begin
  abbreviation meet' (infixl "\<sqinter>''" 50) where "meet' \<equiv> le'.meet"
  abbreviation join' (infixl "\<squnion>''" 50) where "join' \<equiv> le'.join"
  end

text {* The next example makes radical use of the short hand
  facilities.  A homomorphism is an endomorphism if both orders
  coincide. *}

  locale lattice_end = lattice_hom _ le

text {* The notation~@{text _} enables to omit a parameter in a
  positional instantiation.  The omitted parameter,~@{text le} becomes
  the parameter of the declared locale and is, in the following
  position, used to instantiate the second parameter of @{text
  lattice_hom}.  The effect is that of identifying the first in second
  parameter of the homomorphism locale. *}

text {* The inheritance diagram of the situation we have now is shown
  in Figure~\ref{fig:hom}, where the dashed line depicts an
  interpretation which is introduced below.  Parameter instantiations
  are indicated by $\sqsubseteq \mapsto \preceq$ etc.  By looking at
  the inheritance diagram it would seem
  that two identical copies of each of the locales @{text
  partial_order} and @{text lattice} are imported by @{text
  lattice_end}.  This is not the case!  Inheritance paths with
  identical morphisms are automatically detected and
  the conclusions of the respective locales appear only once.

\begin{figure}
\hrule \vspace{2ex}
\begin{center}
\begin{tikzpicture}
  \node (o) at (0,0) {@{text partial_order}};
  \node (oh) at (1.5,-2) {@{text order_preserving}};
  \node (oh1) at (1.5,-0.7) {$\scriptscriptstyle \sqsubseteq \mapsto \sqsubseteq$};
  \node (oh2) at (0,-1.3) {$\scriptscriptstyle \sqsubseteq \mapsto \preceq$};
  \node (l) at (-1.5,-2) {@{text lattice}};
  \node (lh) at (0,-4) {@{text lattice_hom}};
  \node (lh1) at (0,-2.7) {$\scriptscriptstyle \sqsubseteq \mapsto \sqsubseteq$};
  \node (lh2) at (-1.5,-3.3) {$\scriptscriptstyle \sqsubseteq \mapsto \preceq$};
  \node (le) at (0,-6) {@{text lattice_end}};
  \node (le1) at (0,-4.8)
    [anchor=west]{$\scriptscriptstyle \sqsubseteq \mapsto \sqsubseteq$};
  \node (le2) at (0,-5.2)
    [anchor=west]{$\scriptscriptstyle \preceq \mapsto \sqsubseteq$};
  \draw (o) -- (l);
  \draw[dashed] (oh) -- (lh);
  \draw (lh) -- (le);
  \draw (o) .. controls (oh1.south west) .. (oh);
  \draw (o) .. controls (oh2.north east) .. (oh);
  \draw (l) .. controls (lh1.south west) .. (lh);
  \draw (l) .. controls (lh2.north east) .. (lh);
\end{tikzpicture}
\end{center}
\hrule
\caption{Hierarchy of Homomorphism Locales.}
\label{fig:hom}
\end{figure}
  *}

text {* It can be shown easily that a lattice homomorphism is order
  preserving.  As the final example of this section, a locale
  interpretation is used to assert this: *}

  sublocale lattice_hom \<subseteq> order_preserving
  proof unfold_locales
    fix x y
    assume "x \<sqsubseteq> y"
    then have "y = (x \<squnion> y)" by (simp add: le.join_connection)
    then have "\<phi> y = (\<phi> x \<squnion>' \<phi> y)" by (simp add: hom_join [symmetric])
    then show "\<phi> x \<preceq> \<phi> y" by (simp add: le'.join_connection)
  qed

text (in lattice_hom) {*
  Theorems and other declarations --- syntax, in particular --- from
  the locale @{text order_preserving} are now active in @{text
  lattice_hom}, for example
  @{thm [source] hom_le}:
  @{thm [display, indent=2] hom_le}
  This theorem will be useful in the following section.
  *}

section {* Conditional Interpretation *}

text {* There are situations where an interpretation is not possible
  in the general case since the desired property is only valid if
  certain conditions are fulfilled.  Take, for example, the function
  @{text "\<lambda>i. n * i"} that scales its argument by a constant factor.
  This function is order preserving (and even a lattice endomorphism)
  with respect to @{term "op \<le>"} provided @{text "n \<ge> 0"}.

  It is not possible to express this using a global interpretation,
  because it is in general unspecified whether~@{term n} is
  non-negative, but one may make an interpretation in an inner context
  of a proof where full information is available.
  This is not fully satisfactory either, since potentially
  interpretations may be required to make interpretations in many
  contexts.  What is
  required is an interpretation that depends on the condition --- and
  this can be done with the \isakeyword{sublocale} command.  For this
  purpose, we introduce a locale for the condition. *}

  locale non_negative =
    fixes n :: int
    assumes non_neg: "0 \<le> n"

text {* It is again convenient to make the interpretation in an
  incremental fashion, first for order preserving maps, the for
  lattice endomorphisms. *}

  sublocale non_negative \<subseteq>
      order_preserving "op \<le>" "op \<le>" "\<lambda>i. n * i"
    using non_neg by unfold_locales (rule mult_left_mono)

text {* While the proof of the previous interpretation
  is straightforward from monotonicity lemmas for~@{term "op *"}, the
  second proof follows a useful pattern. *}

  sublocale %visible non_negative \<subseteq> lattice_end "op \<le>" "\<lambda>i. n * i"
  proof (unfold_locales, unfold int_min_eq int_max_eq)
    txt {* \normalsize Unfolding the locale predicates \emph{and} the
      interpretation equations immediately yields two subgoals that
      reflect the core conjecture.
      @{subgoals [display]}
      It is now necessary to show, in the context of @{term
      non_negative}, that multiplication by~@{term n} commutes with
      @{term min} and @{term max}. *}
  qed (auto simp: hom_le)

text (in order_preserving) {* The lemma @{thm [source] hom_le}
  simplifies a proof that would have otherwise been lengthy and we may
  consider making it a default rule for the simplifier: *}

  lemmas (in order_preserving) hom_le [simp]

subsection {* Avoiding Infinite Chains of Interpretations
  \label{sec:infinite-chains} *}

text {* Similar situations arise frequently in formalisations of
  abstract algebra where it is desirable to express that certain
  constructions preserve certain properties.  For example, polynomials
  over rings are rings, or --- an example from the domain where the
  illustrations of this tutorial are taken from --- a partial order
  may be obtained for a function space by point-wise lifting of the
  partial order of the co-domain.  This corresponds to the following
  interpretation: *}

  sublocale %visible partial_order \<subseteq> f: partial_order "\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x"
    oops

text {* Unfortunately this is a cyclic interpretation that leads to an
  infinite chain, namely
  @{text [display, indent=2] "partial_order \<subseteq> partial_order (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x) \<subseteq>
  partial_order (\<lambda>f g. \<forall>x y. f x y \<sqsubseteq> g x y) \<subseteq>  \<dots>"}
  and the interpretation is rejected.

  Instead it is necessary to declare a locale that is logically
  equivalent to @{term partial_order} but serves to collect facts
  about functions spaces where the co-domain is a partial order, and
  to make the interpretation in its context: *}

  locale fun_partial_order = partial_order

  sublocale fun_partial_order \<subseteq>
      f: partial_order "\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x"
    by unfold_locales (fast,rule,fast,blast intro: trans)

text {* It is quite common in abstract algebra that such a construction
  maps a hierarchy of algebraic structures (or specifications) to a
  related hierarchy.  By means of the same lifting, a function space
  is a lattice if its co-domain is a lattice: *}

  locale fun_lattice = fun_partial_order + lattice

  sublocale fun_lattice \<subseteq> f: lattice "\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x"
  proof unfold_locales
    fix f g
    have "partial_order.is_inf (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x) f g (\<lambda>x. f x \<sqinter> g x)"
      apply (rule is_infI) apply rule+ apply (drule spec, assumption)+ done
    then show "\<exists>inf. partial_order.is_inf (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x) f g inf"
      by fast
  next
    fix f g
    have "partial_order.is_sup (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x) f g (\<lambda>x. f x \<squnion> g x)"
      apply (rule is_supI) apply rule+ apply (drule spec, assumption)+ done
    then show "\<exists>sup. partial_order.is_sup (\<lambda>f g. \<forall>x. f x \<sqsubseteq> g x) f g sup"
      by fast
  qed

section {* Further Reading *}

text {* More information on locales and their interpretation is
  available.  For the locale hierarchy of import and interpretation
  dependencies see~@{cite Ballarin2006a}; interpretations in theories
  and proofs are covered in~@{cite Ballarin2006b}.  In the latter, I
  show how interpretation in proofs enables to reason about families
  of algebraic structures, which cannot be expressed with locales
  directly.

  Haftmann and Wenzel~@{cite HaftmannWenzel2007} overcome a restriction
  of axiomatic type classes through a combination with locale
  interpretation.  The result is a Haskell-style class system with a
  facility to generate ML and Haskell code.  Classes are sufficient for
  simple specifications with a single type parameter.  The locales for
  orders and lattices presented in this tutorial fall into this
  category.  Order preserving maps, homomorphisms and vector spaces,
  on the other hand, do not.

  The locales reimplementation for Isabelle 2009 provides, among other
  improvements, a clean integration with Isabelle/Isar's local theory
  mechanisms, which are described in another paper by Haftmann and
  Wenzel~@{cite HaftmannWenzel2009}.

  The original work of Kamm\"uller on locales~@{cite KammullerEtAl1999}
  may be of interest from a historical perspective.  My previous
  report on locales and locale expressions~@{cite Ballarin2004a}
  describes a simpler form of expressions than available now and is
  outdated. The mathematical background on orders and lattices is
  taken from Jacobson's textbook on algebra~@{cite \<open>Chapter~8\<close> Jacobson1985}.

  The sources of this tutorial, which include all proofs, are
  available with the Isabelle distribution at
  @{url "http://isabelle.in.tum.de"}.
  *}

text {*
\begin{table}
\hrule
\vspace{2ex}
\begin{center}
\begin{tabular}{l>$c<$l}
  \multicolumn{3}{l}{Miscellaneous} \\

  \textit{attr-name} & ::=
  & \textit{name} $|$ \textit{attribute} $|$
    \textit{name} \textit{attribute} \\
  \textit{qualifier} & ::=
  & \textit{name} [``\textbf{?}'' $|$ ``\textbf{!}''] \\[2ex]

  \multicolumn{3}{l}{Context Elements} \\

  \textit{fixes} & ::=
  & \textit{name} [ ``\textbf{::}'' \textit{type} ]
    [ ``\textbf{(}'' \textbf{structure} ``\textbf{)}'' $|$
    \textit{mixfix} ] \\
\begin{comment}
  \textit{constrains} & ::=
  & \textit{name} ``\textbf{::}'' \textit{type} \\
\end{comment}
  \textit{assumes} & ::=
  & [ \textit{attr-name} ``\textbf{:}'' ] \textit{proposition} \\
\begin{comment}
  \textit{defines} & ::=
  & [ \textit{attr-name} ``\textbf{:}'' ] \textit{proposition} \\
  \textit{notes} & ::=
  & [ \textit{attr-name} ``\textbf{=}'' ]
    ( \textit{qualified-name} [ \textit{attribute} ] )$^+$ \\
\end{comment}

  \textit{element} & ::=
  & \textbf{fixes} \textit{fixes} ( \textbf{and} \textit{fixes} )$^*$ \\
\begin{comment}
  & |
  & \textbf{constrains} \textit{constrains}
    ( \textbf{and} \textit{constrains} )$^*$ \\
\end{comment}
  & |
  & \textbf{assumes} \textit{assumes} ( \textbf{and} \textit{assumes} )$^*$ \\[2ex]
%\begin{comment}
%  & |
%  & \textbf{defines} \textit{defines} ( \textbf{and} \textit{defines} )$^*$ \\
%  & |
%  & \textbf{notes} \textit{notes} ( \textbf{and} \textit{notes} )$^*$ \\
%\end{comment}

  \multicolumn{3}{l}{Locale Expressions} \\

  \textit{pos-insts} & ::=
  & ( \textit{term} $|$ ``\textbf{\_}'' )$^*$ \\
  \textit{named-insts} & ::=
  & \textbf{where} \textit{name} ``\textbf{=}'' \textit{term}
  ( \textbf{and} \textit{name} ``\textbf{=}'' \textit{term} )$^*$ \\
  \textit{instance} & ::=
  & [ \textit{qualifier} ``\textbf{:}'' ]
    \textit{name} ( \textit{pos-insts} $|$ \textit{named-inst} ) \\
  \textit{expression}  & ::=
  & \textit{instance} ( ``\textbf{+}'' \textit{instance} )$^*$
    [ \textbf{for} \textit{fixes} ( \textbf{and} \textit{fixes} )$^*$ ] \\[2ex]

  \multicolumn{3}{l}{Declaration of Locales} \\

  \textit{locale} & ::=
  & \textit{element}$^+$ \\
  & | & \textit{expression} [ ``\textbf{+}'' \textit{element}$^+$ ] \\
  \textit{toplevel} & ::=
  & \textbf{locale} \textit{name} [ ``\textbf{=}''
    \textit{locale} ] \\[2ex]

  \multicolumn{3}{l}{Interpretation} \\

  \textit{equation} & ::= & [ \textit{attr-name} ``\textbf{:}'' ]
    \textit{prop} \\
  \textit{equations} & ::= &  \textbf{where} \textit{equation} ( \textbf{and}
    \textit{equation} )$^*$  \\
  \textit{toplevel} & ::=
  & \textbf{sublocale} \textit{name} ( ``$<$'' $|$
    ``$\subseteq$'' ) \textit{expression} \textit{proof} \\
  & |
  & \textbf{interpretation}
    \textit{expression} [ \textit{equations} ] \textit{proof} \\
  & |
  & \textbf{interpret}
    \textit{expression} \textit{proof} \\[2ex]

  \multicolumn{3}{l}{Diagnostics} \\

  \textit{toplevel} & ::=
  & \textbf{print\_locales} \\
  & | & \textbf{print\_locale} [ ``\textbf{!}'' ] \textit{name} \\
  & | & \textbf{print\_interps} \textit{name}
\end{tabular}
\end{center}
\hrule
\caption{Syntax of Locale Commands.}
\label{tab:commands}
\end{table}
  *}

text {* \textbf{Revision History.}  For the present third revision of
  the tutorial, much of the explanatory text
  was rewritten.  Inheritance of interpretation equations is
  available with the forthcoming release of Isabelle, which at the
  time of editing these notes is expected for the end of 2009.
  The second revision accommodates changes introduced by the locales
  reimplementation for Isabelle 2009.  Most notably locale expressions
  have been generalised from renaming to instantiation.  *}

text {* \textbf{Acknowledgements.}  Alexander Krauss, Tobias Nipkow,
  Randy Pollack, Andreas Schropp, Christian Sternagel and Makarius Wenzel
  have made
  useful comments on earlier versions of this document.  The section
  on conditional interpretation was inspired by a number of e-mail
  enquiries the author received from locale users, and which suggested
  that this use case is important enough to deserve explicit
  explanation.  The term \emph{conditional interpretation} is due to
  Larry Paulson. *}

end


section \<open> Greatest Common Divisor \<close>

theory gcd
  imports "UTP.utp"
begin

alphabet gcd_ss =
  x :: int
  y :: int

abbreviation gcd_prog :: "int \<Rightarrow> int \<Rightarrow> gcd_ss hrel" where
  "gcd_prog X Y \<equiv>
   x := \<guillemotleft>X\<guillemotright> ;;
   y := \<guillemotleft>Y\<guillemotright> ;;
   while \<not> (x = y)
   invr x > 0 \<and> y > 0 \<and> gcd x y = gcd \<guillemotleft>X\<guillemotright> \<guillemotleft>Y\<guillemotright>
   do
      if x > y
         then x := x - y
         else y := y - x
      fi
   od"

lemma "TRY(id\<^sub>s \<Turnstile> gcd_prog 6 21)"
  apply (sym_eval)
  oops

lemma gcd_verify:
  "\<lbrace>\<guillemotleft>X\<guillemotright> > 0 \<and> \<guillemotleft>Y\<guillemotright> > 0\<rbrace> gcd_prog X Y \<lbrace>x = gcd \<guillemotleft>X\<guillemotright> \<guillemotleft>Y\<guillemotright>\<rbrace>\<^sub>u"
  oops

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Functions from A to B up to a Permutation on B\<close>

theory Twelvefold_Way_Entry7
imports Equiv_Relations_on_Functions
begin

subsection \<open>Definition of Bijections\<close>

definition partitions_of :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set \<Rightarrow> 'a set set"
where
  "partitions_of A B F = univ (\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) F"

definition functions_of :: "'a set set \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) set"
where
  "functions_of P A B = {f \<in> A \<rightarrow>\<^sub>E B. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P}"

subsection \<open>Properties for Bijections\<close>

lemma partitions_of:
  assumes "finite B"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
  shows "card (partitions_of A B F) \<le> card B"
  and "partition_on A (partitions_of A B F)"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = range_permutation A B `` {f}" using quotientE by blast
  have "partitions_of A B F = univ (\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) F"
    unfolding partitions_of_def ..
  also have "\<dots> = univ (\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) (range_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using equiv_range_permutation domain_partitions_respects_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have partitions_of_eq: "partitions_of A B F = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}" .
  show "card (partitions_of A B F) \<le> card B"
  proof -
    have "card (partitions_of A B F) = card ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
      unfolding partitions_of_eq ..
    also have "\<dots> \<le> card ((\<lambda>b. {x \<in> A. f x = b}) ` B)"
      using \<open>finite B\<close> by (auto intro: card_mono)
    also have "\<dots> \<le> card B"
      using \<open>finite B\<close> by (rule card_image_le)
    finally show ?thesis .
  qed
  show "partition_on A (partitions_of A B F)"
  proof -
    have "partition_on A ((\<lambda>b. {x \<in> A. f x = b}) ` B - {{}})"
      using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by (auto intro!: partition_onI)
    from this show ?thesis
      unfolding partitions_of_eq .
  qed
qed

lemma functions_of:
  assumes "finite A" "finite B"
  assumes "partition_on A P"
  assumes "card P \<le> card B"
  shows "functions_of P A B \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
proof -
  obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and r1: "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
    using obtain_function_with_partition[OF \<open>finite A\<close> \<open>finite B\<close> \<open>partition_on A P\<close> \<open>card P \<le> card B\<close>]
    by blast
  have "functions_of P A B = range_permutation A B `` {f}"
  proof
    show "functions_of P A B \<subseteq> range_permutation A B `` {f}"
    proof
      fix f'
      assume "f' \<in> functions_of P A B"
      from this have "f' \<in> A \<rightarrow>\<^sub>E B" and r2: "(\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}} = P"
        unfolding functions_of_def by auto
      from r1 r2
      obtain p where "p permutes B \<and> (\<forall>x\<in>A. f x = p (f' x))"
        using partitions_eq_implies_permutes[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>] \<open>finite B\<close> by metis
      from this show "f' \<in> range_permutation A B `` {f}"
        using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>
        unfolding range_permutation_def by auto
    qed
  next
    show "range_permutation A B `` {f} \<subseteq> functions_of P A B"
    proof
      fix f'
      assume "f' \<in> range_permutation A B `` {f}"
      from this have "(f, f') \<in> range_permutation A B" by auto
      from this have "f' \<in> A \<rightarrow>\<^sub>E B"
        unfolding range_permutation_def by auto
      from \<open>(f, f') \<in> range_permutation A B\<close> have
        "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
        using congruentD[OF domain_partitions_respects_range_permutation] by blast
      from \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> this r1 show "f' \<in> functions_of P A B"
        unfolding functions_of_def by auto
    qed
  qed
  from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show ?thesis by (auto intro: quotientI)
qed

lemma functions_of_partitions_of:
  assumes "finite B"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
  shows "functions_of (partitions_of A B F) A B = F"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = range_permutation A B `` {f}" using quotientE by blast
  have partitions_of_eq: "partitions_of A B F = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
        unfolding partitions_of_def F_eq
        using equiv_range_permutation domain_partitions_respects_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
        by (subst univ_commute') auto
  show ?thesis
  proof
    show "functions_of (partitions_of A B F) A B \<subseteq> F"
    proof
      fix f'
      assume f': "f' \<in> functions_of (partitions_of A B F) A B"
      from this have "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}"
        unfolding functions_of_def by (auto simp add: partitions_of_eq)
      note \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
      moreover from f' have "f' \<in> A \<rightarrow>\<^sub>E B"
        unfolding functions_of_def by auto
      moreover obtain p where "p permutes B \<and> (\<forall>x\<in>A. f x = p (f' x))"
        using partitions_eq_implies_permutes[OF \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> \<open>finite B\<close>
          \<open>(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}}\<close>]
        by metis
      ultimately show "f' \<in> F"
        unfolding F_eq range_permutation_def by auto
    qed
  next
    show "F \<subseteq> functions_of (partitions_of A B F) A B"
    proof
      fix f'
      assume "f' \<in> F"
      from this have "f' \<in> A \<rightarrow>\<^sub>E B"
        unfolding F_eq range_permutation_def by auto
      from \<open>f' \<in> F\<close> obtain p where "p permutes B" "\<forall>x\<in>A. f x = p (f' x)"
        unfolding F_eq range_permutation_def by auto
      have eq: "(\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
      proof -
        have "(\<lambda>b. {x \<in> A. f' x = b}) ` B - {{}} = (\<lambda>b. {x \<in> A. p (f' x) = b}) ` B - {{}}"
          using permutes_implies_inv_image_on_eq[OF \<open>p permutes B\<close>, of A f'] by simp
        also have "\<dots> =  (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
          using \<open>\<forall>x\<in>A. f x = p (f' x)\<close> by auto
        finally show ?thesis .
      qed
      from this \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> show "f' \<in> functions_of (partitions_of A B F) A B"
        unfolding functions_of_def partitions_of_eq by auto
    qed
  qed
qed

lemma partitions_of_functions_of:
  assumes "finite A" "finite B"
  assumes "partition_on A P"
  assumes "card P \<le> card B"
  shows "partitions_of A B (functions_of P A B) = P"
proof -
  have "functions_of P A B \<in> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
    using \<open>finite A\<close> \<open>finite B\<close> \<open>partition_on A P\<close> \<open>card P \<le> card B\<close> by (rule functions_of)
  from this obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and functions_of_eq: "functions_of P A B = range_permutation A B `` {f}"
    using quotientE by metis
  from functions_of_eq \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f \<in> functions_of P A B"
    using equiv_range_permutation equiv_class_self by fastforce
  have "partitions_of A B (functions_of P A B) = univ (\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) (functions_of P A B)"
    unfolding partitions_of_def ..
  also have "\<dots> = univ (\<lambda>f. (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}) (range_permutation A B `` {f})"
    unfolding \<open>functions_of P A B = range_permutation A B `` {f}\<close> ..
  also have "\<dots> = (\<lambda>b. {x \<in> A. f x = b}) ` B - {{}}"
    using equiv_range_permutation domain_partitions_respects_range_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  also have "(\<lambda>b. {x \<in> A. f x = b}) ` B - {{}} = P"
    using \<open>f \<in> functions_of P A B\<close> unfolding functions_of_def by simp
  finally show ?thesis .
qed

subsection \<open>Bijections\<close>

lemma bij_betw_partitions_of:
  assumes "finite A" "finite B"
  shows "bij_betw (partitions_of A B) ((A \<rightarrow>\<^sub>E B) // range_permutation A B) {P. partition_on A P \<and> card P \<le> card B}"
proof (rule bij_betw_byWitness[where f'="\<lambda>P. functions_of P A B"])
  show "\<forall>F\<in>(A \<rightarrow>\<^sub>E B) // range_permutation A B. functions_of (partitions_of A B F) A B = F"
    using \<open>finite B\<close> by (simp add: functions_of_partitions_of)
  show "\<forall>P\<in>{P. partition_on A P \<and> card P \<le> card B}. partitions_of A B (functions_of P A B) = P"
    using \<open>finite A\<close> \<open>finite B\<close> by (auto simp add: partitions_of_functions_of)
  show "partitions_of A B ` ((A \<rightarrow>\<^sub>E B) // range_permutation A B) \<subseteq> {P. partition_on A P \<and> card P \<le> card B}"
    using \<open>finite B\<close> partitions_of by auto
  show "(\<lambda>P. functions_of P A B) ` {P. partition_on A P \<and> card P \<le> card B} \<subseteq> (A \<rightarrow>\<^sub>E B) // range_permutation A B"
    using functions_of \<open>finite A\<close> \<open>finite B\<close> by auto
qed

subsection \<open>Cardinality\<close>

lemma
  assumes "finite A" "finite B"
  shows "card ((A \<rightarrow>\<^sub>E B) // range_permutation A B) = (\<Sum>j\<le>card B. Stirling (card A) j)"
proof -
  have "bij_betw (partitions_of A B) ((A \<rightarrow>\<^sub>E B) // range_permutation A B) {P. partition_on A P \<and> card P \<le> card B}"
    using \<open>finite A\<close> \<open>finite B\<close> by (rule bij_betw_partitions_of)
  from this have "card ((A \<rightarrow>\<^sub>E B) // range_permutation A B) = card {P. partition_on A P \<and> card P \<le> card B}"
    by (rule bij_betw_same_card)
  also have "card  {P. partition_on A P \<and> card P \<le> card B} = (\<Sum>j\<le>card B. Stirling (card A) j)"
    using \<open>finite A\<close> by (rule card_partition_on_at_most_size)
  finally show ?thesis .
qed

end


(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file contains the verification of meta-theoretical connections of extension-based semantics.
   Auxiliary references:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
            Knowledge Engineering Review (2011)
*)
theory "ext-relationships"
  imports "extensions" "ext-properties"
begin

(************************************************************************)
(* Inclusion relations as summary: Figure 12 of [BCG2011]
   All but one verified. The non-inclusion of the inverse directions has been checked
   with Nitpick in every case.  *)
(************************************************************************)

lemma stage_implies_cf_ext: \<open>stageExt\<^sup>\<A> AF S \<Longrightarrow> conflictfreeExt\<^sup>\<A> AF S\<close>
  by (simp add: maximal_rel_def stageExt_def)

lemma admissible_implies_cf_ext: \<open>admissibleExt\<^sup>\<A> AF S \<Longrightarrow> conflictfreeExt\<^sup>\<A> AF S\<close>
  by (simp add: admissibleExt_def)

lemma complete_implies_admissible_ext: \<open>completeExt\<^sup>\<A> AF S \<Longrightarrow> admissibleExt\<^sup>\<A> AF S\<close>
  by (simp add: completeExt_def)

lemma grounded_implies_complete_ext: \<open>groundedExt\<^sup>\<A> AF S \<Longrightarrow> completeExt\<^sup>\<A> AF S\<close>
  by (simp add: groundedExt_def minimal_rel_def)

lemma ideal_implies_complete_ext: \<open>idealExt2\<^sup>\<A> AF S \<Longrightarrow> completeExt\<^sup>\<A> AF S\<close>
  oops (*TODO*)

lemma preferred_implies_complete_ext: \<open>preferredExt\<^sup>\<A> AF S \<Longrightarrow> completeExt\<^sup>\<A> AF S\<close>
  by (simp add: maximal_rel_def preferredExt_def)

lemma stable_implies_stage_ext: \<open>stableExt\<^sup>\<A> AF S \<Longrightarrow> stageExt\<^sup>\<A> AF S\<close>
  by (simp add: greatestMax_rel greatest_rel_def stableExt_def stageExt_def)

lemma semistable_implies_preferred_ext: \<open>semistableExt\<^sup>\<A> AF S \<Longrightarrow> preferredExt\<^sup>\<A> AF S\<close>
  unfolding semistableExt_def preferredExt_def maximal_rel_def range_def
  by (smt (z3) admissible_implies_cf_ext complete_implies_admissible_ext conflictfreeExt_def id_apply plusset_rel_def)

lemma stable_implies_semistable_ext: \<open>stableExt\<^sup>\<A> AF S \<Longrightarrow> semistableExt\<^sup>\<A> AF S\<close>
  by (smt (verit, ccfv_threshold) admissibleExt_def completeExt_def conflictfreeExt_def defends_rel_def greatestMax_rel greatest_rel_def plusset_rel_def range_def semistableExt_def stableExt_def)

end


subsection "The CYK Algorithm"

theory CYK
imports
  "HOL-Library.IArray"
  "HOL-Library.Code_Target_Numeral"
  "HOL-Library.Product_Lexorder"
  "HOL-Library.RBT_Mapping"
  "../state_monad/State_Main"
  "../heap_monad/Heap_Default"
  Example_Misc
begin

subsubsection \<open>Misc\<close>

lemma append_iff_take_drop:
  "w = u@v \<longleftrightarrow> (\<exists>k \<in> {0..length w}. u = take k w \<and> v = drop k w)"
by (metis (full_types) append_eq_conv_conj append_take_drop_id atLeastAtMost_iff le0 le_add1 length_append)

lemma append_iff_take_drop1: "u \<noteq> [] \<Longrightarrow> v \<noteq> [] \<Longrightarrow>
  w = u@v \<longleftrightarrow> (\<exists>k \<in> {1..length w - 1}. u = take k w \<and> v = drop k w)"
by(auto simp: append_iff_take_drop)

subsubsection \<open>Definitions\<close>

datatype ('n, 't) rhs = NN 'n 'n | T 't

type_synonym ('n, 't) prods = "('n \<times> ('n, 't) rhs) list"

context
fixes P :: "('n :: heap, 't) prods"
begin

inductive yield :: "'n \<Rightarrow> 't list \<Rightarrow> bool" where
"(A, T a) \<in> set P \<Longrightarrow> yield A [a]" |
"\<lbrakk> (A, NN B C) \<in> set P; yield B u; yield C v \<rbrakk> \<Longrightarrow> yield A (u@v)"

lemma yield_not_Nil: "yield A w \<Longrightarrow> w \<noteq> []"
by (induction rule: yield.induct) auto

lemma yield_eq1:
  "yield A [a] \<longleftrightarrow> (A, T a) \<in> set P" (is "?L = ?R")
proof
  assume ?L thus ?R
    by(induction A "[a]" arbitrary: a rule: yield.induct)
      (auto simp add: yield_not_Nil append_eq_Cons_conv)
qed (simp add: yield.intros)

lemma yield_eq2: assumes "length w > 1"
shows "yield A w \<longleftrightarrow> (\<exists>B u C v. yield B u \<and> yield C v \<and> w = u@v \<and> (A, NN B C) \<in> set P)"
       (is "?L = ?R")
proof
  assume ?L from this assms show ?R
    by(induction rule: yield.induct) (auto)
next
  assume ?R with assms show ?L
    by (auto simp add: yield.intros)
qed

subsubsection "CYK on Lists"

fun cyk :: "'t list \<Rightarrow> 'n list" where
"cyk [] = []" |
"cyk [a] = [A . (A, T a') <- P, a'= a]" |
"cyk w =
  [A. k <- [1..<length w], B <- cyk (take k w), C <- cyk (drop k w), (A, NN B' C') <- P, B' = B, C' = C]"

lemma set_cyk_simp2[simp]: "length w \<ge> 2 \<Longrightarrow> set(cyk w) =
  (\<Union>k \<in> {1..length w - 1}. \<Union>B \<in> set(cyk (take k w)). \<Union>C \<in> set(cyk (drop k w)). {A. (A, NN B C) \<in> set P})"
apply(cases w)
 apply simp
subgoal for _ w'
apply(case_tac w')
 apply auto
    apply force
   apply force
  apply force
 using le_Suc_eq le_simps(3) apply auto[1]
by (metis drop_Suc_Cons le_Suc_eq le_antisym not_le take_Suc_Cons)
done

declare cyk.simps(3)[simp del]

lemma cyk_correct: "set(cyk w) = {N. yield N w}"
proof (induction w rule: cyk.induct)
  case 1 thus ?case by (auto dest: yield_not_Nil)
next
  case 2 thus ?case by (auto simp add: yield_eq1)
next
  case (3 v vb vc)
  let ?w = "v # vb # vc"
  have "set(cyk ?w) = (\<Union>k\<in>{1..length ?w-1}. {N. \<exists>A B. (N, NN A B) \<in> set P \<and>
             yield A (take k ?w) \<and> yield B (drop k ?w)})"
    by(auto simp add:"3.IH" simp del:upt_Suc)
  also have "... = {N. \<exists>A B. (N, NN A B) \<in> set P \<and>
              (\<exists>u v. yield A u \<and> yield B v \<and> ?w = u@v)}"
    by(fastforce simp add: append_iff_take_drop1 yield_not_Nil)
  also have "... = {N. yield N ?w}" using yield_eq2[of ?w] by(auto)
  finally show ?case .
qed

subsubsection "CYK on Lists and Index"

fun cyk2 :: "'t list \<Rightarrow> nat * nat \<Rightarrow> 'n list" where
"cyk2 w (i,0) = []" |
"cyk2 w (i,Suc 0) = [A . (A, T a) <- P, a = w!i]" |
"cyk2 w (i,n) =
[A. k <- [1..<n], B <- cyk2 w (i,k), C <- cyk2 w (i+k,n-k), (A, NN B' C') <- P, B' = B, C' = C]"

lemma set_aux: "(\<Union>xb\<in>set P. {A. (A, NN B C) = xb}) = {A. (A, NN B C) \<in> set P}"
by auto

lemma cyk2_eq_cyk: "i+n \<le> length w \<Longrightarrow> set(cyk2 w (i,n)) = set(cyk (take n (drop i w)))"
proof(induction w "(i,n)" arbitrary: i n rule: cyk2.induct)
  case 1 show ?case by(simp)
next
  case 2 show ?case using "2.prems"
    by(auto simp: hd_drop_conv_nth take_Suc)
next
  case (3 w i m)
  show ?case using "3.prems"
    by(simp add: 3(1,2) min.absorb1 min.absorb2 drop_take atLeastLessThanSuc_atLeastAtMost set_aux
         del:upt_Suc cong: SUP_cong_simp)
      (simp add: add.commute)
qed

definition "CYK S w =  (S \<in> set(cyk2 w (0, length w)))"

theorem CYK_correct: "CYK S w = yield S w"
by(simp add: CYK_def cyk2_eq_cyk cyk_correct)

subsubsection "CYK With Index Function"

context
fixes w :: "nat \<Rightarrow> 't"
begin

fun cyk_ix :: "nat * nat \<Rightarrow> 'n list" where
"cyk_ix (i,0) = []" |
"cyk_ix (i,Suc 0) = [A . (A, T a) <- P, a = w i]" |
"cyk_ix (i,n) =
  [A. k <- [1..<n], B <- cyk_ix (i,k), C <- cyk_ix (i+k,n-k), (A, NN B' C') <- P, B' = B, C' = C]"

subsubsection \<open>Correctness Proof\<close>

lemma cyk_ix_simp2: "set(cyk_ix (i,Suc(Suc n))) =
  (\<Union>k \<in> {1..Suc n}. \<Union>B \<in> set(cyk_ix (i,k)). \<Union>C \<in> set(cyk_ix (i+k,n+2-k)). {A. (A, NN B C) \<in> set P})"
by(simp add: atLeastLessThanSuc_atLeastAtMost set_aux del: upt_Suc)

declare cyk_ix.simps(3)[simp del]

abbreviation "slice f i j \<equiv> map f [i..<j]"

lemma slice_append_iff_take_drop1: "u \<noteq> [] \<Longrightarrow> v \<noteq> [] \<Longrightarrow>
  slice w i j = u @ v \<longleftrightarrow> (\<exists>k. 1 \<le> k \<and> k \<le> j-i-1 \<and> slice w i (i + k) = u \<and> slice w (i + k) j = v)"
by(subst append_iff_take_drop1) (auto simp: take_map drop_map Bex_def)

lemma cyk_ix_correct:
  "set(cyk_ix (i,n)) = {N. yield N (slice w i (i+n))}"
proof (induction "(i,n)" arbitrary: i n rule: cyk_ix.induct)
  case 1 thus ?case by (auto simp: dest: yield_not_Nil)
next
  case 2 thus ?case by (auto simp add: yield_eq1)
next
  case (3 i m)
  let ?n = "Suc(Suc m)" let ?w = "slice w i (i+?n)"
  have "set(cyk_ix (i,?n)) = (\<Union>k\<in>{1..Suc m}. {N. \<exists>A B. (N, NN A B) \<in> set P \<and>
             yield A (slice w i (i+k)) \<and> yield B (slice w (i+k) (i+?n))})"
    by(auto simp add: 3 cyk_ix_simp2 simp del: upt_Suc)
  also have "... = {N. \<exists>A B. (N, NN A B) \<in> set P \<and>
              (\<exists>u v. yield A u \<and> yield B v \<and> slice w i (i+?n) = u@v)}"
    by(fastforce simp del: upt_Suc simp: slice_append_iff_take_drop1 yield_not_Nil cong: conj_cong)
  also have "... = {N. yield N ?w}" using yield_eq2[of ?w] by(auto)
  finally show ?case .
qed

subsubsection \<open>Functional Memoization\<close>

memoize_fun cyk_ix\<^sub>m: cyk_ix with_memory dp_consistency_mapping monadifies (state) cyk_ix.simps
thm cyk_ix\<^sub>m'.simps

memoize_correct
  by memoize_prover
print_theorems

lemmas [code] = cyk_ix\<^sub>m.memoized_correct

subsubsection \<open>Imperative Memoization\<close>

context
  fixes n :: nat
begin

context
  fixes mem :: "'n list option array"
begin

memoize_fun cyk_ix\<^sub>h: cyk_ix
  with_memory dp_consistency_heap_default where bound = "Bound (0, 0) (n, n)" and mem="mem"
  monadifies (heap) cyk_ix.simps

context includes heap_monad_syntax begin
thm cyk_ix\<^sub>h'.simps cyk_ix\<^sub>h_def
end

memoize_correct
  by memoize_prover

lemmas memoized_empty = cyk_ix\<^sub>h.memoized_empty

lemmas init_success = cyk_ix\<^sub>h.init_success

end (* Fixed array *)

definition "cyk_ix_impl i j = do {mem \<leftarrow> mem_empty (n * n); cyk_ix\<^sub>h' mem (i, j)}"

lemma cyk_ix_impl_success:
  "success (cyk_ix_impl i j) Heap.empty"
  using init_success[of _ cyk_ix\<^sub>h' "(i, j)", OF cyk_ix\<^sub>h.crel]
  by (simp add: cyk_ix_impl_def index_size_defs)

lemma min_wpl_heap:
  "cyk_ix (i, j) = result_of (cyk_ix_impl i j) Heap.empty"
  unfolding cyk_ix_impl_def
  using memoized_empty[of _ cyk_ix\<^sub>h' "(i, j)", OF cyk_ix\<^sub>h.crel]
  by (simp add: index_size_defs)

end (* Bound *)

end (* Index *)

definition "CYK_ix S w n =  (S \<in> set(cyk_ix w (0,n)))"

theorem CYK_ix_correct: "CYK_ix S w n = yield S (slice w 0 n)"
by(simp add: CYK_ix_def cyk_ix_correct)

definition "cyk_list w = cyk_ix (\<lambda>i. w ! i) (0,length w)"

definition
  "CYK_ix_impl S w n = do {R \<leftarrow> cyk_ix_impl w n 0 n; return (S \<in> set R)}"

lemma CYK_ix_impl_correct:
  "result_of (CYK_ix_impl S w n) Heap.empty = yield S (slice w 0 n)"
  unfolding CYK_ix_impl_def
  by (simp add: execute_bind_success[OF cyk_ix_impl_success]
        min_wpl_heap[symmetric] CYK_ix_correct CYK_ix_def[symmetric]
     )

end (* Fixed Productions *)

subsubsection \<open>Functional Test Case\<close>

value
  "(let P = [(0::int, NN 1 2), (0, NN 2 3),
            (1, NN 2 1), (1, T (CHR ''a'')),
            (2, NN 3 3), (2, T (CHR ''b'')),
            (3, NN 1 2), (3, T (CHR ''a''))]
  in map (\<lambda>w. cyk2 P w (0,length w)) [''baaba'', ''baba''])"

value
  "(let P = [(0::int, NN 1 2), (0, NN 2 3),
            (1, NN 2 1), (1, T (CHR ''a'')),
            (2, NN 3 3), (2, T (CHR ''b'')),
            (3, NN 1 2), (3, T (CHR ''a''))]
  in map (cyk_list P) [''baaba'', ''baba''])"

definition "cyk_ia P w = (let a = IArray w in cyk_ix P (\<lambda>i. a !! i) (0,length w))"

value
  "(let P = [(0::int, NN 1 2), (0, NN 2 3),
            (1, NN 2 1), (1, T (CHR ''a'')),
            (2, NN 3 3), (2, T (CHR ''b'')),
            (3, NN 1 2), (3, T (CHR ''a''))]
  in map (cyk_ia P) [''baaba'', ''baba''])"

subsubsection \<open>Imperative Test Case\<close>

definition "cyk_ia' P w = (let a = IArray w in cyk_ix_impl P (\<lambda>i. a !! i) (length w) 0 (length w))"

definition
  "test = (let P = [(0::int, NN 1 2), (0, NN 2 3),
            (1, NN 2 1), (1, T (CHR ''a'')),
            (2, NN 3 3), (2, T (CHR ''b'')),
            (3, NN 1 2), (3, T (CHR ''a''))]
  in map (cyk_ia' P) [''baaba'', ''baba''])"

code_reflect Test functions test

ML \<open>List.map (fn f => f ()) Test.test\<close>

end


(*  Title:      HOL/Metis_Examples/Proxies.thy
    Author:     Jasmin Blanchette, TU Muenchen

Example that exercises Metis's and Sledgehammer's logical symbol proxies for
rudimentary higher-order reasoning.
*)

section \<open>
Example that Exercises Metis's and Sledgehammer's Logical Symbol Proxies for
Rudimentary Higher-Order Reasoning.
\<close>

theory Proxies
imports Type_Encodings
begin

sledgehammer_params [prover = spass, fact_filter = mepo, timeout = 30, preplay_timeout = 0,
  dont_minimize]

text \<open>Extensionality and set constants\<close>

lemma plus_1_not_0: "n + (1::nat) \<noteq> 0"
by simp

definition inc :: "nat \<Rightarrow> nat" where
"inc x = x + 1"

lemma "inc \<noteq> (\<lambda>y. 0)"
sledgehammer [expect = some] (inc_def plus_1_not_0)
by (metis_exhaust inc_def plus_1_not_0)

lemma "inc = (\<lambda>y. y + 1)"
sledgehammer [expect = some]
by (metis_exhaust inc_def)

definition add_swap :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add_swap = (\<lambda>x y. y + x)"

lemma "add_swap m n = n + m"
sledgehammer [expect = some] (add_swap_def)
by (metis_exhaust add_swap_def)

definition "A = {xs::'a list. True}"

lemma "xs \<in> A"
(* The "add:" argument is unfortunate. *)
sledgehammer [expect = some] (add: A_def mem_Collect_eq)
by (metis_exhaust A_def mem_Collect_eq)

definition "B (y::int) \<equiv> y \<le> 0"
definition "C (y::int) \<equiv> y \<le> 1"

lemma int_le_0_imp_le_1: "x \<le> (0::int) \<Longrightarrow> x \<le> 1"
by linarith

lemma "B \<le> C"
sledgehammer [expect = some]
by (metis_exhaust B_def C_def int_le_0_imp_le_1 predicate1I)

text \<open>Proxies for logical constants\<close>

lemma "id (=) x x"
sledgehammer [type_enc = erased, expect = none] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis (full_types) id_apply)

lemma "id True"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "\<not> id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "x = id True \<or> x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id x = id True \<or> id x = id False"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "P True \<Longrightarrow> P False \<Longrightarrow> P x"
sledgehammer [type_enc = erased, expect = none] ()
sledgehammer [type_enc = poly_args, expect = none] ()
sledgehammer [type_enc = poly_tags??, expect = some] ()
sledgehammer [type_enc = poly_tags, expect = some] ()
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] ()
sledgehammer [type_enc = mono_tags??, expect = some] ()
sledgehammer [type_enc = mono_tags, expect = some] ()
sledgehammer [type_enc = mono_guards??, expect = some] ()
sledgehammer [type_enc = mono_guards, expect = some] ()
by (metis (full_types))

lemma "id (\<not> a) \<Longrightarrow> \<not> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> \<not> a) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by metis_exhaust

lemma "id (\<not> (id (\<not> a))) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id a"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<and> b) \<Longrightarrow> id b"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id b \<Longrightarrow> id (a \<and> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id a \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id b \<Longrightarrow> id (a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (\<not> b) \<Longrightarrow> id (\<not> (a \<or> b))"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (\<not> a) \<Longrightarrow> id (a \<longrightarrow> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

lemma "id (a \<longrightarrow> b) \<longleftrightarrow> id (\<not> a \<or> b)"
sledgehammer [type_enc = erased, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags??, expect = some] (id_apply)
sledgehammer [type_enc = poly_tags, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards??, expect = some] (id_apply)
sledgehammer [type_enc = poly_guards, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags??, expect = some] (id_apply)
sledgehammer [type_enc = mono_tags, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards??, expect = some] (id_apply)
sledgehammer [type_enc = mono_guards, expect = some] (id_apply)
by (metis_exhaust id_apply)

end


(* Title:      Tests
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Tests\<close>

theory Tests

imports Subset_Boolean_Algebras.Subset_Boolean_Algebras Base

begin

context subset_boolean_algebra_extended
begin

sublocale sba_dual: subset_boolean_algebra_extended where uminus = uminus and sup = inf and minus = "\<lambda>x y . -(-x \<sqinter> y)" and inf = sup and bot = top and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: inf_associative)
  apply (simp add: inf_commutative)
  using inf_cases_2 apply simp
  using inf_closed apply simp
  apply simp
  apply simp
  using sub_sup_closed sub_sup_demorgan apply simp
  apply simp
  apply (simp add: inf_commutative less_eq_inf)
  by (metis inf_commutative inf_idempotent inf_left_dist_sup sub_less_def sup_absorb sup_right_zero top_double_complement)

lemma strict_leq_def:
  "-x < -y \<longleftrightarrow> -x \<le> -y \<and> \<not> (-y \<le> -x)"
  by (simp add: sba_dual.sba_dual.sub_less_def sba_dual.sba_dual.sub_less_eq_def)

lemma one_def:
  "top = -bot"
  by simp

end

class tests = times + uminus + one + ord + sup + bot +
  assumes sub_assoc: "-x * (-y * -z) = (-x * -y) * -z"
  assumes sub_comm: "-x * -y = -y * -x"
  assumes sub_compl: "-x = -(--x * -y) * -(--x * --y)"
  assumes sub_mult_closed: "-x * -y = --(-x * -y)"
  assumes the_bot_def: "bot = (THE x . (\<forall>y . x = -y * --y))" (* define without imposing uniqueness *)
  assumes one_def: "1 = - bot"
  assumes sup_def: "-x \<squnion> -y = -(--x * --y)"
  assumes leq_def: "-x \<le> -y \<longleftrightarrow> -x * -y = -x"
  assumes strict_leq_def: "-x < -y \<longleftrightarrow> -x \<le> -y \<and> \<not> (-y \<le> -x)"
begin

sublocale tests_dual: subset_boolean_algebra_extended where uminus = uminus and sup = times and minus = "\<lambda>x y . -(-x * y)" and inf = sup and bot = 1 and less_eq = greater_eq and less = greater and top = bot
  apply unfold_locales
  apply (simp add: sub_assoc)
  apply (simp add: sub_comm)
  apply (simp add: sub_compl)
  using sub_mult_closed apply simp
  apply (simp add: the_bot_def)
  apply (simp add: one_def the_bot_def)
  apply (simp add: sup_def)
  apply simp
  apply (simp add: leq_def sub_comm)
  by (simp add: leq_def strict_leq_def sub_comm)

sublocale sba: subset_boolean_algebra_extended where uminus = uminus and sup = sup and minus = "\<lambda>x y . -(-x \<squnion> y)" and inf = times and bot = bot and less_eq = less_eq and less = less and top = 1 ..

text \<open>sets and sequences of tests\<close>

definition test_set :: "'a set \<Rightarrow> bool"
  where "test_set A \<equiv> \<forall>x\<in>A . x = --x"

lemma mult_left_dist_test_set:
  "test_set A \<Longrightarrow> test_set { -p * x | x . x \<in> A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma mult_right_dist_test_set:
  "test_set A \<Longrightarrow> test_set { x * -p | x . x \<in> A }"
  by (smt mem_Collect_eq sub_mult_closed test_set_def)

lemma sup_left_dist_test_set:
  "test_set A \<Longrightarrow> test_set { -p \<squnion> x | x . x \<in> A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma sup_right_dist_test_set:
  "test_set A \<Longrightarrow> test_set { x \<squnion> -p | x . x \<in> A }"
  by (smt mem_Collect_eq tests_dual.sba_dual.sub_sup_closed test_set_def)

lemma test_set_closed:
  "A \<subseteq> B \<Longrightarrow> test_set B \<Longrightarrow> test_set A"
  using test_set_def by auto

definition test_seq :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "test_seq t \<equiv> \<forall>n . t n = --t n"

lemma test_seq_test_set:
  "test_seq t \<Longrightarrow> test_set { t n | n::nat . True }"
  using test_seq_def test_set_def by auto

definition nat_test :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> bool"
  where "nat_test t s \<equiv> (\<forall>n . t n = --t n) \<and> s = --s \<and> (\<forall>n . t n \<le> s) \<and> (\<forall>x y . (\<forall>n . t n * -x \<le> -y) \<longrightarrow> s * -x \<le> -y)"

lemma nat_test_seq:
  "nat_test t s \<Longrightarrow> test_seq t"
  by (simp add: nat_test_def test_seq_def)

primrec pSum :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
  where "pSum f 0 = bot"
      | "pSum f (Suc m) = pSum f m \<squnion> f m"

lemma pSum_test:
  "test_seq t \<Longrightarrow> pSum t m = --(pSum t m)"
  apply (induct m)
  apply simp
  by (smt pSum.simps(2) tests_dual.sba_dual.sub_sup_closed test_seq_def)

lemma pSum_test_nat:
  "nat_test t s \<Longrightarrow> pSum t m = --(pSum t m)"
  by (metis nat_test_seq pSum_test)

lemma pSum_upper:
  "test_seq t \<Longrightarrow> i<m \<Longrightarrow> t i \<le> pSum t m"
proof (induct m)
  show "test_seq t \<Longrightarrow> i<0 \<Longrightarrow> t i \<le> pSum t 0"
    by (smt less_zeroE)
next
  fix n
  assume "test_seq t \<Longrightarrow> i<n \<Longrightarrow> t i \<le> pSum t n"
  hence "test_seq t \<Longrightarrow> i<n \<Longrightarrow> t i \<le> pSum t (Suc n)"
    by (smt (z3) pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_left tests_dual.transitive test_seq_def)
  thus "test_seq t \<Longrightarrow> i<Suc n \<Longrightarrow> t i \<le> pSum t (Suc n)"
    by (metis less_Suc_eq pSum.simps(2) pSum_test tests_dual.sba_dual.upper_bound_right test_seq_def)
qed

lemma pSum_below:
  "test_seq t \<Longrightarrow> (\<forall>m<k . t m * -p \<le> -q) \<Longrightarrow> pSum t k * -p \<le> -q"
  apply (induct k)
  apply (simp add: tests_dual.top_greatest)
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_dist_inf pSum.simps(2) pSum_test test_seq_def sub_mult_closed less_Suc_eq tests_dual.sba_dual.sub_associative tests_dual.sba_dual.sub_less_eq_def)

lemma pSum_below_nat:
  "nat_test t s \<Longrightarrow> (\<forall>m<k . t m * -p \<le> -q) \<Longrightarrow> pSum t k * -p \<le> -q"
  by (simp add: nat_test_seq pSum_below)

lemma pSum_below_sum:
  "nat_test t s \<Longrightarrow> pSum t x \<le> s"
  by (smt (verit, ccfv_threshold) tests_dual.sup_right_unit nat_test_def one_def pSum_below_nat pSum_test_nat)

lemma ascending_chain_sup_left:
  "ascending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> ascending_chain (\<lambda>n . -p \<squnion> t n) \<and> test_seq (\<lambda>n . -p \<squnion> t n)"
  by (smt (z3) ord.ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma ascending_chain_sup_right:
  "ascending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> ascending_chain (\<lambda>n . t n \<squnion> -p) \<and> test_seq (\<lambda>n . t n \<squnion> -p)"
  by (smt ascending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma ascending_chain_mult_left:
  "ascending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> ascending_chain (\<lambda>n . -p * t n) \<and> test_seq (\<lambda>n . -p * t n)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma ascending_chain_mult_right:
  "ascending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> ascending_chain (\<lambda>n . t n * -p) \<and> test_seq (\<lambda>n . t n * -p)"
  by (smt (z3) ascending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_sup_left:
  "descending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> descending_chain (\<lambda>n . -p \<squnion> t n) \<and> test_seq (\<lambda>n . -p \<squnion> t n)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_right_isotone test_seq_def)

lemma descending_chain_sup_right:
  "descending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> descending_chain (\<lambda>n . t n \<squnion> -p) \<and> test_seq (\<lambda>n . t n \<squnion> -p)"
  by (smt descending_chain_def tests_dual.sba_dual.sub_sup_closed tests_dual.sba_dual.sub_sup_left_isotone test_seq_def)

lemma descending_chain_mult_left:
  "descending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> descending_chain (\<lambda>n . -p * t n) \<and> test_seq (\<lambda>n . -p * t n)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

lemma descending_chain_mult_right:
  "descending_chain t \<Longrightarrow> test_seq t \<Longrightarrow> descending_chain (\<lambda>n . t n * -p) \<and> test_seq (\<lambda>n . t n * -p)"
  by (smt (z3) descending_chain_def sub_mult_closed tests_dual.sba_dual.reflexive tests_dual.sup_isotone test_seq_def)

end

end


chapter\<open>Models\<close>
text\<open>In this chapter, we present our formalisation of EFSMs from \<^cite>\<open>"foster2018"\<close>. We first
define transitions, before defining EFSMs as finite sets of transitions between states. Finally,
we provide a framework of function definitions and key lemmas such that LTL properties over EFSMs
can be more easily specified and proven.\<close>

section\<open>Transitions\<close>
text\<open>Here we define the transitions which make up EFSMs. As per \<^cite>\<open>"foster2018"\<close>, each transition
has a label and an arity and, optionally, guards, outputs, and updates. To implement this, we use
the record type such that each component of the transition can be accessed.\<close>

theory Transition
imports GExp
begin

type_synonym label = String.literal
type_synonym arity = nat
type_synonym guard = "vname gexp"
type_synonym inputs = "value list"
type_synonym outputs = "value option list"
type_synonym output_function = "vname aexp"
type_synonym update_function = "nat \<times> vname aexp"

text_raw\<open>\snip{transitiontype}{1}{2}{%\<close>
record transition =
  Label :: String.literal
  Arity :: nat
  Guards :: "guard list"
  Outputs :: "output_function list"
  Updates :: "update_function list"
text_raw\<open>}%endsnip\<close>

definition same_structure :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "same_structure t1 t2 = (
    Label t1 = Label t2 \<and>
    Arity t1 = Arity t2 \<and>
    length (Outputs t1) = length (Outputs t2)
  )"

definition enumerate_inputs :: "transition \<Rightarrow> nat set" where
  "enumerate_inputs t = (\<Union> (set (map enumerate_gexp_inputs (Guards t)))) \<union>
                        (\<Union> (set (map enumerate_aexp_inputs (Outputs t)))) \<union>
                        (\<Union> (set (map (\<lambda>(_, u). enumerate_aexp_inputs u) (Updates t))))"

definition max_input :: "transition \<Rightarrow> nat option" where
  "max_input t = (if enumerate_inputs t = {} then None else Some (Max (enumerate_inputs t)))"

definition total_max_input :: "transition \<Rightarrow> nat" where
  "total_max_input t = (case max_input t of None \<Rightarrow> 0 | Some a \<Rightarrow> a)"

definition enumerate_regs :: "transition \<Rightarrow> nat set" where
  "enumerate_regs t = (\<Union> (set (map GExp.enumerate_regs (Guards t)))) \<union>
                      (\<Union> (set (map AExp.enumerate_regs (Outputs t)))) \<union>
                      (\<Union> (set (map (\<lambda>(_, u). AExp.enumerate_regs u) (Updates t)))) \<union>
                      (\<Union> (set (map (\<lambda>(r, _). AExp.enumerate_regs (V (R r))) (Updates t))))"

definition max_reg :: "transition \<Rightarrow> nat option" where
  "max_reg t = (if enumerate_regs t = {} then None else Some (Max (enumerate_regs t)))"

definition total_max_reg :: "transition \<Rightarrow> nat" where
  "total_max_reg t = (case max_reg t of None \<Rightarrow> 0 | Some a \<Rightarrow> a)"

definition enumerate_ints :: "transition \<Rightarrow> int set" where
  "enumerate_ints t = (\<Union> (set (map enumerate_gexp_ints (Guards t)))) \<union>
                      (\<Union> (set (map enumerate_aexp_ints (Outputs t)))) \<union>
                      (\<Union> (set (map (\<lambda>(_, u). enumerate_aexp_ints u) (Updates t)))) \<union>
                      (\<Union> (set (map (\<lambda>(r, _). enumerate_aexp_ints (V (R r))) (Updates t))))"

definition valid_transition :: "transition \<Rightarrow> bool" where
  "valid_transition t = (\<forall>i \<in> enumerate_inputs t. i < Arity t)"

definition can_take :: "nat \<Rightarrow> vname gexp list \<Rightarrow> inputs \<Rightarrow> registers \<Rightarrow> bool" where
  "can_take a g i r = (length i = a \<and> apply_guards g (join_ir i r))"

lemma can_take_empty [simp]: "length i = a \<Longrightarrow> can_take a [] i c"
  by (simp add: can_take_def)

lemma can_take_subset_append:
  assumes "set (Guards t) \<subseteq> set (Guards t')"
  shows "can_take a (Guards t @ Guards t') i c = can_take a (Guards t') i c"
  using assms
  by (simp add: apply_guards_subset_append can_take_def)

definition "can_take_transition t i r = can_take (Arity t) (Guards t) i r"

lemmas can_take = can_take_def can_take_transition_def

lemma can_take_transition_empty_guard:
  "Guards t = [] \<Longrightarrow> \<exists>i. can_take_transition t i c"
  by (simp add: can_take_transition_def can_take_def Ex_list_of_length)

lemma can_take_subset: "length i = Arity t \<Longrightarrow>
   Arity t = Arity t' \<Longrightarrow>
   set (Guards t') \<subseteq> set (Guards t) \<Longrightarrow>
   can_take_transition t i r \<Longrightarrow>
   can_take_transition t' i r"
  by (simp add: can_take_transition_def can_take_def apply_guards_subset)

lemma valid_list_can_take:
  "\<forall>g \<in> set (Guards t). valid g \<Longrightarrow> \<exists>i. can_take_transition t i c"
  by (simp add: can_take_transition_def can_take_def apply_guards_def valid_def Ex_list_of_length)

lemma cant_take_if:
  "\<exists>g \<in> set (Guards t). gval g (join_ir i r) \<noteq> true \<Longrightarrow>
   \<not> can_take_transition t i r"
  using apply_guards_cons apply_guards_rearrange can_take_def can_take_transition_def by blast

definition apply_outputs :: "'a aexp list \<Rightarrow> 'a datastate \<Rightarrow> value option list" where
  "apply_outputs p s = map (\<lambda>p. aval p s) p"

abbreviation "evaluate_outputs t i r \<equiv> apply_outputs (Outputs t) (join_ir i r)"

lemma apply_outputs_nth:
  "i < length p \<Longrightarrow> apply_outputs p s ! i = aval (p ! i) s"
  by (simp add: apply_outputs_def)

lemmas apply_outputs = datastate apply_outputs_def value_plus_def value_minus_def value_times_def

lemma apply_outputs_empty [simp]: "apply_outputs [] s = []"
  by (simp add: apply_outputs_def)

lemma apply_outputs_preserves_length: "length (apply_outputs p s) = length p"
  by (simp add: apply_outputs_def)

lemma apply_outputs_literal: assumes "P ! r = L v"
      and "r < length P"
    shows "apply_outputs P s ! r = Some v"
  by (simp add: assms apply_outputs_nth)

lemma apply_outputs_register: assumes "r < length P"
  shows "apply_outputs (list_update P r (V (R p))) (join_ir i c) ! r = c $ p"
  by (metis apply_outputs_nth assms aval.simps(2) join_ir_R length_list_update nth_list_update_eq)

lemma apply_outputs_unupdated: assumes "ia \<noteq> r"
      and "ia < length P"
    shows "apply_outputs P j ! ia = apply_outputs (list_update P r v)j ! ia"
  by (metis apply_outputs_nth assms(1) assms(2) length_list_update nth_list_update_neq)

definition apply_updates :: "update_function list \<Rightarrow> vname datastate \<Rightarrow> registers \<Rightarrow> registers" where
  "apply_updates u old = fold (\<lambda>h r. r(fst h $:= aval (snd h) old)) u"

abbreviation "evaluate_updates t i r \<equiv> apply_updates (Updates t) (join_ir i r) r"

lemma apply_updates_cons: "ra \<noteq> r \<Longrightarrow>
       apply_updates u (join_ir ia c) c $ ra = apply_updates ((r, a) # u) (join_ir ia c) c $ ra"
proof(induct u rule: rev_induct)
  case Nil
  then show ?case
    by (simp add: apply_updates_def)
next
  case (snoc u us)
  then show ?case
    apply (cases u)
    apply (simp add: apply_updates_def)
    by (case_tac "ra = aa", auto)
qed

lemma update_twice:
  "apply_updates [(r, a), (r, b)] s regs = regs (r $:= aval b s)"
  by (simp add: apply_updates_def)

lemma r_not_updated_stays_the_same:
  "r \<notin> fst ` set U \<Longrightarrow> apply_updates U c d $ r = d $ r"
  using apply_updates_def
  by (induct U rule: rev_induct, auto)

definition rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> transition \<Rightarrow> transition" where
  "rename_regs f t = t\<lparr>
      Guards  := map (GExp.rename_regs f) (Guards t),
      Outputs := map (AExp.rename_regs f) (Outputs t),
      Updates := map (\<lambda>(r, u). (f r, AExp.rename_regs f u)) (Updates t)
    \<rparr>"

definition eq_upto_rename_strong :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "eq_upto_rename_strong t1 t2 = (\<exists>f. bij f \<and> rename_regs f t1 = t2)"

inductive eq_upto_rename :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "Label t1 = Label t2 \<Longrightarrow>
   Arity t2 = Arity t2 \<Longrightarrow>
   apply_guards (map (GExp.rename_regs f) (Guards t1)) = apply_guards (Guards t2) \<Longrightarrow>

   apply_outputs (map (AExp.rename_regs f) (Outputs t1)) = apply_outputs (Outputs t2) \<Longrightarrow>

   apply_updates (map (\<lambda>(r, u). (f r, AExp.rename_regs f u)) (Updates t1)) = apply_updates (Updates t2) \<Longrightarrow>

   eq_upto_rename t1 t2"

end


(*  Title:      ZF/Induct/Ntree.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* Datatype definition n-ary branching trees *}

theory Ntree imports Main begin

text {*
  Demonstrates a simple use of function space in a datatype
  definition.  Based upon theory @{text Term}.
*}

consts
  ntree :: "i => i"
  maptree :: "i => i"
  maptree2 :: "[i, i] => i"

datatype "ntree(A)" = Branch ("a \<in> A", "h \<in> (\<Union>n \<in> nat. n -> ntree(A))")
  monos UN_mono [OF subset_refl Pi_mono]  -- {* MUST have this form *}
  type_intros nat_fun_univ [THEN subsetD]
  type_elims UN_E

datatype "maptree(A)" = Sons ("a \<in> A", "h \<in> maptree(A) -||> maptree(A)")
  monos FiniteFun_mono1  -- {* Use monotonicity in BOTH args *}
  type_intros FiniteFun_univ1 [THEN subsetD]

datatype "maptree2(A, B)" = Sons2 ("a \<in> A", "h \<in> B -||> maptree2(A, B)")
  monos FiniteFun_mono [OF subset_refl]
  type_intros FiniteFun_in_univ'

definition
  ntree_rec :: "[[i, i, i] => i, i] => i"  where
  "ntree_rec(b) ==
    Vrecursor(\<lambda>pr. ntree_case(\<lambda>x h. b(x, h, \<lambda>i \<in> domain(h). pr`(h`i))))"

definition
  ntree_copy :: "i => i"  where
  "ntree_copy(z) == ntree_rec(\<lambda>x h r. Branch(x,r), z)"

text {*
  \medskip @{text ntree}
*}

lemma ntree_unfold: "ntree(A) = A \<times> (\<Union>n \<in> nat. n -> ntree(A))"
  by (blast intro: ntree.intros [unfolded ntree.con_defs]
    elim: ntree.cases [unfolded ntree.con_defs])

lemma ntree_induct [consumes 1, case_names Branch, induct set: ntree]:
  assumes t: "t \<in> ntree(A)"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  \<forall>i \<in> n. P(h`i)
      |] ==> P(Branch(x,h))"
  shows "P(t)"
  -- {* A nicer induction rule than the standard one. *}
  using t
  apply induct
  apply (erule UN_E)
  apply (assumption | rule step)+
   apply (fast elim: fun_weaken_type)
  apply (fast dest: apply_type)
  done

lemma ntree_induct_eqn [consumes 1]:
  assumes t: "t \<in> ntree(A)"
    and f: "f \<in> ntree(A)->B"
    and g: "g \<in> ntree(A)->B"
    and step: "!!x n h. [| x \<in> A;  n \<in> nat;  h \<in> n -> ntree(A);  f O h = g O h |] ==>
      f ` Branch(x,h) = g ` Branch(x,h)"
  shows "f`t=g`t"
  -- {* Induction on @{term "ntree(A)"} to prove an equation *}
  using t
  apply induct
  apply (assumption | rule step)+
  apply (insert f g)
  apply (rule fun_extension)
  apply (assumption | rule comp_fun)+
  apply (simp add: comp_fun_apply)
  done

text {*
  \medskip Lemmas to justify using @{text Ntree} in other recursive
  type definitions.
*}

lemma ntree_mono: "A \<subseteq> B ==> ntree(A) \<subseteq> ntree(B)"
  apply (unfold ntree.defs)
  apply (rule lfp_mono)
    apply (rule ntree.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemma ntree_univ: "ntree(univ(A)) \<subseteq> univ(A)"
  -- {* Easily provable by induction also *}
  apply (unfold ntree.defs ntree.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (blast intro: Pair_in_univ nat_fun_univ [THEN subsetD])
  done

lemma ntree_subset_univ: "A \<subseteq> univ(B) ==> ntree(A) \<subseteq> univ(B)"
  by (rule subset_trans [OF ntree_mono ntree_univ])

text {*
  \medskip @{text ntree} recursion.
*}

lemma ntree_rec_Branch:
    "function(h) ==>
     ntree_rec(b, Branch(x,h)) = b(x, h, \<lambda>i \<in> domain(h). ntree_rec(b, h`i))"
  apply (rule ntree_rec_def [THEN def_Vrecursor, THEN trans])
  apply (simp add: ntree.con_defs rank_pair2 [THEN [2] lt_trans] rank_apply)
  done

lemma ntree_copy_Branch [simp]:
    "function(h) ==>
     ntree_copy (Branch(x, h)) = Branch(x, \<lambda>i \<in> domain(h). ntree_copy (h`i))"
  by (simp add: ntree_copy_def ntree_rec_Branch)

lemma ntree_copy_is_ident: "z \<in> ntree(A) ==> ntree_copy(z) = z"
  by (induct z set: ntree)
    (auto simp add: domain_of_fun Pi_Collect_iff fun_is_function)

text {*
  \medskip @{text maptree}
*}

lemma maptree_unfold: "maptree(A) = A \<times> (maptree(A) -||> maptree(A))"
  by (fast intro!: maptree.intros [unfolded maptree.con_defs]
    elim: maptree.cases [unfolded maptree.con_defs])

lemma maptree_induct [consumes 1, induct set: maptree]:
  assumes t: "t \<in> maptree(A)"
    and step: "!!x n h. [| x \<in> A;  h \<in> maptree(A) -||> maptree(A);
                  \<forall>y \<in> field(h). P(y)
               |] ==> P(Sons(x,h))"
  shows "P(t)"
  -- {* A nicer induction rule than the standard one. *}
  using t
  apply induct
  apply (assumption | rule step)+
  apply (erule Collect_subset [THEN FiniteFun_mono1, THEN subsetD])
  apply (drule FiniteFun.dom_subset [THEN subsetD])
  apply (drule Fin.dom_subset [THEN subsetD])
  apply fast
  done

text {*
  \medskip @{text maptree2}
*}

lemma maptree2_unfold: "maptree2(A, B) = A \<times> (B -||> maptree2(A, B))"
  by (fast intro!: maptree2.intros [unfolded maptree2.con_defs]
    elim: maptree2.cases [unfolded maptree2.con_defs])

lemma maptree2_induct [consumes 1, induct set: maptree2]:
  assumes t: "t \<in> maptree2(A, B)"
    and step: "!!x n h. [| x \<in> A;  h \<in> B -||> maptree2(A,B);  \<forall>y \<in> range(h). P(y)
               |] ==> P(Sons2(x,h))"
  shows "P(t)"
  using t
  apply induct
  apply (assumption | rule step)+
   apply (erule FiniteFun_mono [OF subset_refl Collect_subset, THEN subsetD])
   apply (drule FiniteFun.dom_subset [THEN subsetD])
   apply (drule Fin.dom_subset [THEN subsetD])
   apply fast
   done

end


(*  File:       Plurality_Module.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Plurality Module\<close>

theory Plurality_Module
  imports "Component_Types/Electoral_Module"
begin

text \<open>
  The plurality module implements the plurality voting rule.
  The plurality rule elects all modules with the maximum amount of top
  preferences among all alternatives, and rejects all the other alternatives.
  It is electing and induces the classical plurality (voting) rule
  from social-choice theory.
\<close>

subsection \<open>Definition\<close>

fun plurality :: "'a Electoral_Module" where
  "plurality A p =
    ({a \<in> A. \<forall>x \<in> A. win_count p x \<le> win_count p a},
     {a \<in> A. \<exists>x \<in> A. win_count p x > win_count p a},
     {})"

subsection \<open>Soundness\<close>

theorem plurality_sound[simp]: "electoral_module plurality"
proof (unfold electoral_module_def, safe)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  have disjoint:
    "let elect = {a \<in> (A::'a set). \<forall> x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists> x \<in> A. win_count p a < win_count p x} in
    disjoint3 (elect, reject, {})"
    by auto
  have
    "let elect = {a \<in> (A::'a set). \<forall> x \<in> A. win_count p x \<le> win_count p a};
      reject = {a \<in> A. \<exists> x \<in> A. win_count p a < win_count p x} in
    elect \<union> reject = A"
    using not_le_imp_less
    by auto
  with disjoint
  show "well_formed A (plurality A p)"
    by simp
qed

subsection \<open>Electing\<close>

lemma plurality_electing2: "\<forall> A p.
                              (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow>
                                elect plurality A p \<noteq> {}"
proof (clarify)
  fix
    A :: "'a set" and
    p :: "'a Profile"
  assume
    A_non_empty: "A \<noteq> {}" and
    fin_A: "finite A" and
    prof_p: "profile A p" and
    plurality_elect_none: "elect plurality A p = {}"
  obtain max where
    max: "max = Max (win_count p ` A)"
    by simp
  then obtain a where
    a: "win_count p a = max \<and> a \<in> A"
    using Max_in A_non_empty fin_A empty_is_image
          finite_imageI imageE
    by (metis (no_types, lifting))
  hence "\<forall> x \<in> A. win_count p x \<le> win_count p a"
    using A_non_empty fin_A max
    by simp
  moreover have "a \<in> A"
    using a
    by simp
  ultimately have
    "a \<in> {a \<in> A. \<forall> x \<in> A. win_count p x \<le> win_count p a}"
    by blast
  hence "a \<in> elect plurality A p"
    by simp
  thus False
    using plurality_elect_none all_not_in_conv
    by metis
qed

text \<open>
  The plurality module is electing.
\<close>

theorem plurality_electing[simp]: "electing plurality"
proof (unfold electing_def, safe)
  show "electoral_module plurality"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    x :: "'a"
  assume
    fin_A: "finite A" and
    prof_p: "profile A p" and
    elect_none: "elect plurality A p = {}" and
    x_in_A: "x \<in> A"
  have "\<forall> A p. (A \<noteq> {} \<and> finite_profile A p) \<longrightarrow> elect plurality A p \<noteq> {}"
    using plurality_electing2
    by simp
  hence empty_A: "A = {}"
    using fin_A prof_p elect_none
    by (metis (no_types))
  thus "x \<in> {}"
    using x_in_A
    by simp
qed

subsection \<open>Property\<close>

lemma plurality_inv_mono2: "\<forall> A p q a.
                              (a \<in> elect plurality A p \<and> lifted A p q a) \<longrightarrow>
                                (elect plurality A q = elect plurality A p \<or>
                                    elect plurality A q = {a})"
proof (intro allI impI)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume elect_and_lift_a: "a \<in> elect plurality A p \<and> lifted A p q a"
  have ab1: "\<forall> a b. (a::'a) \<notin> {b} \<or> a = b"
    by force
  have lifted_winner:
    "\<forall> x \<in> A.
      \<forall> i::nat. i < length p \<longrightarrow>
        (above (p!i) x = {x} \<longrightarrow>
          (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
    using elect_and_lift_a lifted_above_winner
    unfolding Profile.lifted_def
    by (metis (no_types, lifting))
  hence
    "\<forall> i::nat. i < length p \<longrightarrow>
      (above (p!i) a = {a} \<longrightarrow> above (q!i) a = {a})"
    using elect_and_lift_a
    by auto
  hence a_win_subset:
    "{i::nat. i < length p \<and> above (p!i) a = {a}} \<subseteq>
      {i::nat. i < length p \<and> above (q!i) a = {a}}"
    by blast
  moreover have sizes: "length p = length q"
    using elect_and_lift_a
    unfolding Profile.lifted_def
    by metis
  ultimately have win_count_a:
    "win_count p a \<le> win_count q a"
    by (simp add: card_mono)
  have fin_A: "finite A"
    using elect_and_lift_a
    unfolding Profile.lifted_def
    by metis
  hence
    "\<forall> x \<in> A - {a}.
      \<forall> i::nat. i < length p \<longrightarrow>
        (above (q!i) a = {a} \<longrightarrow> above (q!i) x \<noteq> {x})"
    using DiffE above_one2 elect_and_lift_a insertCI insert_absorb insert_not_empty sizes
    unfolding Profile.lifted_def profile_def
    by metis
  with lifted_winner
  have above_QtoP:
    "\<forall> x \<in> A - {a}.
      \<forall> i::nat. i < length p \<longrightarrow>
        (above (q!i) x = {x} \<longrightarrow> above (p!i) x = {x})"
    using lifted_above_winner3 elect_and_lift_a
    unfolding Profile.lifted_def
    by metis
  hence
    "\<forall> x \<in> A - {a}.
      {i::nat. i < length p \<and> above (q!i) x = {x}} \<subseteq>
        {i::nat. i < length p \<and> above (p!i) x = {x}}"
    by (simp add: Collect_mono)
  hence win_count_other:
    "\<forall> x \<in> A - {a}. win_count p x \<ge> win_count q x"
    by (simp add: card_mono sizes)
  show
    "elect plurality A q = elect plurality A p \<or>
      elect plurality A q = {a}"
  proof cases
    assume "win_count p a = win_count q a"
    hence
      "card {i::nat. i < length p \<and> above (p!i) a = {a}} =
        card {i::nat. i < length p \<and> above (q!i) a = {a}}"
      using sizes
      by simp
    moreover have
      "finite {i::nat. i < length p \<and> above (q!i) a = {a}}"
      by simp
    ultimately have
      "{i::nat. i < length p \<and> above (p!i) a = {a}} =
        {i::nat. i < length p \<and> above (q!i) a = {a}}"
      using a_win_subset
      by (simp add: card_subset_eq)
    hence above_pq:
      "\<forall> i::nat. i < length p \<longrightarrow>
        above (p!i) a = {a} \<longleftrightarrow> above (q!i) a = {a}"
      by blast
    hence above_pq2:
      "\<forall> n. \<not> n < length p \<or>
        (above (p!n) a = {a}) = (above (q!n) a = {a})"
      by presburger
    moreover have
      "\<forall> x \<in> A - {a}.
        \<forall> i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow>
            (above (q!i) x = {x} \<or> above (q!i) a = {a}))"
      using lifted_winner
      by auto
    moreover have
      "\<forall> x \<in> A - {a}.
        \<forall> i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (p!i) a \<noteq> {a})"
    proof (rule ccontr, simp, safe, simp)
      fix
        x :: "'a" and
        i :: "nat"
      assume
        x_in_A: "x \<in> A" and
        i_in_range: "i < length p" and
        abv_x: "above (p!i) x = {x}" and
        abv_a: "above (p!i) a = {a}"
      have not_empty: "A \<noteq> {}"
        using x_in_A
        by auto
      have "linear_order_on A (p!i)"
        using elect_and_lift_a i_in_range
        unfolding Profile.lifted_def profile_def
        by simp
      thus "x = a"
        using not_empty abv_a abv_x fin_A above_one2
        by metis
    qed
    ultimately have above_PtoQ:
      "\<forall> x \<in> A - {a}.
        \<forall> i::nat. i < length p \<longrightarrow>
          (above (p!i) x = {x} \<longrightarrow> above (q!i) x = {x})"
      by simp
    hence
      "\<forall> x \<in> A.
        card {i::nat. i < length p \<and> above (p!i) x = {x}} =
          card {i::nat. i < length q \<and> above (q!i) x = {x}}"
    proof (safe)
      fix x :: "'a"
      assume
        "\<forall> y \<in> A - {a}. \<forall> i < length p.
          above (p!i) y = {y} \<longrightarrow> above (q!i) y = {y}" and
        x_in_A: "x \<in> A"
      show
        "card {i. i < length p \<and> above (p!i) x = {x}} =
          card {i. i < length q \<and> above (q!i) x = {x}}"
        using DiffI x_in_A ab1 above_PtoQ above_QtoP above_pq2 sizes
        by (metis (no_types, lifting))
    qed
    hence "\<forall> x \<in> A. win_count p x = win_count q x"
      by simp
    hence
      "{a \<in> A. \<forall> x \<in> A. win_count p x \<le> win_count p a} =
        {a \<in> A. \<forall> x \<in> A. win_count q x \<le> win_count q a}"
      by auto
    thus ?thesis
      by simp
  next
    assume "win_count p a \<noteq> win_count q a"
    hence strict_less:
      "win_count p a < win_count q a"
      using win_count_a
      by simp
    have a_in_win_p:
      "a \<in> {a \<in> A. \<forall> x \<in> A. win_count p x \<le> win_count p a}"
      using elect_and_lift_a
      by simp
    hence "\<forall> x \<in> A. win_count p x \<le> win_count p a"
      by simp
    with strict_less win_count_other
    have less:
      "\<forall> x \<in> A - {a}. win_count q x < win_count q a"
      using DiffD1 antisym dual_order.trans
            not_le_imp_less win_count_a
      by metis
    hence
      "\<forall> x \<in> A - {a}. \<not>(\<forall>y \<in> A. win_count q y \<le> win_count q x)"
      using elect_and_lift_a not_le
      unfolding Profile.lifted_def
      by metis
    hence
      "\<forall> x \<in> A - {a}.
        x \<notin> {a \<in> A. \<forall> x \<in> A. win_count q x \<le> win_count q a}"
      by blast
    hence
      "\<forall> x \<in> A - {a}. x \<notin> elect plurality A q"
      by simp
    moreover have
      "a \<in> elect plurality A q"
    proof -
      from less
      have
        "\<forall> x \<in> A - {a}. win_count q x \<le> win_count q a"
        using less_imp_le
        by metis
      moreover have
        "win_count q a \<le> win_count q a"
        by simp
      ultimately have
        "\<forall> x \<in> A. win_count q x \<le> win_count q a"
        by auto
      moreover have
        "a \<in> A"
        using a_in_win_p
        by simp
      ultimately have
        "a \<in> {a \<in> A.
            \<forall> x \<in> A. win_count q x \<le> win_count q a}"
        by simp
      thus ?thesis
        by simp
    qed
    moreover have
      "elect plurality A q \<subseteq> A"
      by simp
    ultimately show ?thesis
      by auto
  qed
qed

text \<open>
  The plurality rule is invariant-monotone.
\<close>

theorem plurality_inv_mono[simp]: "invariant_monotonicity plurality"
proof (unfold invariant_monotonicity_def, intro conjI impI allI)
  show "electoral_module plurality"
    by simp
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    q :: "'a Profile" and
    a :: "'a"
  assume "a \<in> elect plurality A p \<and> Profile.lifted A p q a"
  thus "elect plurality A q = elect plurality A p \<or> elect plurality A q = {a}"
    using plurality_inv_mono2
    by metis
qed

end