(*  Title:        C2KA Behaviour Structure (Concurrent Kleene Algebra)
    Author:       Maxime Buyse <maxime.buyse at polytechnique.edu>, 2019
    Maintainers:  Maxime Buyse <maxime.buyse at polytechnique.edu> and Jason Jaskolka <jason.jaskolka at carleton.ca>
*)

section \<open>Behaviour Structure \label{sec:behaviour_structure}\<close>

text \<open>
Hoare et al.~\cite{Hoare2011aa} presented the framework of Concurrent Kleene Algebra (\CKAabbrv) which captures the concurrent
behaviour of agents. The framework of \CKAabbrv is adopted to describe agent behaviours in distributed
systems. For a \CKAabbrv~$\CKAstructure$,~$\CKAset$ is a set of possible behaviours. The operator~$+$ is
interpreted as a choice between two behaviours, the operator~$\CKAseq$ is interpreted as a sequential
composition of two behaviours, and the operator~$\CKApar$ is interpreted as a parallel composition of
two behaviours. The operators~$\CKAiterSeq{\,}$ and~$\CKAiterPar{\,}$ are interpreted as a finite sequential
iteration and a finite parallel iteration of behaviours, respectively. The element~$0$ represents the
behaviour of the \emph{inactive agent} and the element~$1$ represents the behaviour of the \emph{idle agent}.
Associated with a \CKAabbrv~$\cka$ is a natural ordering relation~$\CKAle$ related to the semirings upon which the
\CKAabbrv is built which is called the sub-behaviour relation. For behaviours~$a,b \in \CKAset$, we
write~$a \CKAle b$ and say that~$a$ is a sub-behaviour of~$b$ if and only if~$a + b = b$.
\<close>

theory CKA
  imports Main
begin

no_notation
rtrancl ("(_\<^sup>*)" [1000] 999)

notation
times (infixl "*" 70)
and less_eq  ("'(\<le>\<^sub>\<K>')")
and less_eq  ("(_/ \<le>\<^sub>\<K> _)"  [51, 51] 50)

text \<open>
The class \emph{cka} contains an axiomatisation of Concurrent Kleene Algebras and a selection of useful theorems.\<close>

class join_semilattice = ordered_ab_semigroup_add +
  assumes leq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and le_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
  and add_idem [simp]: "x + x = x"
begin

lemma inf_add_K_right: "a \<le>\<^sub>\<K> a + b"
  unfolding leq_def
  by (simp add:  add_assoc[symmetric])

lemma inf_add_K_left: "a \<le>\<^sub>\<K> b + a"
  by (simp only: add_commute, fact inf_add_K_right)

end

class dioid = semiring + one + zero + join_semilattice +
  assumes par_onel [simp]: "1 * x = x"
  and par_oner [simp]: "x * 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 * x = 0"
  and annir [simp]: "x * 0 = 0"

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>*" [101] 100)
  assumes star_unfoldl: "1 + x * x\<^sup>* \<le>\<^sub>\<K> x\<^sup>*"
  and star_unfoldr: "1 + x\<^sup>* * x \<le>\<^sub>\<K> x\<^sup>*"
  and star_inductl: "z + x * y \<le>\<^sub>\<K> y \<Longrightarrow> x\<^sup>* * z \<le>\<^sub>\<K> y"
  and star_inductr: "z + y * x \<le>\<^sub>\<K> y \<Longrightarrow> z * x\<^sup>* \<le>\<^sub>\<K> y"

class cka = kleene_algebra +
  fixes seq :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl ";" 70)
  and seqstar :: "'a \<Rightarrow> 'a" ("_\<^sup>;" [101] 100)
  assumes seq_assoc: "x ; (y ; z) = (x ; y) ; z"
  and seq_rident [simp]: "x ; 1 = x"
  and seq_lident [simp]: "1 ; x = x"
  and seq_rdistrib [simp]: "(x + y);z = x;z + y;z"
  and seq_ldistrib [simp]: "x;(y + z) = x;y + x;z"
  and seq_annir [simp]: "x ; 0 = 0"
  and seq_annil [simp]: "0 ; x = 0"
  and seqstar_unfoldl: "1 + x ; x\<^sup>; \<le>\<^sub>\<K> x\<^sup>;"
  and seqstar_unfoldr: "1 + x\<^sup>; ; x \<le>\<^sub>\<K> x\<^sup>;"
  and seqstar_inductl: "z + x ; y \<le>\<^sub>\<K> y \<Longrightarrow> x\<^sup>; ; z \<le>\<^sub>\<K> y"
  and seqstar_inductr: "z + y ; x \<le>\<^sub>\<K> y \<Longrightarrow> z ; x\<^sup>; \<le>\<^sub>\<K> y"
  and exchange: "(a*b) ; (c*d) \<le>\<^sub>\<K> (b;c) * (a;d)"
begin

interpretation cka: kleene_algebra plus less_eq less "1" "0" seq seqstar
  by (unfold_locales, simp_all add: seq_assoc seqstar_unfoldl seqstar_unfoldr seqstar_inductl seqstar_inductr)

lemma par_comm: "a * b = b * a"
proof -
  have "(b*a) ; (1*1) \<le>\<^sub>\<K> (a;1) * (b;1)" by (simp only:  exchange)
  hence "b * a \<le>\<^sub>\<K> a * b" by (simp)
  hence "a * b \<le>\<^sub>\<K> b * a \<longleftrightarrow> a * b  = b * a" by (rule antisym_conv)
  moreover have "a * b \<le>\<^sub>\<K> b * a" proof -
  have "(a*b) ; (1*1) \<le>\<^sub>\<K> (b;1) * (a;1)" by (rule  exchange)
    thus ?thesis  by (simp)
  qed
  ultimately show ?thesis by (auto)
qed

lemma exchange_2: "(a*b) ; (c*d) \<le>\<^sub>\<K> (a;c) * (b;d)"
proof -
  have "(b*a) ; (c*d) \<le>\<^sub>\<K> (a;c) * (b;d)" by (rule exchange)
  thus ?thesis by (simp add: par_comm)
qed

lemma seq_inf_par: "a ; b \<le>\<^sub>\<K> a * b"
proof -
  have "(1*a) ; (1*b) \<le>\<^sub>\<K> (a;1) * (1;b)" by (rule exchange)
  thus ?thesis by simp
qed

lemma add_seq_inf_par: "a;b + b;a \<le>\<^sub>\<K> a*b"
proof -
  have "a;b \<le>\<^sub>\<K> a*b" by (rule seq_inf_par)
  moreover have "b;a \<le>\<^sub>\<K> b*a" by (rule seq_inf_par)
  ultimately have "a;b + b;a \<le>\<^sub>\<K> a*b + b*a" by (simp add: add_mono)
  thus ?thesis by (simp add: par_comm)
qed

lemma exchange_3: "(a*b) ; c \<le>\<^sub>\<K> a * (b;c)"
proof -
  have "(a*b) ; (1*c) \<le>\<^sub>\<K> (a;1) * (b;c)" by (rule exchange_2)
  thus ?thesis by simp
qed

lemma exchange_4: "a ; (b*c) \<le>\<^sub>\<K> (a;b) * c"
proof -
  have "(1*a) ; (b*c) \<le>\<^sub>\<K> (a;b) * (1;c)" by (rule exchange)
  thus ?thesis by simp
qed

lemma seqstar_inf_parstar: "a\<^sup>; \<le>\<^sub>\<K> a\<^sup>*"
proof -
  have "a ; a\<^sup>* \<le>\<^sub>\<K> a * a\<^sup>*" by (rule seq_inf_par)
  hence "1 + a ; a\<^sup>* \<le>\<^sub>\<K> 1 + a * a\<^sup>*" by (simp add: add_left_mono)
  hence "1 + a ; a\<^sup>* \<le>\<^sub>\<K> a\<^sup>*" by (simp add: star_unfoldl order_trans)
  hence "a\<^sup>; ; 1 \<le>\<^sub>\<K> a\<^sup>*" by (rule seqstar_inductl)
  thus ?thesis by simp
qed

end

end


theory Examples3
imports Examples
begin

subsection \<open>Third Version: Local Interpretation
  \label{sec:local-interpretation}\<close>

text \<open>In the above example, the fact that \<^term>\<open>(\<le>)\<close> is a partial
  order for the integers was used in the second goal to
  discharge the premise in the definition of \<open>(\<sqsubset>)\<close>.  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.\<close>

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

text \<open>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 \<open>int.less_def\<close> 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.\<close>

subsection \<open>Further Interpretations\<close>

text \<open>Further interpretations are necessary for
  the other locales.  In \<open>lattice\<close> the operations~\<open>\<sqinter>\<close>
  and~\<open>\<squnion>\<close> are substituted by \<^term>\<open>min :: int \<Rightarrow> int \<Rightarrow> int\<close>
  and \<^term>\<open>max :: int \<Rightarrow> int \<Rightarrow> int\<close>.  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.\<close>

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

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

text \<open>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 \<open>partial_order\<close>: \\
  \quad @{thm int.less_def} \\
  @{thm [source] int.meet_left} from locale \<open>lattice\<close>: \\
  \quad @{thm int.meet_left} \\
  @{thm [source] int.join_distr} from locale \<open>distrib_lattice\<close>: \\
  \quad @{thm int.join_distr} \\
  @{thm [source] int.less_total} from locale \<open>total_order\<close>: \\
  \quad @{thm int.less_total}
\end{tabular}
\end{center}
\hrule
\caption{Interpreted theorems for~\<open>\<le>\<close> on the integers.}
\label{tab:int-lattice}
\end{table}

\begin{itemize}
\item
  Locale \<open>distrib_lattice\<close> 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>\<open>(<)\<close> appears in theorem @{thm [source]
  int.less_total}
  although an equation for the replacement of \<open>(\<sqsubset>)\<close> was only
  given in the interpretation of \<open>partial_order\<close>.  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}
\<close>

text \<open>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>\<open>partial_order\<close>
  outputs the following:
\begin{small}
\begin{alltt}
  int : partial_order "(\(\le\))"
\end{alltt}
\end{small}
  Of course, there is only one interpretation.
  The interpretation qualifier on the left is mandatory.  Qualifiers
  can either be \emph{mandatory} or \emph{optional}.  Optional qualifiers
  are designated by ``?''.  Mandatory qualifiers must occur in
  name references while optional ones need not.  Mandatory qualifiers
  prevent accidental hiding of names, while optional qualifiers can be
  more convenient to use.  The default is mandatory.
\<close>

section \<open>Locale Expressions \label{sec:expressions}\<close>

text \<open>
  A map~\<^term>\<open>\<phi>\<close> between partial orders~\<open>\<sqsubseteq>\<close> and~\<open>\<preceq>\<close>
  is called order preserving if \<open>x \<sqsubseteq> y\<close> implies \<open>\<phi> x \<preceq>
  \<phi> y\<close>.  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: \<open>le\<close>~(\isakeyword{infixl}~\<open>\<sqsubseteq>\<close>) and \<open>le'\<close>~(\isakeyword{infixl}~\<open>\<preceq>\<close>) for the orders and~\<open>\<phi>\<close>
  for the map.

  In order to reuse the existing locale for partial orders, which has
  the single parameter~\<open>le\<close>, it must be imported twice, once
  mapping its parameter to~\<open>le\<close> from the new locale and once
  to~\<open>le'\<close>.  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, and unless designated with a
  ``?'' it must occur in name references.

  Since the parameters~\<open>le\<close> and~\<open>le'\<close> 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~\<open>\<phi>\<close> and the
  assumptions that it is order preserving complete the locale
  declaration.\<close>

  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) \<open>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 with
  \<^term>\<open>(\<sqsubseteq>)\<close>, there is none for the strict version of \<^term>\<open>(\<preceq>)\<close>.  The syntax \<open>\<sqsubset>\<close> for \<open>less\<close> is only
  available for the original instance it was declared for.  We may
  introduce infix syntax for \<open>le'.less\<close> with the following declaration:\<close>

  notation (in order_preserving) le'.less (infixl "\<prec>" 50)

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

text \<open>There are short notations for locale expressions.  These are
  discussed in the following.\<close>

subsection \<open>Default Instantiations\<close>

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

subsection \<open>Implicit Parameters \label{sec:implicit-parameters}\<close>

text \<open>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 \<open>partial_order\<close> 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}.
\<close>

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

  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 \<open>The parameter instantiation in the first instance of \<^term>\<open>lattice\<close> is omitted.  This causes the parameter~\<open>le\<close> to be
  added to the \isakeyword{for} clause, and the locale has
  parameters~\<open>le\<close>,~\<open>le'\<close> and, of course,~\<open>\<phi>\<close>.

  Before turning to the second example, we complete the locale by
  providing infix syntax for the meet and join operations of the
  second lattice.
\<close>

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

text \<open>The next example makes radical use of the short hand
  facilities.  A homomorphism is an endomorphism if both orders
  coincide.\<close>

  locale lattice_end = lattice_hom _ le

text \<open>The notation~\<open>_\<close> enables to omit a parameter in a
  positional instantiation.  The omitted parameter,~\<open>le\<close> becomes
  the parameter of the declared locale and is, in the following
  position, used to instantiate the second parameter of \<open>lattice_hom\<close>.  The effect is that of identifying the first in second
  parameter of the homomorphism locale.\<close>

text \<open>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 \<open>partial_order\<close> and \<open>lattice\<close> are imported by \<open>lattice_end\<close>.  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) {\<open>partial_order\<close>};
  \node (oh) at (1.5,-2) {\<open>order_preserving\<close>};
  \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) {\<open>lattice\<close>};
  \node (lh) at (0,-4) {\<open>lattice_hom\<close>};
  \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) {\<open>lattice_end\<close>};
  \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}
\<close>

text \<open>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:\<close>

  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) \<open>
  Theorems and other declarations --- syntax, in particular --- from
  the locale \<open>order_preserving\<close> are now active in \<open>lattice_hom\<close>, for example
  @{thm [source] hom_le}:
  @{thm [display, indent=2] hom_le}
  This theorem will be useful in the following section.
\<close>

section \<open>Conditional Interpretation\<close>

text \<open>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
  \<open>\<lambda>i. n * i\<close> that scales its argument by a constant factor.
  This function is order preserving (and even a lattice endomorphism)
  with respect to \<^term>\<open>(\<le>)\<close> provided \<open>n \<ge> 0\<close>.

  It is not possible to express this using a global interpretation,
  because it is in general unspecified whether~\<^term>\<open>n\<close> 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.\<close>

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

text \<open>It is again convenient to make the interpretation in an
  incremental fashion, first for order preserving maps, then for
  lattice endomorphisms.\<close>

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

text \<open>While the proof of the previous interpretation
  is straightforward from monotonicity lemmas for~\<^term>\<open>(*)\<close>, the
  second proof follows a useful pattern.\<close>

  sublocale %visible non_negative \<subseteq> lattice_end "(\<le>)" "\<lambda>i. n * i"
  proof (unfold_locales, unfold int_min_eq int_max_eq)
    txt \<open>\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>\<open>non_negative\<close>, that multiplication by~\<^term>\<open>n\<close> commutes with
      \<^term>\<open>min\<close> and \<^term>\<open>max\<close>.\<close>
  qed (auto simp: hom_le)

text (in order_preserving) \<open>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:\<close>

  lemmas (in order_preserving) hom_le [simp]

subsection \<open>Avoiding Infinite Chains of Interpretations
  \label{sec:infinite-chains}\<close>

text \<open>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:\<close>

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

text \<open>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>\<open>partial_order\<close> but serves to collect facts
  about functions spaces where the co-domain is a partial order, and
  to make the interpretation in its context:\<close>

  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 \<open>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:\<close>

  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 f.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 f.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 \<open>Further Reading\<close>

text \<open>More information on locales and their interpretation is
  available.  For the locale hierarchy of import and interpretation
  dependencies see~\<^cite>\<open>Ballarin2006a\<close>; interpretations in theories
  and proofs are covered in~\<^cite>\<open>Ballarin2006b\<close>.  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>\<open>HaftmannWenzel2007\<close> 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>\<open>HaftmannWenzel2009\<close>.

  The original work of Kammüller on locales~\<^cite>\<open>KammullerEtAl1999\<close>
  may be of interest from a historical perspective.  My previous
  report on locales and locale expressions~\<^cite>\<open>Ballarin2004a\<close>
  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>\<open>Chapter~8\<close> in Jacobson1985\<close>.

  The sources of this tutorial, which include all proofs, are
  available with the Isabelle distribution at
  \<^url>\<open>https://isabelle.in.tum.de\<close>.
\<close>

text \<open>
\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{?}''] \\[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{rewrites} \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}
\<close>

text \<open>\textbf{Revision History.}  The present fourth revision of the
  tutorial accommodates minor updates to the syntax of the locale commands
  and the handling of notation under morphisms introduced with Isabelle 2016.
  For the third revision of the tutorial, which corresponds to the published
  version, much of the explanatory text was rewritten.  Inheritance of
  interpretation equations was made available with Isabelle 2009-1.
  The second revision accommodates changes introduced by the locales
  reimplementation for Isabelle 2009.  Most notably locale expressions
  were generalised from renaming to instantiation.\<close>

text \<open>\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.\<close>

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009         |
            |                   June 2009  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2013         |
            |                   June 2013  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Trace
imports Infra
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (notick | t = <>)                  *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(***********************************************************

    Type Definitions
      'a event      : type of events      a,b,...
      'a trace      : type of traces      s,t,...

 ***********************************************************)

datatype 'a event = Ev 'a | Tick

definition
  Evset     :: "'a event set"
  where
  "Evset     == {a. a ~= Tick}"

definition
  EvsetTick :: "'a event set"
  where
  "EvsetTick == UNIV"

(* EvsetTick seems to be useless, but it sometimes *)
(* makes proofs to be readable.                    *)

(*------------------------------------*
 |              X-Symbols             |
 *------------------------------------*)
(*
notation (xsymbols) Tick ("\<surd>")
*)

(*******************************
    Evset contains all (Ev a)
 *******************************)

lemma Un_Evset[simp] : "Ev ` X Un Evset = Evset"
by (auto simp add: Evset_def)

(*******************************
         Tick or Ev a
 *******************************)

lemma event_Tick_or_Ev: "ALL e. e = Tick | (EX a. e = Ev a)"
apply (intro allI)
by (induct_tac e, auto)

lemma not_Tick_to_Ev: "(e ~= Tick) = (EX a. e = Ev a)"
apply (auto)
apply (insert event_Tick_or_Ev)
apply (drule_tac x="e" in spec)
by (simp)

lemma in_Ev_set : "(e : Ev ` X) = (EX a. (e = Ev a & a : X))"
by (auto)

lemma notin_Ev_set : "(e ~: Ev ` X) = (e = Tick | (EX a. (e = Ev a & a ~: X)))"
apply (insert event_Tick_or_Ev)
apply (drule_tac x="e" in spec)
by (auto)

(*******************************
             inj
 *******************************)

lemma inj_Ev[simp]: "inj Ev"
apply (simp add: inj_on_def)
done

(***********************************************************
                    Definition of traces
 ***********************************************************)

(* "typedef" requires defined types are not empty as follows: *)

definition "trace  = {ss::('a event list). Tick ~: set (butlast ss)}"

typedef 'a trace = "trace :: 'a event list set"
(* typedef 'a trace = "{ss::('a event list). Tick ~: set (butlast ss)}"  *)
apply (rule_tac x ="[]" in exI)
apply (simp add: trace_def)
done

declare Rep_trace         [simp]

(*****************************************************************
            directly convert from list to trace
 *****************************************************************)

(***********************************************************)
(*                  operators over traces                  *)
(*                                                         *)
(*    memo    (infixr "@t" 65) = ("_ @t _" [66,65] 65)     *)
(*                                                         *)
(***********************************************************)

definition
  nilt    :: "'a trace"                                ("<>")
  where "<>       == Abs_trace []"

definition
  sett    :: "'a trace => 'a event set"
  where  "sett s    == set (Rep_trace s)"

definition
  lengtht :: "'a trace => nat"
  where
  "lengtht s == length (Rep_trace s)"

definition
  noTick  :: "'a trace => bool"
  where
  "noTick s  == (Tick ~: sett s)"

definition
  hdt      :: "'a trace => 'a event"
  where
  hdt_def      : "hdt s      == hd (Rep_trace s)"

definition
  tlt      :: "'a trace => 'a trace"
  where
  tlt_def      : "tlt s      == Abs_trace (tl (Rep_trace s))"

definition
  lastt    :: "'a trace => 'a event"
  where
  lastt_def    : "lastt s    == last (Rep_trace s)"

definition
  butlastt :: "'a trace => 'a trace"
  where
  butlastt_def : "butlastt s == Abs_trace (butlast (Rep_trace s))"

syntax
  "@trace"   :: "args => 'a trace"                       ("<_>" [900] 1000)

translations
  "<s>"      == "CONST Abs_trace [s]"   (* "CONST" for isabelle2009-2 *)

(*** appending ***)

datatype TraceChk = tr_nil | tr_noTick | tr_Tick | tr_error

definition
  appt    :: "'a trace => 'a trace => 'a trace"      (infixr "^^^" 65)
  where
  appt_def    : "s ^^^ t    == Abs_trace (Rep_trace s @ Rep_trace t)"

(******** X-symbols ********)
(*
notation (xsymbols) nilt ("\<langle>\<rangle>")
notation (xsymbols) appt (infixr "\<frown>" 65)

syntax (output)
  "_traceX"     :: "args => 'a trace"                       ("<(_)>")

syntax (xsymbols)
  "_traceX"     :: "args => 'a trace"       ("\<langle>(_)\<rangle>" [900] 1000)

translations
  "\<langle>s\<rangle>"  == "<s>"
*)

(***********************************************************
                          lemmas
 ***********************************************************)

(***************************************
         trace Rep and Abs lemmas
 ***************************************)

(*** Abs-Rep ***)

lemma Abs_trace_Rep_trace_inverse_left:
  "t : trace ==> ((Abs_trace t = s) = (t = Rep_trace s))"
by (auto simp add: Abs_trace_inverse Rep_trace_inverse)

lemma Abs_trace_Rep_trace_inverse_right:
  "t : trace ==> ((s = Abs_trace t) = (t = Rep_trace s))"
by (auto simp add: Abs_trace_inverse Rep_trace_inverse)

lemmas Abs_trace_Rep_trace_inverse =
       Abs_trace_Rep_trace_inverse_left Abs_trace_Rep_trace_inverse_right

(*** Rep-Abs ***)

lemma Rep_trace_Abs_trace_inverse_left_only_if:
  "Rep_trace t = s ==> t = Abs_trace s"
by (auto simp add: Rep_trace_inverse)

lemma Rep_trace_Abs_trace_inverse_right_only_if:
  "s = Rep_trace t ==> t = Abs_trace s"
by (auto simp add: Rep_trace_inverse)

lemmas Rep_trace_Abs_trace_inverse_only_if =
           Rep_trace_Abs_trace_inverse_left_only_if
           Rep_trace_Abs_trace_inverse_right_only_if

(*** Abs image ***)

lemma Abs_trace_inverse_in_only_if:
  "[| ALL s:X. s : trace ; t : Abs_trace ` X |] ==> Rep_trace t : X"
apply (simp add: image_def, erule bexE)
apply (drule_tac x="x" in bspec, simp)
by (simp add: Abs_trace_inverse)

lemma Abs_trace_inverse_in_if:
  "Rep_trace t : X ==> t : Abs_trace ` X"
apply (simp add: image_def)
apply (rule_tac x="Rep_trace t" in bexI)
by (simp_all add: Rep_trace_inverse)

lemma Abs_trace_inverse_in:
  "[| ALL s:X. s : trace |]
       ==> (t : Abs_trace ` X) = (Rep_trace t : X)"
apply (rule iffI)
apply (simp add: Abs_trace_inverse_in_only_if)
by (simp add: Abs_trace_inverse_in_if)

(*******************************
         check in trace
 *******************************)

lemma nil_in_trace[simp] : "[] : trace"
by (simp add: trace_def)

lemma event_in_trace[simp] : "[a] : trace"
by (simp add: trace_def)

lemma notic_in_trace[simp] : "Tick ~: set s ==> s : trace"
by (simp add: trace_def notin_set_butlast)

(*--------------------------*
 |        decompo app       |
 *--------------------------*)

(*** decompo traces only if ***)

lemma decompo_app_in_trace_only_if1 : "s @ t : trace ==> s : trace"
apply (simp add: trace_def)
apply (simp add: notin_butlast_decompo)
apply (erule disjE)
by (simp_all add: notin_set_butlast)

lemma decompo_app_in_trace_only_if2 : "s @ t : trace ==> t : trace"
apply (simp add: trace_def)
apply (simp add: notin_butlast_decompo)
by (auto)

lemma decompo_app_in_trace_only_if :
  "s @ t : trace ==> (s : trace & t = []) | (Tick ~: set s & t : trace)"
apply (insert list_last_nil_or_unnil)
apply (drule_tac x="t" in spec)
apply (erule disjE)

 (* t = [] *)
 apply (simp)

 (* t = sa @ [a] *)
 apply (elim exE)
 apply (rule disjI2)
 apply (rule conjI)

 apply (simp add: trace_def)
 apply (simp add: notin_butlast_decompo)

 apply (rule decompo_app_in_trace_only_if2[of s])
 apply (simp)
done

(*** decompo traces if ***)

lemma decompo_app_in_trace_if :
  "[| Tick ~: set s ; t : trace |] ==> s @ t : trace"
by (simp add: trace_def notin_butlast_decompo)

(****** decompo traces iff ******)

lemma decompo_app_in_trace :
  "s @ t : trace = ((s : trace & t = []) | (Tick ~: set s & t : trace))"
apply (rule iffI)
apply (simp add: decompo_app_in_trace_only_if)
apply (erule disjE)
by (simp_all add: decompo_app_in_trace_if)

(*** erule for decomposing "s @ t : trace" in assumption ***)

lemma decompo_appt_in_traceE:
  "[| s @ t : trace ; [| s @ t : trace ; s : trace ; t : trace |] ==> R |]
    ==> R"
apply (simp add: decompo_app_in_trace)
by (auto)

(*--------------------------*
 |       decompo cons       |
 *--------------------------*)

(*** decompo traces if ***)

lemma decompo_head_in_trace_if:
  "[| a ~= Tick ; t : trace |] ==> a # t : trace"
apply (insert decompo_app_in_trace_if[of "[a]" t])
by (auto)

lemma decompo_head_in_trace :
  "a # t : trace =  (t = [] | (a ~= Tick & t : trace))"
apply (insert decompo_app_in_trace[of "[a]"])
by (auto)

lemma decompo_last_in_trace_if :
  "Tick ~: set s ==> s @ [a] : trace"
apply (insert decompo_app_in_trace_if[of s "[a]"])
by (auto)

lemma decompo_last_in_trace :
  "s @ [a] : trace = (Tick ~: set s)"
apply (insert decompo_app_in_trace[of s "[a]"])
by (simp)

(*--------------------------*
 |        app not in        |
 *--------------------------*)

lemma app_notin_trace_left:
   "s ~: trace ==> t @ s ~: trace"
apply (auto simp add: trace_def)
apply (simp add: in_butlast_decompo)
apply (case_tac "s = []")
by (simp_all)

lemma app_notin_trace_right:
   "s ~: trace ==> s @ t ~: trace"
apply (auto simp add: trace_def)
apply (simp add: in_butlast_decompo)
apply (rule disjI1)
by (rule in_set_butlast, simp)

lemmas app_notin_trace =
       app_notin_trace_left app_notin_trace_right

(*******************************
            Tick
 *******************************)

lemma Tick_is_last : "Tick#s : trace ==> s = []"
apply (case_tac "s = []")
by (auto simp add: trace_def)

(*******************************
             Nil
 *******************************)

lemma one_neq_nil[simp]: "<a> ~= <>"
by (simp add: nilt_def Abs_trace_inject)

lemma one_neq_nil_sym[simp]: "<> ~= <a>"
by (simp add: nilt_def Abs_trace_inject)

(*******************************
           noTick
 *******************************)

(*** noTick Ev ***)

lemma noTick_Ev[simp]: "noTick (<Ev a>)"
apply (simp add: noTick_def sett_def)
by (simp add: Abs_trace_inverse)

lemma noTick_EvI: "(EX a. e = Ev a) ==> noTick (<e>)"
apply (simp add: noTick_def sett_def)
by (auto simp add: Abs_trace_inverse)

(*** noTick nil ***)

lemma noTick_nil[simp]: "noTick <>"
apply (simp add: noTick_def nilt_def sett_def)
by (simp add: Abs_trace_inverse)

(*** not noTick Tick ***)

lemma not_noTick_Tick[simp]: "~ noTick <Tick>"
apply (simp add: noTick_def sett_def)
by (simp add: Abs_trace_inverse)

(*******************************
            Event
 *******************************)

lemma Event_eq[simp] : "(<e1> = <e2>) = (e1 = e2)"
by (simp add: Abs_trace_inject)

(***********************************************************
                   @ in trace
 ***********************************************************)

(*---------------------------------------------*
 |         Rep_trace s @ Rep_trace t           |
 *---------------------------------------------*)

(*--------------------------*
 |       rep in_trace       |
 *--------------------------*)

lemma Rep_compo_head_in_trace[simp]:
  "(Ev a) # Rep_trace t : trace"
by (simp add: decompo_head_in_trace)

lemma Rep_compo_last_in_trace[simp]:
  "noTick t ==> Rep_trace t @ [e] : trace"
apply (simp add: decompo_last_in_trace)
apply (simp add: noTick_def sett_def)
done

lemma Rep_compo_app_in_trace[simp] :
  "(noTick s | t = <>) ==> Rep_trace s @ Rep_trace t : trace"
apply (simp add: decompo_app_in_trace)
apply (simp add: noTick_def sett_def nilt_def)
apply (simp add: Abs_trace_Rep_trace_inverse)
by (auto)

(*** only if ***)

lemma decompo_apprep_in_traceI:
  "Rep_trace s @ Rep_trace t : trace ==> (noTick s | t = <>)"
apply (simp add: decompo_app_in_trace)
apply (simp add: nilt_def noTick_def sett_def)
by (auto simp add: Rep_trace_Abs_trace_inverse_only_if)

(*** iff ***)

lemma decompo_apprep_in_trace:
  "(Rep_trace s @ Rep_trace t : trace) = (noTick s | t = <>)"
apply (rule iffI)
apply (rule decompo_apprep_in_traceI, simp)
apply (simp)
done

(*** not ***)

lemma decompo_apprep_notin_traceI:
  "Rep_trace s @ Rep_trace t ~: trace ==> (~ noTick s & t ~= <>)"
by (erule contrapos_np, simp)

(*** erule ***)

lemma decompo_apprep_in_traceE:
  "[| Rep_trace s @ Rep_trace t : trace ;
      noTick s | t = <> ==> R |] ==> R"
apply (simp add: decompo_apprep_in_trace)
done

lemma decompo_apprep_notin_traceE:
  "[| Rep_trace s @ Rep_trace t ~: trace ;
      [| ~ noTick s ; t ~= <> |] ==> R |] ==> R"
apply (simp add: decompo_apprep_in_trace)
done

(*-----------------------------*
 |     lemmas for in_traces    |
 *-----------------------------*)

lemmas in_trace = decompo_head_in_trace decompo_app_in_trace
lemmas Rep_in_trace = decompo_apprep_in_trace

(***********************************************************
                  lemmas for s @t t
 ***********************************************************)

(*-----------------------------*
 | Abs_trace distribution on @ |
 *-----------------------------*)

lemma Abs_trace_app_dist:
  "s @ t : trace ==> Abs_trace s ^^^ Abs_trace t = Abs_trace (s @ t)"
apply (simp add: appt_def)
apply (erule decompo_appt_in_traceE)
apply (simp add: Abs_trace_inverse)
done

(***********************************************************
                    s ^^^ t <==> s @rep t
 ***********************************************************)

(*--------------------------*
 |       append head        |
 *--------------------------*)

lemma appt_head:
  "<a> ^^^ s = Abs_trace (a # Rep_trace s)"
apply (simp add: appt_def)
by (simp add: Abs_trace_inverse)

(*--------------------------*
 |       append last        |
 *--------------------------*)

lemma appt_last:
  "noTick t ==> t ^^^ <e> = Abs_trace (Rep_trace t @ [e])"
apply (simp add: appt_def)
by (simp add: Abs_trace_inverse)

(***********************************************************
                  lemmas for s ^^^ t
 ***********************************************************)

lemma appt_nil_left[simp]: "<> ^^^ s = s"
apply (simp add: appt_def)
apply (simp add: nilt_def)
by (simp add: Abs_trace_inverse Rep_trace_inverse)

lemma appt_nil_right[simp]: "s ^^^ <> = s"
apply (simp add: appt_def)
apply (simp add: nilt_def)
by (simp add: Abs_trace_inverse Rep_trace_inverse)

lemma event_app_not_nil_left[simp]: "<Ev a> ^^^ s ~= <>"
apply (simp add: appt_def)
apply (simp add: Abs_trace_inverse nilt_def)
apply (subgoal_tac "Ev a # Rep_trace s : trace")
apply (simp add: Abs_trace_inject)
apply (simp add: in_trace)
done

lemma event_app_not_nil_right[simp]: "noTick s ==> s ^^^ <e> ~= <>"
apply (simp add: appt_def)
apply (simp add: Abs_trace_inverse nilt_def)
apply (subgoal_tac "Rep_trace s @ [e] : trace")
apply (simp add: Abs_trace_inject)
apply (simp add: in_trace)
apply (simp add: noTick_def sett_def)
done

(***********************************************************
                 induction for traces
 ***********************************************************)

(*** induction ***)

lemma induct_event_list:
  "s : trace &
   P <> & P <Tick> &
   (ALL s a. (P (Abs_trace s) --> P (<Ev a> ^^^ (Abs_trace s))))
    --> P (Abs_trace s)"
apply (induct_tac s)

(* base case *)
apply (simp add: nilt_def)

(* step case *)
apply (intro impI)
apply (simp add: in_trace)

apply (insert event_Tick_or_Ev)
apply (drule_tac x="a" in spec)
apply (elim disjE conjE exE)
apply (simp_all)

apply (drule_tac x="[]" in spec)
apply (fold nilt_def, simp)
apply (simp add: appt_head)
apply (drule_tac x="list" in spec)
apply (simp add: Abs_trace_inverse)
done

(*** rule ***)

lemma induct_trace:
  "[| P <> ; P <Tick> ;
      !! (s::'a trace) a. P s ==> P (<Ev a> ^^^ s) |]
    ==> P (s)"
apply (insert induct_event_list[of "Rep_trace s" P])
by (simp add: Rep_trace_inverse)

(*------------------------------------------------------*
 |  use this induction rule "induct_trace" as follows:  |
 |                                                      |
 |      lemma test_induction: "test (s::'a trace)"      |
 |      apply (induct_tac s rule: induct_trace)         |
 |                                                      |
 *------------------------------------------------------*)

(*** reverse induction ***)

lemma rev_induct_event_list:
  "s : trace &
   P <> &
   (ALL s e. (P (Abs_trace s) & noTick (Abs_trace s))
    --> P ((Abs_trace s) ^^^ <e>))
    --> P (Abs_trace s)"
apply (induct_tac s rule: rev_induct)

(* base case *)
apply (simp add: nilt_def)

(* step case *)
apply (intro allI impI)
apply (simp add: in_trace)
apply (elim conjE)
apply (drule_tac x="xs" in spec)
apply (simp add: noTick_def sett_def)
apply (simp add: Abs_trace_inverse)
apply (subgoal_tac "noTick (Abs_trace xs)")
apply (simp add: appt_last Abs_trace_inverse)
apply (simp add: noTick_def sett_def)
apply (simp add: Abs_trace_inverse)
done

(*** rule ***)

lemma rev_induct_trace:
  "[| P <> ;
      !! (s::'a trace) e. [| P s ; noTick s |] ==> P (s ^^^ <e>) |]
    ==> P (s)"
apply (insert rev_induct_event_list[of "Rep_trace s" P])
by (simp add: Rep_trace_inverse)

(*----------------------------------------------------------*
 |  use this induction rule "rev_induct_trace" as follows:  |
 |                                                          |
 |      lemma test_induction: "test (s::'a trace)"          |
 |      apply (induct_tac s rule: rev_induct_trace)         |
 |                                                          |
 *----------------------------------------------------------*)

(***********************************************************
                   convenient lemmas
 ***********************************************************)

(*--------------------------*
 |   associativity of ^^^    |
 *--------------------------*)

lemma appt_assoc:
  "[| (noTick s | t = <>) ; (noTick t | u = <>) |]
   ==> (s ^^^ t) ^^^ u = s ^^^ (t ^^^ u)"
apply (subgoal_tac "Rep_trace s @ Rep_trace t : trace")
apply (subgoal_tac "Rep_trace t @ Rep_trace u : trace")
apply (simp add: appt_def)
apply (simp add: Abs_trace_inverse)

apply (simp_all add: Rep_in_trace)
done

lemma appt_assoc_sym :
  "[| (noTick s | t = <>) ; (noTick t | u = <>) |]
   ==> s ^^^ (t ^^^ u) = (s ^^^ t) ^^^ u"
by (simp add: appt_assoc)

(*** nil ***)

lemma appt_nil[simp]: "noTick s ==> (s ^^^ t = <>) = (s = <> & t = <>)"
apply (rule iffI)
apply (simp_all)

apply (simp add: appt_def)
apply (case_tac "(Rep_trace s @ Rep_trace t) : trace")
 apply (simp add: nilt_def)
 apply (simp add: Abs_trace_inject)
 apply (simp add: Rep_trace_Abs_trace_inverse_only_if)
 apply (simp add: Rep_in_trace)
done

lemma appt_nil_sym[simp]: "noTick s ==> (<> = s ^^^ t) = (s = <> & t = <>)"
apply (auto)
by (drule sym, simp)+

(*--------------------------*
 |         length           |
 *--------------------------*)

(*** 0 ***)
lemma lengtht_nil_zero[simp]: "lengtht (<>) = 0"
apply (simp add: nilt_def lengtht_def)
by (simp add: Abs_trace_inverse)

(*** 1 ***)
lemma lengtht_one_event[simp]: "lengtht (<e>) = Suc 0"
apply (simp add: lengtht_def)
by (simp add: Abs_trace_inverse)

(*** length + 1 ***)

lemma lengtht_app_event_Suc_last[simp]:
  "noTick s ==> lengtht (s ^^^ <a>) = Suc (lengtht s)"
apply (simp add: appt_def lengtht_def)
apply (simp add: Abs_trace_inverse)
done

lemma lengtht_app_event_Suc_head[simp]:
  "lengtht (<Ev a> ^^^ s) = Suc (lengtht s)"
apply (simp add: appt_def lengtht_def)
apply (simp add: Abs_trace_inverse)
done

(*** app length ***)

lemma lengtht_app_decompo1[simp]:
  "noTick s | t = <>
      ==> lengtht (s ^^^ t) = lengtht s + lengtht t"
apply (simp add: appt_def lengtht_def)
apply (simp add: Abs_trace_inverse)
done

lemma lengtht_app_decompo2[simp]:
  "Rep_trace s @ Rep_trace t : trace
      ==> lengtht (s ^^^ t) = lengtht s + lengtht t"
apply (simp add: Rep_in_trace)
done

(*---------------------------*
 |           sett            |
 *---------------------------*)

(*** nil ***)

lemma sett_nil[simp]: "sett <> = {}"
apply (simp add: sett_def)
by (simp add: nilt_def Abs_trace_inverse)

(*** one ***)

lemma sett_one[simp]: "sett <e> = {e}"
apply (simp add: sett_def)
by (simp add: Abs_trace_inverse)

(*** appt ***)

lemma sett_appt1[simp]:
  "noTick s | t = <> ==> sett (s ^^^ t) = sett s Un sett t"
apply (simp add: sett_def appt_def)
apply (simp add: Abs_trace_inverse)
done

lemma sett_appt2[simp]:
  "Rep_trace s @ Rep_trace t : trace
    ==> sett (s ^^^ t) = sett s Un sett t"
by (simp add: Rep_in_trace)

(*---------------------------*
 |     decompo appt Tick     |
 *---------------------------*)

(*** only if ***)

lemma decompo_appt_noTick_only_if:
  "[| noTick s | t = <> ; noTick (s ^^^ t) |] ==> (noTick s & noTick t)"
by (simp add: noTick_def)

(*** if ***)

lemma decompo_appt_noTick_if:
  "[| noTick s ; noTick t |] ==> noTick (s ^^^ t)"
by (simp add: noTick_def)

(*** iff ***)

lemma decompo_appt_noTick[simp]:
  "noTick s | t = <> ==> noTick (s ^^^ t) = (noTick s & noTick t)"
by (simp add: noTick_def)

(*---------------------------*
 |   a trace is ... or ...   |
 *---------------------------*)

(*** trace --> nil or Tick or etc ***)

lemma trace_nil_or_Tick_or_Ev:
  "ALL t. ((t = <>) | (t = <Tick>) | (EX a s. t=<Ev a> ^^^ s))"
apply (intro allI)
apply (induct_tac t rule: induct_trace)
by (auto)

(*** trace --> nil or unnil ***)

lemma trace_nil_or_unnil:
  "ALL t. ((t = <>) | (EX a s. t=<a> ^^^ s))"
apply (intro allI)
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="t" in spec)
apply (elim conjE disjE exE)
apply (simp_all)

apply (rule_tac x="Tick" in exI)
apply (rule_tac x="<>" in exI)
apply (simp)

apply (rule_tac x="Ev a" in exI)
apply (rule_tac x="s" in exI)
by (simp)

(*** trace --> nil or unnil (last) ***)

lemma trace_last_nil_or_unnil:
  "ALL t. ((t = <>) | (EX s a. noTick s & t = s ^^^ <a>))"
apply (intro allI)
apply (induct_tac t rule: rev_induct_trace)
by (auto)

(*** trace --> noTick or Tick (last) ***)

lemma trace_last_noTick_or_Tick:
  "ALL t. (noTick t | (EX s. noTick s & t = s ^^^ <Tick>))"
apply (intro allI impI)
apply (insert trace_last_nil_or_unnil)
apply (drule_tac x="t" in spec, simp)
apply (elim conjE disjE exE)
apply (simp_all)

 apply (insert event_Tick_or_Ev)
 apply (drule_tac x="a" in spec)
by (auto)

(*---------------------------*
 |    same head and last     |
 *---------------------------*)

(*** same head ***)

lemma appt_same_head_only_if:
  "<Ev a> ^^^ s = <Ev b> ^^^ t  ==> a = b & s = t"
apply (simp add: appt_def)
apply (simp add: Abs_trace_inverse)
apply (simp add: Abs_trace_inject)
apply (simp add: Rep_trace_inject)
done

lemma appt_same_head[simp]:
  "(<Ev a> ^^^ s = <Ev b> ^^^ t) = (a = b & s = t)"
apply (rule iffI)
apply (rule appt_same_head_only_if)
by (simp_all)

(*** same last ***)

lemma appt_same_last_only_if:
  "[| noTick s ; noTick t ; s ^^^ <a> = t ^^^ <b> |]
      ==> s = t & a = b"
apply (simp add: appt_def)
apply (simp add: Abs_trace_inverse)
apply (simp add: Abs_trace_inject)
apply (simp add: Rep_trace_inject)
done

lemma appt_same_last[simp]:
  "[| noTick s ; noTick t |] ==> (s ^^^ <a> = t ^^^ <b>) = (s = t & a = b)"
apply (rule iffI)
apply (rule appt_same_last_only_if)
by (simp_all)

(*---------------------------*
 |     appt decompo one      |
 *---------------------------*)

lemma appt_decompo_one_only_if:
  "[| noTick s | t = <> ; s ^^^ t = <a> |]
   ==> (s = <a> & t = <>) | (s = <> & t = <a>)"
apply (erule disjE)
apply (simp_all)
apply (simp add: appt_def)
apply (simp add: Abs_trace_inject)
apply (simp add: list_app_decompo_one)
apply (simp add: Abs_trace_Rep_trace_inverse nilt_def)
by (auto)

lemma appt_decompo_one[simp]:
  "noTick s | t = <>
   ==> (s ^^^ t = <a>) = ((s = <a> & t = <>) | (s = <> & t = <a>))"
apply (rule iffI)
apply (simp add: appt_decompo_one_only_if)
by (auto)

lemma appt_decompo_one_sym[simp]:
  "noTick s | t = <>
   ==> (<a> = s ^^^ t) = ((s = <a> & t = <>) | (s = <> & t = <a>))"
apply (rule iffI)
apply (drule sym, simp)
by (rule sym, simp)

(******************************************************************
                        head and tail
 ******************************************************************)

(*** tl : trace ***)

lemma tlt_trace:
  "[| s : trace ; s ~= [] |] ==> tl s : trace"
apply (simp add: trace_def)
apply (insert list_nil_or_unnil)
apply (drule_tac x="s" in spec)

apply (erule disjE, simp)
apply (elim exE, simp)
by (case_tac "sa = []", simp, simp)

(*** head !! ***)

lemma hdt_appt[simp]: "hdt (<Ev a> ^^^ s) = Ev a"
apply (simp add: appt_def)
apply (simp add: hdt_def)
apply (simp add: Abs_trace_inverse)
done

(* one *)

lemma hdt_one[simp]: "hdt <a> = a"
apply (simp add: hdt_def)
by (simp add: Abs_trace_inverse)

(*** tail !! ***)

lemma tlt_appt[simp]: "tlt (<Ev a> ^^^ s) = s"
apply (simp add: appt_def)
apply (simp add: tlt_def)
apply (simp add: Abs_trace_inverse)
apply (simp add: Rep_trace_inverse)
done

(* one *)

lemma tlt_one[simp]: "tlt <a> = <>"
apply (simp add: tlt_def)
by (simp add: Abs_trace_inverse nilt_def)

(*** head + tail ***)

lemma hdt_appt_tail[simp]: "s ~= <> ==> <hdt s> ^^^ (tlt s) = s"
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="s" in spec)
apply (simp)
apply (erule disjE, simp)
by (elim exE, simp)

(******************************************************************
                        butlast & last
 ******************************************************************)

(*** butlast : trace ***)

lemma butlast_trace:
  "[| s : trace ; s ~= [] |] ==> butlast s : trace"
by (simp add: trace_def notin_set_butlast)

lemma butlast_trace_Rep:
  "s ~= <> ==> butlast (Rep_trace s) : trace"
apply (insert Rep_trace[of s])
apply (case_tac "Rep_trace s ~= []")
apply (simp add: trace_def)
apply (simp add: notin_set_butlast)
by (simp)

(*** last !! ***)

lemma lastt_appt[simp]: "noTick s ==> lastt (s ^^^ <e>) = e"
apply (simp add: appt_def)
apply (simp add: lastt_def)
apply (simp add: Abs_trace_inverse)
done

(* one *)

lemma lastt_one[simp]: "lastt <a> = a"
apply (simp add: lastt_def)
by (simp add: Abs_trace_inverse)

(*** butlast !! ***)

lemma butlastt_appt[simp]: "noTick s ==> butlastt (s ^^^ <e>) = s"
apply (simp add: appt_def)
apply (simp add: butlastt_def)
apply (simp add: Abs_trace_inverse)
by (simp add: Rep_trace_inverse)

(* one *)

lemma butlastt_one[simp]: "butlastt <a> = <>"
apply (simp add: butlastt_def)
by (simp add: Abs_trace_inverse nilt_def)

(*** butlast + last ***)

lemma butlastt_appt_lastt[simp]: "s ~= <> ==> (butlastt s) ^^^ <lastt s> = s"
apply (insert trace_last_nil_or_unnil)
apply (drule_tac x="s" in spec)
apply (simp)
apply (elim conjE exE)
by (simp)

(******************************************************************
                        noTick + alpha
 ******************************************************************)

(* Tick in *)

lemma not_noTick_unnil[simp]: "~ noTick s ==> s ~= <>"
by (case_tac "s ~= <>", simp_all)

(* noTick butlastt *)

lemma noTick_butlast: "s ~= <> ==> noTick (butlastt s)"
apply (simp add: butlastt_def)
apply (simp add: noTick_def sett_def)
apply (simp add: butlast_trace_Rep Abs_trace_inverse)
apply (insert Rep_trace[of s])
by (simp add: trace_def)

(* Tick and butlastt *)

lemma Tick_decompo_lm: "ALL s. ~ noTick s --> s = ((butlastt s) ^^^ <Tick>)"
apply (intro allI impI)
apply (insert trace_last_nil_or_unnil)
apply (drule_tac x="s" in spec)
apply (simp)

apply (elim conjE exE)
by (simp add: noTick_def)

lemma Tick_decompo: "~ noTick s ==> s = ((butlastt s) ^^^ <Tick>)"
by (simp add: Tick_decompo_lm)

(******************************************************************
                         lengtht plus
 ******************************************************************)

(*** lengtht zero ***)

lemma lengtht_zero: "(lengtht s = 0) = (s = <>)"
apply (induct_tac s rule: induct_trace)
by (simp_all)

(*** lengtht one ***)

lemma lengtht_one: "(lengtht s = Suc 0) = (EX e. s = <e>)"
apply (induct_tac s rule: induct_trace)
apply (simp_all)
by (simp add: lengtht_zero)

(******************************************************************
                         convenient lemmas
 ******************************************************************)

(*-------------------*
 |  for Seq_compo T1 |
 *-------------------*)

lemma appt_decompo_lm:
  "ALL s1 s2 t1 t2.
   (noTick s1 & s2 ~= <> & noTick t1 & t2 ~= <>)
       --> (s1 ^^^ s2 = t1 ^^^ t2)
           = ((EX u. s1 ^^^ u = t1 & s2 = u ^^^ t2 & noTick u) |
              (EX u. s1 = t1 ^^^ u & u ^^^ s2 = t2 & noTick u))"
apply (rule allI)
apply (induct_tac s1 rule: induct_trace)
apply (force)
apply (force)
apply (intro allI impI)
apply (drule_tac x="s2" in spec, simp)

apply (rule iffI)
 (* => *)
 apply (insert trace_nil_or_Tick_or_Ev)
 apply (rotate_tac -1)

 apply (drule_tac x="t1" in spec)
 apply (erule disjE, simp)
 apply (erule disjE, simp)
 apply (elim exE, simp)     (* t1 = [Ev aa]t ^^^ sa *)
 apply (drule_tac x="sa" in spec)
 apply (drule_tac x="t2" in spec)
 apply (simp add: appt_assoc)

 (* <= *)
 apply (elim disjE conjE exE)
 apply (auto simp add: appt_assoc_sym)
done

lemma appt_decompo:
  "[| noTick s1 | s2 = <> ; noTick t1 | t2 = <> |]
   ==> (s1 ^^^ s2 = t1 ^^^ t2)
       = ((EX u. s1 ^^^ u = t1 & s2 = u ^^^ t2 & (noTick u | (noTick s1 & t2 = <>))) |
          (EX u. s1 = t1 ^^^ u & u ^^^ s2 = t2 & (noTick u | (noTick t1 & s2 = <>))))"
apply (case_tac "s2 ~= <>")
apply (case_tac "t2 ~= <>")
apply (auto simp add: appt_decompo_lm)
done

(*-------------------*
 |  for Seq_compo T2 |
 *-------------------*)

lemma noTick_or_last_Tick:
  "ALL s. noTick s | (EX t. s = t ^^^ <Tick>)"
apply (rule allI)
apply (induct_tac s rule: rev_induct_trace)
apply (simp_all)
apply (insert event_Tick_or_Ev)
apply (drule_tac x="e" in spec)
by (auto)

(*--------------------------*
 |  used in Alpha_parallel  |
 *--------------------------*)

(*** Tick & sett ***)

lemma not_noTick_in_sett_imp:
  "~ (noTick s) --> (EX t. s = t ^^^ <Tick> & noTick t)"
apply (induct_tac s rule: induct_trace)
apply (simp_all)
apply (rule_tac x="<>" in exI)
apply (simp)

apply (intro allI impI)
apply (simp)
apply (elim exE)
apply (simp)
apply (rule_tac x="<Ev a> ^^^ t" in exI)
apply (simp add: appt_assoc)
done

lemma Tick_in_sett_imp:
  "Tick : sett(s) --> (EX t. s = t ^^^ <Tick> & noTick t)"
apply (insert not_noTick_in_sett_imp[of s])
by (simp add: noTick_def)

lemma Tick_in_sett: "(Tick : sett(s)) = (EX t. s = t ^^^ <Tick> & noTick t)"
apply (rule iffI)
apply (simp add: Tick_in_sett_imp)
apply (elim conjE exE)
by (simp)

(*--------------------------------*
 |   used in Inductive_parallel   |
 *--------------------------------*)

lemma sett_subset_Tick_if:
 "(u = <> | u = <Tick>) ==> (sett u <= {Tick})"
by (auto)

lemma sett_subset_Tick_only_if:
 "(sett u <= {Tick}) --> (u = <> | u = <Tick>)"
apply (induct_tac u rule: induct_trace)
by (simp_all)

lemma sett_subset_Tick:
 "(sett u <= {Tick}) = (u = <> | u = <Tick>)"
apply (rule iffI)
apply (simp add: sett_subset_Tick_only_if)
apply (simp add: sett_subset_Tick_if)
done

(*--------------------------*
 |    lengtht [a,b,c]t      |
 *--------------------------*)

lemma lengtht_Abs_trace: "s : trace ==> lengtht (Abs_trace s) = length s"
apply (simp add: lengtht_def)
apply (simp add: Abs_trace_inverse)
done

lemma lengtht_Abs_trace_noTick:
  "Tick ~: set  (butlast s) ==> lengtht (Abs_trace s) = length s"
apply (simp add: lengtht_Abs_trace[simplified trace_def])
done

(* =================================================== *
 |             addition for CSP-Prover 5               |
 * =================================================== *)

(* ~ noTick *)

lemma not_noTick_in_sett: "(~ (noTick s)) = (EX t. s = t ^^^ <Tick> & noTick t)"
apply (rule iffI)
apply (subgoal_tac "Tick : sett(s)")
apply (simp add: Tick_in_sett)
apply (simp add: noTick_def)
apply (simp (no_asm_simp) add: noTick_def)
apply (simp add: Tick_in_sett)
done

(*-------------------*
 |  for Seq_compo T2 |
 *-------------------*)

lemma noTick_or_last_Tick2:
  "ALL s. noTick s | (EX t. s = t ^^^ <Tick> & noTick t)"
apply (rule allI)
apply (induct_tac s rule: rev_induct_trace)
apply (simp_all)
apply (insert event_Tick_or_Ev)
apply (drule_tac x="e" in spec)
apply (elim disjE exE)
apply (force)
apply (rule disjI1)
apply (force)
done

(****************** to add it again ******************)

declare disj_not1 [simp]

end


(*  Title:       CCPO_Topology.thy
    Author:      Johannes Hölzl, TU Munich
*)

section {* CCPO topologies *}

theory CCPO_Topology
imports
  "HOL-Analysis.Extended_Real_Limits"
  "../Coinductive_Nat"
begin

lemma dropWhile_append:
  "dropWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then dropWhile P ys else dropWhile P xs @ ys)"
  by auto

lemma dropWhile_False: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> dropWhile P xs = []"
  by simp

abbreviation (in order) "chain \<equiv> Complete_Partial_Order.chain op \<le>"

lemma (in linorder) chain_linorder: "chain C"
  by (simp add: chain_def linear)

lemma continuous_add_ereal:
  assumes "0 \<le> t"
  shows "continuous_on {-\<infinity>::ereal <..} (\<lambda>x. t + x)"
proof (subst continuous_on_open_vimage, (intro open_greaterThan allI impI)+)
  fix B :: "ereal set" assume "open B"
  show "open ((\<lambda>x. t + x) -` B \<inter> {- \<infinity><..})"
  proof (cases t)
    case (real t')
    then have *: "(\<lambda>x. t + x) -` B \<inter> {- \<infinity><..} = (\<lambda>x. 1 * x + (-t)) ` (B \<inter> {-\<infinity> <..})"
      apply (simp add: set_eq_iff image_iff Bex_def)
      apply (intro allI iffI)
      apply (rule_tac x= "x + ereal t'" in exI)
      apply (case_tac x)
      apply (auto simp: ac_simps)
      done
    show ?thesis
      unfolding *
      apply (rule ereal_open_affinity_pos)
      using `open B`
      apply (auto simp: real)
      done
  qed (insert `0 \<le> t`, auto)
qed

lemma tendsto_add_ereal:
  "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> (f \<longlongrightarrow> y) F \<Longrightarrow> ((\<lambda>z. x + f z :: ereal) \<longlongrightarrow> x + y) F"
  apply (rule tendsto_compose[where f=f])
  using continuous_add_ereal[where t=x]
  unfolding continuous_on_def
  apply (auto simp add: at_within_open[where S="{- \<infinity> <..}"])
  done

lemma tendsto_LimI: "(f \<longlongrightarrow> y) F \<Longrightarrow> (f \<longlongrightarrow> Lim F f) F"
  by (metis tendsto_Lim tendsto_bot)

subsection {* The filter @{text at'} *}

abbreviation (in ccpo) "compact_element \<equiv> ccpo.compact Sup op \<le>"

lemma tendsto_unique_eventually:
  fixes x x' :: "'a :: t2_space"
  shows "F \<noteq> bot \<Longrightarrow> eventually (\<lambda>x. f x = g x) F \<Longrightarrow> (f \<longlongrightarrow> x) F \<Longrightarrow> (g \<longlongrightarrow> x') F \<Longrightarrow> x = x'"
  by (metis tendsto_unique filterlim_cong)

lemma (in ccpo) ccpo_Sup_upper2: "chain C \<Longrightarrow> x \<in> C \<Longrightarrow> y \<le> x \<Longrightarrow> y \<le> Sup C"
  by (blast intro: ccpo_Sup_upper order_trans)

lemma tendsto_open_vimage: "(\<And>B. open B \<Longrightarrow> open (f -` B)) \<Longrightarrow> f \<midarrow>l\<rightarrow> f l"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma open_vimageI: "(\<And>x. f \<midarrow>x\<rightarrow> f x) \<Longrightarrow> open A \<Longrightarrow> open (f -` A)"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma principal_bot: "principal x = bot \<longleftrightarrow> x = {}"
  by (auto simp: filter_eq_iff eventually_principal)

definition "at' x = (if open {x} then principal {x} else at x)"

lemma at'_bot: "at' x \<noteq> bot"
  by (simp add: at'_def at_eq_bot_iff principal_bot)

lemma tendsto_id_at'[simp, intro]: "((\<lambda>x. x) \<longlongrightarrow> x) (at' x)"
  by (simp add: at'_def topological_tendstoI eventually_principal tendsto_ident_at)

lemma cont_at': "(f \<longlongrightarrow> f x) (at' x) \<longleftrightarrow> f \<midarrow>x\<rightarrow> f x"
  using at_eq_bot_iff[of x] by (auto split: if_split_asm intro!: topological_tendstoI simp: eventually_principal at'_def)

subsection {* The type class @{text ccpo_topology} *}

text {* Temporarily relax type constraints for @{term "open"}. *}
setup {* Sign.add_const_constraint
  (@{const_name "open"}, SOME @{typ "'a::open set \<Rightarrow> bool"}) *}

class ccpo_topology = "open" + ccpo +
  assumes open_ccpo: "open A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"
begin

lemma open_ccpoD:
  assumes "open A" "chain C" "C \<noteq> {}" "Sup C \<in> A"
  shows "\<exists>c\<in>C. \<forall>c'\<in>C. c \<le> c' \<longrightarrow> c' \<in> A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<And>c. c \<in> C \<Longrightarrow> \<exists>c'\<in>C. c \<le> c' \<and> c' \<notin> A"
    by auto
  with `chain C` `C \<noteq> {}` have "chain (C - A)" "C - A \<noteq> {}"
    by (auto intro: chain_Diff)
  moreover have "Sup C = Sup (C - A)"
  proof (safe intro!: antisym ccpo_Sup_least `chain C` chain_Diff)
    fix c assume "c \<in> C"
    with * obtain c' where "c' \<in> C" "c \<le> c'" "c' \<notin> A"
      by auto
    with `c\<in>C` show "c \<le> \<Squnion>(C - A)"
      by (intro ccpo_Sup_upper2 `chain (C - A)`) auto
  qed (auto intro: `chain C` ccpo_Sup_upper)
  ultimately show False
    using `open A` `Sup C \<in> A` by (auto simp: open_ccpo)
qed

lemma open_ccpo_Iic: "open {.. b}"
  by (auto simp: open_ccpo) (metis Int_iff atMost_iff ccpo_Sup_upper empty_iff order_trans)

subclass topological_space
proof
  show "open (UNIV::'a set)"
    unfolding open_ccpo by auto
next
  fix S T :: "'a set" assume "open S" "open T"
  show "open (S \<inter> T)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume C: "chain C" "C \<noteq> {}" and "\<Squnion>C \<in> S \<inter> T"
    with open_ccpoD[OF `open S` C] open_ccpoD[OF `open T` C]
    show "C \<inter> (S \<inter> T) \<noteq> {}"
      unfolding chain_def by blast
  qed
next
  fix K :: "'a set set" assume *: "\<forall>D\<in>K. open D"
  show "open (\<Union>K)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume "chain C" "C \<noteq> {}" "\<Squnion>C \<in> (\<Union>K)"
    with * obtain D where "D \<in> K" "\<Squnion>C \<in> D" "C \<inter> D \<noteq> {}"
      by (auto simp: open_ccpo)
    then show "C \<inter> (\<Union>K) \<noteq> {}"
      by auto
  qed
qed

lemma closed_ccpo: "closed A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> C \<subseteq> A \<longrightarrow> Sup C \<in> A)"
  unfolding closed_def open_ccpo by auto

lemma closed_admissible: "closed {x. P x} \<longleftrightarrow> ccpo.admissible Sup op \<le> P"
  unfolding closed_ccpo ccpo.admissible_def by auto

lemma open_singletonI_compact: "compact_element x \<Longrightarrow> open {x}"
  using admissible_compact_neq[of Sup "op \<le>" x]
  by (simp add: closed_admissible[symmetric] open_closed Collect_neg_eq)

lemma closed_Ici: "closed {.. b}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_least)

lemma closed_Iic: "closed {b ..}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_upper2)

text {*
  @{class ccpo_topology}s are also @{class t2_space}s.
  This is necessary to have a unique continuous extension.
*}

subclass t2_space
proof
  fix x y :: 'a assume "x \<noteq> y"
  show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
  proof cases
    { fix x y assume "x \<noteq> y" "x \<le> y"
      then have "open {..x} \<and> open (- {..x}) \<and> x \<in> {..x} \<and> y \<in> - {..x} \<and> {..x} \<inter> - {..x} = {}"
        by (auto intro: open_ccpo_Iic closed_Ici) }
    moreover assume "x \<le> y \<or> y \<le> x"
    ultimately show ?thesis
      using `x \<noteq> y` by (metis Int_commute)
  next
    assume "\<not> (x \<le> y \<or> y \<le> x)"
    then have "open ({..x} \<inter> - {..y}) \<and> open ({..y} \<inter> - {..x}) \<and>
        x \<in> {..x} \<inter> - {..y} \<and> y \<in> {..y} \<inter> - {..x} \<and> ({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    then show ?thesis by auto
  qed
qed

end

lemma tendsto_le_ccpo:
  fixes f g :: "'a \<Rightarrow> 'b::ccpo_topology"
  assumes F: "\<not> trivial_limit F"
  assumes x: "(f \<longlongrightarrow> x) F" and y: "(g \<longlongrightarrow> y) F"
  assumes ev: "eventually (\<lambda>x. g x \<le> f x) F"
  shows "y \<le> x"
proof (rule ccontr)
  assume "\<not> y \<le> x"

  show False
  proof cases
    assume "x \<le> y"
    with `\<not> y \<le> x`
    have "open {..x}" "open (- {..x})" "x \<in> {..x}" "y \<in> - {..x}" "{..x} \<inter> - {..x} = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x}"] topological_tendstoD[OF y, of "- {..x}"]
    have "eventually (\<lambda>z. f z \<le> x) F" "eventually (\<lambda>z. \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  next
    assume "\<not> x \<le> y"
    with `\<not> y \<le> x` have "open ({..x} \<inter> - {..y})" "open ({..y} \<inter> - {..x})"
        "x \<in> {..x} \<inter> - {..y}" "y \<in> {..y} \<inter> - {..x}" "({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x} \<inter> - {..y}"]
         topological_tendstoD[OF y, of "{..y} \<inter> - {..x}"]
    have "eventually (\<lambda>z. f z \<le> x \<and> \<not> f z \<le> y) F" "eventually (\<lambda>z. g z \<le> y \<and> \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  qed
qed

lemma tendsto_ccpoI:
  fixes f :: "'a::ccpo_topology \<Rightarrow> 'b::ccpo_topology"
  shows "(\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> chain (f ` C) \<and> f (Sup C) = Sup (f`C)) \<Longrightarrow> f \<midarrow>x\<rightarrow> f x"
  by (intro tendsto_open_vimage) (auto simp: open_ccpo)

lemma tendsto_mcont:
  assumes mcont: "mcont Sup op \<le> Sup op \<le> (f :: 'a :: ccpo_topology \<Rightarrow> 'b :: ccpo_topology)"
  shows "f \<midarrow>l\<rightarrow> f l"
proof (intro tendsto_ccpoI conjI)
  fix C :: "'a set" assume C: "chain C" "C \<noteq> {}"
  show "chain (f`C)"
    using mcont
    by (intro chain_imageI[where le_a="op \<le>"] C) (simp add: mcont_def monotone_def)
  show "f (\<Squnion>C) = \<Squnion>(f ` C)"
    using mcont C by (simp add: mcont_def cont_def)
qed

subsection {* Instances for @{class ccpo_topology}s and continuity theorems *}

instantiation set :: (type) ccpo_topology
begin

definition open_set :: "'a set set \<Rightarrow> bool" where
  "open_set A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_set_def)

end

instantiation enat :: ccpo_topology
begin

instance
proof
  fix A :: "enat set"
  show "open A = (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> \<Squnion>C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"
  proof (intro iffI allI impI)
    fix C x assume "open A" "chain C" "C \<noteq> {}" "\<Squnion>C \<in> A"

    show "C \<inter> A \<noteq> {}"
    proof cases
      assume "\<Squnion>C = \<infinity>"
      with `\<Squnion>C \<in> A` `open A` obtain n where "{enat n <..} \<subseteq> A"
        unfolding open_enat_iff by auto
      with `\<Squnion>C = \<infinity>` Sup_eq_top_iff[of C] show ?thesis
        by (auto simp: top_enat_def)
    next
      assume "\<Squnion>C \<noteq> \<infinity>"
      then obtain n where "C \<subseteq> {.. enat n}"
        unfolding Sup_eq_top_iff top_enat_def[symmetric] by (auto simp: not_less top_enat_def)
      moreover have "finite {.. enat n}"
        by (auto intro: finite_enat_bounded)
      ultimately have "finite C"
        by (auto intro: finite_subset)
      from in_chain_finite[OF `chain C` `finite C` `C \<noteq> {}`] `\<Squnion>C \<in> A` show ?thesis
        by auto
    qed
  next
    assume C: "\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> \<Squnion>C \<in> A \<longrightarrow> C \<inter> A \<noteq> {}"
    show "open A"
      unfolding open_enat_iff
    proof safe
      assume "\<infinity> \<in> A"
      { fix C :: "enat set" assume "infinite C"
        then have "\<Squnion>C = \<infinity>"
          by (auto simp: Sup_enat_def)
        with `infinite C` C[THEN spec, of C] `\<infinity> \<in> A` have "C \<inter> A \<noteq> {}"
          by auto }
      note inf_C = this

      show "\<exists>x. {enat x<..} \<subseteq> A"
      proof (rule ccontr)
        assume "\<not> (\<exists>x. {enat x<..} \<subseteq> A)"
        with `\<infinity> \<in> A` have "\<And>x. \<exists>y>x. enat y \<notin> A"
          by (simp add: subset_eq Bex_def) (metis enat.exhaust enat_ord_simps(2))
        then have "infinite {n. enat n \<notin> A}"
          unfolding infinite_nat_iff_unbounded by auto
        then have "infinite (enat ` {n. enat n \<notin> A})"
          by (auto dest!: finite_imageD)
        from inf_C[OF this] show False
          by auto
      qed
    qed
  qed
qed

end

lemmas tendsto_inf2[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_inf2]

lemma isCont_inf2[THEN isCont_o2[rotated]]:
  "isCont (\<lambda>x. x \<sqinter> y) (z :: _ :: {ccpo_topology, complete_distrib_lattice})"
  by(simp add: isCont_def tendsto_inf2 tendsto_ident_at)

lemmas tendsto_sup1[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_sup1]

lemma isCont_If: "isCont f x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. if Q then f x else g x) x"
  by (cases Q) auto

lemma isCont_enat_case: "isCont (f (epred n)) x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. co.case_enat (g x) (\<lambda>n. f n x) n) x"
  by (cases n rule: enat_coexhaust) auto

end


(*  Author:  Gertrud Bauer, Tobias Nipkow  *)

section "Properties of Tame Graph Enumeration (2)"

theory TameEnumProps
imports GeneratorProps
begin

text\<open>Completeness of filter for final graphs.\<close>

lemma untame_negFin:
assumes pl: "inv g" and fin: "final g" and tame: "tame g"
shows "is_tame g"
proof (unfold is_tame_def, intro conjI)
  show "tame10 g" using tame by(auto simp:tame_def)
next
  show "tame11a g" using tame by(auto simp:tame_def)
next
  show "tame12o g" using tame by(auto simp:tame_def)
next
next
  from tame obtain w where adm: "admissible w g"
    and sqn: "(\<Sum>\<^bsub>f \<in> faces g\<^esub> w f) < squanderTarget" by(auto simp:tame_def tame13a_def)
  moreover have "squanderLowerBound g \<le>  (\<Sum>\<^bsub>f \<in> faces g\<^esub> w f)"
    using pl fin tame adm sqn by (rule total_weight_lowerbound)
  ultimately show "is_tame13a g" by(auto simp:is_tame13a_def)
qed

lemma next_tame_comp:
 "\<lbrakk> tame g; final g; Seed\<^bsub>p\<^esub> [next_tame0 p]\<rightarrow>* g \<rbrakk>
 \<Longrightarrow> Seed\<^bsub>p\<^esub> [next_tame\<^bsub>p\<^esub>]\<rightarrow>* g"
apply (unfold next_tame_def)
apply(rule filter_tame_succs[OF inv_inv_next_tame0])
     apply(simp add:next_tame0_def finalGraph_def)
    apply(rule context_conjI)
     apply(simp)
    apply(blast dest:untame_negFin)
   apply assumption
  apply(rule inv_Seed)
 apply assumption+
done

end


theory Routing
imports PrefixMatch  "../topoS/interface_abstraction/Network" CaesarTheories
begin

subsection{*Definition*}

record routing_rule =
  routing_match :: prefix_match (* done on the dst *)
  routing_action :: "port set"

type_synonym prefix_routing = "routing_rule list"

definition valid_prefixes where
  "valid_prefixes r = foldr conj (map (\<lambda>rr. valid_prefix (routing_match rr)) r) True"
lemma valid_prefixes_split: "valid_prefixes (r#rs) \<Longrightarrow> valid_prefix (routing_match r) \<and> valid_prefixes rs"
  using valid_prefixes_def by force
lemma valid_prefixes_alt_def: "valid_prefixes r = (\<forall>e \<in> set r. valid_prefix (routing_match e))"
  unfolding valid_prefixes_def
  unfolding foldr_map
  unfolding comp_def
  unfolding foldr_True_set
  ..

fun is_longest_prefix_routing :: "prefix_routing \<Rightarrow> bool" where
  "is_longest_prefix_routing (r1#r2#rs) = ((pfxm_length (routing_match r1) \<ge> pfxm_length (routing_match r2)) \<and>
   is_longest_prefix_routing (r2#rs))" |
  "is_longest_prefix_routing _ = True"

(*example: get longest prefix match by sorting by pfxm_length*)
value "rev (sort_key (\<lambda>r. pfxm_length (routing_match r)) [
  \<lparr> routing_match = \<lparr> pfxm_prefix = 1::ipv4addr, pfxm_length = 3 \<rparr>, routing_action = {} \<rparr>,
  \<lparr> routing_match = \<lparr> pfxm_prefix = 2::ipv4addr, pfxm_length = 8 \<rparr>, routing_action = {} \<rparr>,
  \<lparr> routing_match = \<lparr> pfxm_prefix = 3::ipv4addr, pfxm_length = 4 \<rparr>, routing_action = {} \<rparr>])"
lemma longest_prefix_routing_no_sort:
  "is_longest_prefix_routing tbl \<Longrightarrow>
  (sort_key (\<lambda>r. 32 - pfxm_length (routing_match r)) tbl) = tbl"
  by (induction tbl rule: is_longest_prefix_routing.induct) auto

fun has_default_route :: "prefix_routing \<Rightarrow> bool" where
"has_default_route (r#rs) = (((pfxm_length (routing_match r)) = 0) \<or> has_default_route rs)" |
"has_default_route Nil = False"

definition correct_routing :: "prefix_routing \<Rightarrow> bool" where
  "correct_routing r \<equiv> is_longest_prefix_routing r \<and> has_default_route r \<and> valid_prefixes r"

lemma is_longest_prefix_routing_rule_exclusion1:
  assumes "is_longest_prefix_routing (r1 # rn # rss)"
  shows "is_longest_prefix_routing (r1 # rss)"
using assms  by(case_tac rss, simp_all)

lemma is_longest_prefix_routing_rules_injection:
  assumes "is_longest_prefix_routing r"
  assumes "r = r1 # rs @ r2 # rss"
  shows "(pfxm_length (routing_match r1) \<ge> pfxm_length (routing_match r2))"
using assms
proof(induction rs arbitrary: r)
  case (Cons rn rs)
  let ?ro = "r1 # rs @ r2 # rss"
  have "is_longest_prefix_routing ?ro" using Cons.prems is_longest_prefix_routing_rule_exclusion1[of r1 rn "rs @ r2 # rss"] by simp
  from Cons.IH[OF this] show ?case by simp
qed simp

subsection{*Single Packet Semantics*}

value "valid_prefix \<lparr>pfxm_prefix=ipv4addr_of_dotteddecimal (192,168,0,0), pfxm_length=24\<rparr> \<and>
  prefix_match_semantics \<lparr>pfxm_prefix=ipv4addr_of_dotteddecimal (192,168,0,0), pfxm_length=24\<rparr>
      (ipv4addr_of_dotteddecimal (192,168,0,42))"

type_synonym packet = "ipv4addr hdr"
definition "extract_addr f p \<equiv> (case f p of NetworkBox a \<Rightarrow> a | Host a \<Rightarrow> a)"
definition dst_addr :: "'v hdr \<Rightarrow> 'v" where
"dst_addr \<equiv>  extract_addr snd"
lemma dst_addr_f: "(f = Host \<or> f = NetworkBox) \<Longrightarrow> dst_addr (src, f dst) = dst"
  unfolding dst_addr_def extract_addr_def snd_def by auto

(*assumes: correct_routing*)
fun routing_table_semantics :: "prefix_routing \<Rightarrow> ipv4addr \<Rightarrow> port set" where
"routing_table_semantics [] _ = {}" |
"routing_table_semantics (r#rs) p = (if prefix_match_semantics (routing_match r) p then routing_action r else routing_table_semantics rs p)"

definition "packet_routing_table_semantics rtbl p \<equiv> routing_table_semantics rtbl (dst_addr p)"

lemma routing_table_semantics_ports_from_table: "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow>
  routing_table_semantics rtbl packet = ports \<Longrightarrow> ports \<in> set (map routing_action rtbl)"
proof(induction rtbl)
  case (Cons r rs)
  note v_pfxs = valid_prefixes_split[OF Cons.prems(1)]
  show ?case
  proof(cases "pfxm_length (routing_match r) = 0")
    case True
    have "routing_action r = ports" using zero_prefix_match_all[OF conjunct1[OF v_pfxs] True] Cons.prems(3) by simp
    then show ?thesis by simp
  next
    case False
    hence "has_default_route rs" using Cons.prems(2) by simp
    from Cons.IH[OF conjunct2[OF v_pfxs] this] Cons.prems(3) show ?thesis by force
  qed
qed simp

end


(*  Title:      While_Combinator_Exts.thy
    Author:     Denis Lohner
*)

section \<open>Code Generation\<close>
subsection \<open>While Combinator Extensions\<close>

theory While_Combinator_Exts imports
  "HOL-Library.While_Combinator"
begin
lemma while_option_None_invD:
  assumes "while_option b c s = None" and "wf r"
  and "I s" and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> I (c s)"
  and "\<And>s. \<lbrakk> I s; b s \<rbrakk> \<Longrightarrow> (c s, s ) \<in> r"
  shows "False"
  using assms
  by -(drule wf_rel_while_option_Some [of r I b c], auto)

lemma while_option_NoneD:
  assumes "while_option b c s = None"
  and "wf r" and "\<And>s. b s \<Longrightarrow> (c s, s) \<in> r"
  shows "False"
  using assms
  by (blast intro: while_option_None_invD)

lemma while_option_sim:
  assumes start: "R (Some s1) (Some s2)"
  and cond: "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1 \<rbrakk> \<Longrightarrow> b1 s1 = b2 s2"
  and step : "\<And>s1 s2. \<lbrakk> R (Some s1) (Some s2); I s1; b1 s1 \<rbrakk> \<Longrightarrow> R (Some (c1 s1)) (Some (c2 s2))"
  and diverge: "R None None"
  and inv_start: "I s1"
  and inv_step: "\<And>s1. \<lbrakk> I s1; b1 s1 \<rbrakk> \<Longrightarrow> I (c1 s1)"
  shows "R (while_option b1 c1 s1) (while_option b2 c2 s2)"
proof -
  { fix k
    assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
    with start cond step inv_start inv_step
    have "b1 ((c1 ^^ k) s1) = b2 ((c2 ^^ k) s2)" and "I ((c1 ^^ k) s1)"
      and "R (Some ((c1 ^^ k) s1)) (Some ((c2 ^^ k) s2))"
      by (induction k) auto
  }
  moreover
  { fix k
    assume "\<not> b1 ((c1 ^^ k) s1)"
    hence "\<forall>k' < LEAST k. \<not> b1 ((c1 ^^ k) s1). b1 ((c1 ^^ k') s1)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  { fix k
    assume "\<not> b2 ((c2 ^^ k) s2)"
    hence "\<forall>k' < LEAST k. \<not> b2 ((c2 ^^ k) s2). b2 ((c2 ^^ k') s2)"
      by (metis (lifting) not_less_Least)
  }
  moreover
  {
    assume "\<exists>k. \<not> b1 ((c1 ^^ k) s1)"
      and "\<exists>k. \<not> b2 ((c2 ^^ k) s2)"
    hence not_cond_Least: "\<not> b1 ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1)"
      "\<not> b2 ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2)"
      by -(drule LeastI_ex, assumption)+
    { fix k
      assume "\<forall>k' < k. b1 ((c1 ^^ k') s1)"
      with calculation(1) dual_order.strict_trans
      have "\<forall>k' < k. b2 ((c2 ^^ k') s2)"
        by blast
    }
    hence "(LEAST k'. \<not> b1 ((c1 ^^ k') s1)) = (LEAST k'. \<not> b2 ((c2 ^^ k') s2))"
      by (metis (no_types, lifting) not_cond_Least calculation(1,4,5) less_linear)
    with calculation(3,4)
    have "R (Some ((c1 ^^ (LEAST k. \<not> b1 ((c1 ^^ k) s1))) s1))
      (Some ((c2 ^^ (LEAST k. \<not> b2 ((c2 ^^ k) s2))) s2))"
      by auto
  }
  ultimately show ?thesis using diverge
    unfolding while_option_def
    apply (split if_split)
    apply (rule conjI)
     apply (split if_split)
     apply metis
    apply (split if_split)
    by (metis (lifting) LeastI_ex)
qed

end