section \<open>{Assert and Assume}\<close>
theory RefineG_Assert
imports RefineG_Transfer
begin

definition "iASSERT return \<Phi> \<equiv> if \<Phi> then return () else top"
definition "iASSUME return \<Phi> \<equiv> if \<Phi> then return () else bot"

  locale generic_Assert =
    fixes bind ::
      "('mu::complete_lattice) \<Rightarrow> (unit \<Rightarrow> ('ma::complete_lattice)) \<Rightarrow> 'ma"
    fixes return :: "unit \<Rightarrow> 'mu"
    fixes ASSERT
    fixes ASSUME
    assumes ibind_strict:
      "bind bot f = bot"
      "bind top f = top"
    assumes imonad1: "bind (return u) f = f u"
    assumes ASSERT_eq: "ASSERT \<equiv> iASSERT return"
    assumes ASSUME_eq: "ASSUME \<equiv> iASSUME return"
  begin
     lemma ASSERT_simps[simp,code]:
      "ASSERT True = return ()"
      "ASSERT False = top"
      unfolding ASSERT_eq iASSERT_def by auto

    lemma ASSUME_simps[simp,code]:
      "ASSUME True = return ()"
      "ASSUME False = bot"
      unfolding ASSUME_eq iASSUME_def by auto

    lemma le_ASSERTI: "\<lbrakk> \<Phi> \<Longrightarrow> M\<le>M' \<rbrakk> \<Longrightarrow> M \<le> bind (ASSERT \<Phi>) (\<lambda>_. M')"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)

    lemma le_ASSERTI_pres: "\<lbrakk> \<Phi> \<Longrightarrow> M\<le>bind (ASSERT \<Phi>) (\<lambda>_. M') \<rbrakk>
      \<Longrightarrow> M \<le> bind (ASSERT \<Phi>) (\<lambda>_. M')"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)

    lemma ASSERT_leI: "\<lbrakk> \<Phi>; \<Phi> \<Longrightarrow> M\<le>M' \<rbrakk> \<Longrightarrow> bind (ASSERT \<Phi>) (\<lambda>_. M) \<le> M'"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)

    lemma ASSUME_leI: "\<lbrakk> \<Phi> \<Longrightarrow> M\<le>M' \<rbrakk> \<Longrightarrow> bind (ASSUME \<Phi>) (\<lambda>_. M) \<le> M'"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)
    lemma ASSUME_leI_pres: "\<lbrakk> \<Phi> \<Longrightarrow> bind (ASSUME \<Phi>) (\<lambda>_. M)\<le>M' \<rbrakk>
      \<Longrightarrow> bind (ASSUME \<Phi>) (\<lambda>_. M) \<le> M'"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)
    lemma le_ASSUMEI: "\<lbrakk> \<Phi>; \<Phi> \<Longrightarrow> M\<le>M' \<rbrakk> \<Longrightarrow> M \<le> bind (ASSUME \<Phi>) (\<lambda>_. M')"
      apply (cases \<Phi>) by (auto simp: ibind_strict imonad1)

    text \<open>The order of these declarations does matter!\<close>
    lemmas [intro?] = ASSERT_leI le_ASSUMEI
    lemmas [intro?] = le_ASSERTI ASSUME_leI

    lemma ASSERT_le_iff:
      "bind (ASSERT \<Phi>) (\<lambda>_. S) \<le> S' \<longleftrightarrow> (S'\<noteq>top \<longrightarrow> \<Phi>) \<and> S\<le>S'"
      by (cases \<Phi>) (auto simp: ibind_strict imonad1 simp: top_unique)

    lemma ASSUME_le_iff:
      "bind (ASSUME \<Phi>) (\<lambda>_. S) \<le> S' \<longleftrightarrow> (\<Phi> \<longrightarrow> S\<le>S')"
      by (cases \<Phi>) (auto simp: ibind_strict imonad1)

    lemma le_ASSERT_iff:
      "S \<le> bind (ASSERT \<Phi>) (\<lambda>_. S') \<longleftrightarrow> (\<Phi> \<longrightarrow> S\<le>S')"
      by (cases \<Phi>) (auto simp: ibind_strict imonad1)

    lemma le_ASSUME_iff:
      "S \<le> bind (ASSUME \<Phi>) (\<lambda>_. S') \<longleftrightarrow> (S\<noteq>bot \<longrightarrow> \<Phi>) \<and> S\<le>S'"
      by (cases \<Phi>) (auto simp: ibind_strict imonad1 simp: bot_unique)
  end

  text \<open>
    This locale transfer's asserts and assumes.
    To remove them, use the next locale.
\<close>
  locale transfer_generic_Assert =
    c: generic_Assert cbind creturn cASSERT cASSUME +
    a: generic_Assert abind areturn aASSERT aASSUME +
    ordered_transfer \<alpha>
    for cbind :: "('muc::complete_lattice)
      \<Rightarrow> (unit\<Rightarrow>'mac) \<Rightarrow> ('mac::complete_lattice)"
    and creturn :: "unit \<Rightarrow> 'muc" and cASSERT and cASSUME
    and abind :: "('mua::complete_lattice)
      \<Rightarrow> (unit\<Rightarrow>'maa) \<Rightarrow> ('maa::complete_lattice)"
    and areturn :: "unit \<Rightarrow> 'mua" and aASSERT and aASSUME
    and \<alpha> :: "'mac \<Rightarrow> 'maa"
  begin
    lemma transfer_ASSERT[refine_transfer]:
      "\<lbrakk>\<Phi> \<Longrightarrow> \<alpha> M \<le> M'\<rbrakk>
      \<Longrightarrow> \<alpha> (cbind (cASSERT \<Phi>) (\<lambda>_. M)) \<le> (abind (aASSERT \<Phi>) (\<lambda>_. M'))"
      apply (cases \<Phi>)
      apply (auto simp: c.ibind_strict a.ibind_strict c.imonad1 a.imonad1)
      done

    lemma transfer_ASSUME[refine_transfer]:
      "\<lbrakk>\<Phi>; \<Phi> \<Longrightarrow> \<alpha> M \<le> M'\<rbrakk>
      \<Longrightarrow> \<alpha> (cbind (cASSUME \<Phi>) (\<lambda>_. M)) \<le> (abind (aASSUME \<Phi>) (\<lambda>_. M'))"
      apply (auto simp: c.ibind_strict a.ibind_strict c.imonad1 a.imonad1)
      done

  end

  locale transfer_generic_Assert_remove =
    a: generic_Assert abind areturn aASSERT aASSUME +
    transfer \<alpha>
    for abind :: "('mua::complete_lattice)
      \<Rightarrow> (unit\<Rightarrow>'maa) \<Rightarrow> ('maa::complete_lattice)"
    and areturn :: "unit \<Rightarrow> 'mua" and aASSERT and aASSUME
    and \<alpha> :: "'mac \<Rightarrow> 'maa"
  begin
    lemma transfer_ASSERT_remove[refine_transfer]:
      "\<lbrakk> \<Phi> \<Longrightarrow> \<alpha> M \<le> M' \<rbrakk> \<Longrightarrow> \<alpha> M \<le> abind (aASSERT \<Phi>) (\<lambda>_. M')"
      by (rule a.le_ASSERTI)

    lemma transfer_ASSUME_remove[refine_transfer]:
      "\<lbrakk> \<Phi>; \<Phi> \<Longrightarrow> \<alpha> M \<le> M' \<rbrakk> \<Longrightarrow> \<alpha> M \<le> abind (aASSUME \<Phi>) (\<lambda>_. M')"
      by (rule a.le_ASSUMEI)
  end

end


(*<*)
theory Sugar
imports
  "~~/src/HOL/Library/LaTeXsugar"
  "~~/src/HOL/Library/OptionalSugar"
begin
no_translations
  ("prop") "P \<and> Q \<Longrightarrow> R" <= ("prop") "P \<Longrightarrow> Q \<Longrightarrow> R"
(*>*)
text{*
\section{Introduction}

This document is for those Isabelle users who have mastered
the art of mixing \LaTeX\ text and Isabelle theories and never want to
typeset a theorem by hand anymore because they have experienced the
bliss of writing \verb!@!\verb!{thm[display,mode=latex_sum] sum_Suc_diff [no_vars]}!
and seeing Isabelle typeset it for them:
@{thm[display,mode=latex_sum] sum_Suc_diff[no_vars]}
No typos, no omissions, no sweat.
If you have not experienced that joy, read Chapter 4, \emph{Presenting
Theories}, @{cite LNCS2283} first.

If you have mastered the art of Isabelle's \emph{antiquotations},
i.e.\ things like the above \verb!@!\verb!{thm...}!, beware: in your vanity
you may be tempted to think that all readers of the stunning
documents you can now produce at the drop of a hat will be struck with
awe at the beauty unfolding in front of their eyes. Until one day you
come across that very critical of readers known as the ``common referee''.
He has the nasty habit of refusing to understand unfamiliar notation
like Isabelle's infamous @{text"\<lbrakk> \<rbrakk> \<Longrightarrow>"} no matter how many times you
explain it in your paper. Even worse, he thinks that using @{text"\<lbrakk>
\<rbrakk>"} for anything other than denotational semantics is a cardinal sin
that must be punished by instant rejection.

This document shows you how to make Isabelle and \LaTeX\ cooperate to
produce ordinary looking mathematics that hides the fact that it was
typeset by a machine. You merely need to load the right files:
\begin{itemize}
\item Import theory \texttt{LaTeXsugar} in the header of your own
theory.  You may also want bits of \texttt{OptionalSugar}, which you can
copy selectively into your own theory or import as a whole.  Both
theories live in \texttt{HOL/Library}.

\item Should you need additional \LaTeX\ packages (the text will tell
you so), you include them at the beginning of your \LaTeX\ document,
typically in \texttt{root.tex}. For a start, you should
\verb!\usepackage{amssymb}! --- otherwise typesetting
@{prop[source]"\<not>(\<exists>x. P x)"} will fail because the AMS symbol
@{text"\<nexists>"} is missing.
\end{itemize}

\section{HOL syntax}

\subsection{Logic}

The formula @{prop[source]"\<not>(\<exists>x. P x)"} is typeset as @{prop"~(EX x. P x)"}.

The predefined constructs @{text"if"}, @{text"let"} and
@{text"case"} are set in sans serif font to distinguish them from
other functions. This improves readability:
\begin{itemize}
\item @{term"if b then e\<^sub>1 else e\<^sub>2"} instead of @{text"if b then e\<^sub>1 else e\<^sub>2"}.
\item @{term"let x = e\<^sub>1 in e\<^sub>2"} instead of @{text"let x = e\<^sub>1 in e\<^sub>2"}.
\item @{term"case x of True \<Rightarrow> e\<^sub>1 | False \<Rightarrow> e\<^sub>2"} instead of\\
      @{text"case x of True \<Rightarrow> e\<^sub>1 | False \<Rightarrow> e\<^sub>2"}.
\end{itemize}

\subsection{Sets}

Although set syntax in HOL is already close to
standard, we provide a few further improvements:
\begin{itemize}
\item @{term"{x. P}"} instead of @{text"{x. P}"}.
\item @{term"{}"} instead of @{text"{}"}, where
 @{term"{}"} is also input syntax.
\item @{term"insert a (insert b (insert c M))"} instead of @{text"insert a (insert b (insert c M))"}.
\item @{term"card A"} instead of @{text"card A"}.
\end{itemize}

\subsection{Lists}

If lists are used heavily, the following notations increase readability:
\begin{itemize}
\item @{term"x # xs"} instead of @{text"x # xs"},
      where @{term"x # xs"} is also input syntax.
\item @{term"length xs"} instead of @{text"length xs"}.
\item @{term"nth xs n"} instead of @{text"nth xs n"},
      the $n$th element of @{text xs}.

\item Human readers are good at converting automatically from lists to
sets. Hence \texttt{OptionalSugar} contains syntax for suppressing the
conversion function @{const set}: for example, @{prop[source]"x \<in> set xs"}
becomes @{prop"x \<in> set xs"}.

\item The @{text"@"} operation associates implicitly to the right,
which leads to unpleasant line breaks if the term is too long for one
line. To avoid this, \texttt{OptionalSugar} contains syntax to group
@{text"@"}-terms to the left before printing, which leads to better
line breaking behaviour:
@{term[display]"term\<^sub>0 @ term\<^sub>1 @ term\<^sub>2 @ term\<^sub>3 @ term\<^sub>4 @ term\<^sub>5 @ term\<^sub>6 @ term\<^sub>7 @ term\<^sub>8 @ term\<^sub>9 @ term\<^sub>1\<^sub>0"}

\end{itemize}

\subsection{Numbers}

Coercions between numeric types are alien to mathematicians who
consider, for example, @{typ nat} as a subset of @{typ int}.
\texttt{OptionalSugar} contains syntax for suppressing numeric coercions such
as @{const int} @{text"::"} @{typ"nat \<Rightarrow> int"}. For example,
@{term[source]"int 5"} is printed as @{term "int 5"}. Embeddings of types
@{typ nat}, @{typ int}, @{typ real} are covered; non-injective coercions such
as @{const nat} @{text"::"} @{typ"int \<Rightarrow> nat"} are not and should not be
hidden.

\section{Printing theorems}

The @{prop "P \<Longrightarrow> Q \<Longrightarrow> R"} syntax is a bit idiosyncratic. If you would like
to avoid it, you can easily print the premises as a conjunction:
@{prop "P \<and> Q \<Longrightarrow> R"}. See \texttt{OptionalSugar} for the required ``code''.

\subsection{Question marks}

If you print anything, especially theorems, containing
schematic variables they are prefixed with a question mark:
\verb!@!\verb!{thm conjI}! results in @{thm conjI}. Most of the time
you would rather not see the question marks. There is an attribute
\verb!no_vars! that you can attach to the theorem that turns its
schematic into ordinary free variables:
\begin{quote}
\verb!@!\verb!{thm conjI[no_vars]}!\\
\showout @{thm conjI[no_vars]}
\end{quote}
This \verb!no_vars! business can become a bit tedious.
If you would rather never see question marks, simply put
\begin{quote}
\verb!options [show_question_marks = false]!
\end{quote}
into the relevant \texttt{ROOT} file, just before the \texttt{theories} for that session.
The rest of this document is produced with this flag set to \texttt{false}.
*}

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

subsection {*Qualified names*}

text{* If there are multiple declarations of the same name, Isabelle prints
the qualified name, for example @{text "T.length"}, where @{text T} is the
theory it is defined in, to distinguish it from the predefined @{const[source]
"List.length"}. In case there is no danger of confusion, you can insist on
short names (no qualifiers) by setting the \verb!names_short!
configuration option in the context.

\subsection {Variable names\label{sec:varnames}}

It sometimes happens that you want to change the name of a
variable in a theorem before printing it. This can easily be achieved
with the help of Isabelle's instantiation attribute \texttt{where}:
\begin{quote}
\verb!@!\verb!{thm conjI[where P = \<phi> and Q = \<psi>]}!\\
\showout @{thm conjI[where P = \<phi> and Q = \<psi>]}
\end{quote}
To support the ``\_''-notation for irrelevant variables
the constant \texttt{DUMMY} has been introduced:
\begin{quote}
\verb!@!\verb!{thm fst_conv[of _ DUMMY]}!\\
\showout @{thm fst_conv[of _ DUMMY]}
\end{quote}
As expected, the second argument has been replaced by ``\_'',
but the first argument is the ugly @{text "x1.0"}, a schematic variable
with suppressed question mark. Schematic variables that end in digits,
e.g. @{text"x1"}, are still printed with a trailing @{text".0"},
e.g. @{text"x1.0"}, their internal index. This can be avoided by
turning the last digit into a subscript: write \<^verbatim>\<open>x\<^sub>1\<close> and
obtain the much nicer @{text"x\<^sub>1"}. Alternatively, you can display trailing digits of
schematic and free variables as subscripts with the \texttt{sub} style:
\begin{quote}
\verb!@!\verb!{thm (sub) fst_conv[of _ DUMMY]}!\\
\showout @{thm (sub) fst_conv[of _ DUMMY]}
\end{quote}
The insertion of underscores can be automated with the \verb!dummy_pats! style:
\begin{quote}
\verb!@!\verb!{thm (dummy_pats,sub) fst_conv}!\\
\showout @{thm (dummy_pats,sub) fst_conv}
\end{quote}
The theorem must be an equation. Then every schematic variable that occurs
on the left-hand but not the right-hand side is replaced by \texttt{DUMMY}.
This is convenient for displaying functional programs.

Variables that are bound by quantifiers or lambdas can be renamed
with the help of the attribute \verb!rename_abs!.
It expects a list of names or underscores, similar to the \texttt{of} attribute:
\begin{quote}
\verb!@!\verb!{thm split_paired_All[rename_abs _ l r]}!\\
\showout @{thm split_paired_All[rename_abs _ l r]}
\end{quote}

\subsection{Inference rules}

To print theorems as inference rules you need to include Didier
R\'emy's \texttt{mathpartir} package~@{cite mathpartir}
for typesetting inference rules in your \LaTeX\ file.

Writing \verb!@!\verb!{thm[mode=Rule] conjI}! produces
@{thm[mode=Rule] conjI}, even in the middle of a sentence.
If you prefer your inference rule on a separate line, maybe with a name,
\begin{center}
@{thm[mode=Rule] conjI} {\sc conjI}
\end{center}
is produced by
\begin{quote}
\verb!\begin{center}!\\
\verb!@!\verb!{thm[mode=Rule] conjI} {\sc conjI}!\\
\verb!\end{center}!
\end{quote}
It is not recommended to use the standard \texttt{display} option
together with \texttt{Rule} because centering does not work and because
the line breaking mechanisms of \texttt{display} and \texttt{mathpartir} can
clash.

Of course you can display multiple rules in this fashion:
\begin{quote}
\verb!\begin{center}!\\
\verb!@!\verb!{thm[mode=Rule] conjI} {\sc conjI} \\[1ex]!\\
\verb!@!\verb!{thm[mode=Rule] conjE} {\sc disjI$_1$} \qquad!\\
\verb!@!\verb!{thm[mode=Rule] disjE} {\sc disjI$_2$}!\\
\verb!\end{center}!
\end{quote}
yields
\begin{center}\small
@{thm[mode=Rule] conjI} {\sc conjI} \\[1ex]
@{thm[mode=Rule] disjI1} {\sc disjI$_1$} \qquad
@{thm[mode=Rule] disjI2} {\sc disjI$_2$}
\end{center}

The \texttt{mathpartir} package copes well if there are too many
premises for one line:
\begin{center}
@{prop[mode=Rule] "\<lbrakk> A \<longrightarrow> B; B \<longrightarrow> C; C \<longrightarrow> D; D \<longrightarrow> E; E \<longrightarrow> F; F \<longrightarrow> G;
 G \<longrightarrow> H; H \<longrightarrow> I; I \<longrightarrow> J; J \<longrightarrow> K \<rbrakk> \<Longrightarrow> A \<longrightarrow> K"}
\end{center}

Limitations: 1. Premises and conclusion must each not be longer than
the line.  2. Premises that are @{text"\<Longrightarrow>"}-implications are again
displayed with a horizontal line, which looks at least unusual.

In case you print theorems without premises no rule will be printed by the
\texttt{Rule} print mode. However, you can use \texttt{Axiom} instead:
\begin{quote}
\verb!\begin{center}!\\
\verb!@!\verb!{thm[mode=Axiom] refl} {\sc refl}! \\
\verb!\end{center}!
\end{quote}
yields
\begin{center}
@{thm[mode=Axiom] refl} {\sc refl}
\end{center}

\subsection{Displays and font sizes}

When displaying theorems with the \texttt{display} option, for example as in
\verb!@!\verb!{thm[display] refl}! @{thm[display] refl} the theorem is
set in small font. It uses the \LaTeX-macro \verb!\isastyle!,
which is also the style that regular theory text is set in, e.g. *}

lemma "t = t"
(*<*)oops(*>*)

text{* \noindent Otherwise \verb!\isastyleminor! is used,
which does not modify the font size (assuming you stick to the default
\verb!\isabellestyle{it}! in \texttt{root.tex}). If you prefer
normal font size throughout your text, include
\begin{quote}
\verb!\renewcommand{\isastyle}{\isastyleminor}!
\end{quote}
in \texttt{root.tex}. On the other hand, if you like the small font,
just put \verb!\isastyle! in front of the text in question,
e.g.\ at the start of one of the center-environments above.

The advantage of the display option is that you can display a whole
list of theorems in one go. For example,
\verb!@!\verb!{thm[display] append.simps}!
generates @{thm[display] append.simps}

\subsection{If-then}

If you prefer a fake ``natural language'' style you can produce
the body of
\newtheorem{theorem}{Theorem}
\begin{theorem}
@{thm[mode=IfThen] le_trans}
\end{theorem}
by typing
\begin{quote}
\verb!@!\verb!{thm[mode=IfThen] le_trans}!
\end{quote}

In order to prevent odd line breaks, the premises are put into boxes.
At times this is too drastic:
\begin{theorem}
@{prop[mode=IfThen] "longpremise \<Longrightarrow> longerpremise \<Longrightarrow> P(f(f(f(f(f(f(f(f(f(x)))))))))) \<Longrightarrow> longestpremise \<Longrightarrow> conclusion"}
\end{theorem}
In which case you should use \texttt{IfThenNoBox} instead of
\texttt{IfThen}:
\begin{theorem}
@{prop[mode=IfThenNoBox] "longpremise \<Longrightarrow> longerpremise \<Longrightarrow> P(f(f(f(f(f(f(f(f(f(x)))))))))) \<Longrightarrow> longestpremise \<Longrightarrow> conclusion"}
\end{theorem}

\subsection{Doing it yourself\label{sec:yourself}}

If for some reason you want or need to present theorems your
own way, you can extract the premises and the conclusion explicitly
and combine them as you like:
\begin{itemize}
\item \verb!@!\verb!{thm (prem 1)! $thm$\verb!}!
prints premise 1 of $thm$.
\item \verb!@!\verb!{thm (concl)! $thm$\verb!}!
prints the conclusion of $thm$.
\end{itemize}
For example, ``from @{thm (prem 2) conjI} and
@{thm (prem 1) conjI} we conclude @{thm (concl) conjI}''
is produced by
\begin{quote}
\verb!from !\verb!@!\verb!{thm (prem 2) conjI}! \verb!and !\verb!@!\verb!{thm (prem 1) conjI}!\\
\verb!we conclude !\verb!@!\verb!{thm (concl) conjI}!
\end{quote}
Thus you can rearrange or hide premises and typeset the theorem as you like.
Styles like \verb!(prem 1)! are a general mechanism explained
in \S\ref{sec:styles}.

\subsection{Patterns}

In \S\ref{sec:varnames} we shows how to create patterns containing ``@{term DUMMY}''.
You can drive this game even further and extend the syntax of let
bindings such that certain functions like @{term fst}, @{term hd},
etc.\ are printed as patterns. \texttt{OptionalSugar} provides the following:

\begin{center}
\begin{tabular}{l@ {~~produced by~~}l}
@{term "let x = fst p in t"} & \verb!@!\verb!{term "let x = fst p in t"}!\\
@{term "let x = snd p in t"} & \verb!@!\verb!{term "let x = snd p in t"}!\\
@{term "let x = hd xs in t"} & \verb!@!\verb!{term "let x = hd xs in t"}!\\
@{term "let x = tl xs in t"} & \verb!@!\verb!{term "let x = tl xs in t"}!\\
@{term "let x = the y in t"} & \verb!@!\verb!{term "let x = the y in t"}!\\
\end{tabular}
\end{center}

\section {Styles\label{sec:styles}}

The \verb!thm! antiquotation works nicely for single theorems, but
sets of equations as used in definitions are more difficult to
typeset nicely: people tend to prefer aligned @{text "="} signs.

To deal with such cases where it is desirable to dive into the structure
of terms and theorems, Isabelle offers antiquotations featuring ``styles'':

\begin{quote}
\verb!@!\verb!{thm (style) thm}!\\
\verb!@!\verb!{prop (style) thm}!\\
\verb!@!\verb!{term (style) term}!\\
\verb!@!\verb!{term_type (style) term}!\\
\verb!@!\verb!{typeof (style) term}!\\
\end{quote}

 A ``style'' is a transformation of a term. There are predefined
 styles, namely \verb!lhs! and \verb!rhs!, \verb!prem! with one argument, and \verb!concl!.
For example, the output
\begin{center}
\begin{tabular}{l@ {~~@{text "="}~~}l}
@{thm (lhs) append_Nil} & @{thm (rhs) append_Nil}\\
@{thm (lhs) append_Cons} & @{thm (rhs) append_Cons}
\end{tabular}
\end{center}
is produced by the following code:
\begin{quote}
  \verb!\begin{center}!\\
  \verb!\begin{tabular}{l@ {~~!\verb!@!\verb!{text "="}~~}l}!\\
  \verb!@!\verb!{thm (lhs) append_Nil} & @!\verb!{thm (rhs) append_Nil}\\!\\
  \verb!@!\verb!{thm (lhs) append_Cons} & @!\verb!{thm (rhs) append_Cons}!\\
  \verb!\end{tabular}!\\
  \verb!\end{center}!
\end{quote}
Note the space between \verb!@! and \verb!{! in the tabular argument.
It prevents Isabelle from interpreting \verb!@ {~~...~~}!
as an antiquotation. The styles \verb!lhs! and \verb!rhs!
extract the left hand side (or right hand side respectively) from the
conclusion of propositions consisting of a binary operator
(e.~g.~@{text "="}, @{text "\<equiv>"}, @{text "<"}).

Likewise, \verb!concl! may be used as a style to show just the
conclusion of a proposition. For example, take \verb!hd_Cons_tl!:
\begin{center}
  @{thm hd_Cons_tl}
\end{center}
To print just the conclusion,
\begin{center}
  @{thm (concl) hd_Cons_tl}
\end{center}
type
\begin{quote}
  \verb!\begin{center}!\\
  \verb!@!\verb!{thm (concl) hd_Cons_tl}!\\
  \verb!\end{center}!
\end{quote}
Beware that any options must be placed \emph{before} the style, as in this example.

Further use cases can be found in \S\ref{sec:yourself}.
If you are not afraid of ML, you may also define your own styles.
Have a look at module @{ML_structure Term_Style}.

\section {Proofs}

Full proofs, even if written in beautiful Isar style, are
likely to be too long and detailed to be included in conference
papers, but some key lemmas might be of interest.
It is usually easiest to put them in figures like the one in Fig.\
\ref{fig:proof}. This was achieved with the \isakeyword{text\_raw} command:
*}
text_raw {*
  \begin{figure}
  \begin{center}\begin{minipage}{0.6\textwidth}
  \isastyleminor\isamarkuptrue
*}
lemma True
proof -
  -- "pretty trivial"
  show True by force
qed
text_raw {*
  \end{minipage}\end{center}
  \caption{Example proof in a figure.}\label{fig:proof}
  \end{figure}
*}
text {*

\begin{quote}
\small
\verb!text_raw {!\verb!*!\\
\verb!  \begin{figure}!\\
\verb!  \begin{center}\begin{minipage}{0.6\textwidth}!\\
\verb!  \isastyleminor\isamarkuptrue!\\
\verb!*!\verb!}!\\
\verb!lemma True!\\
\verb!proof -!\\
\verb!  -- "pretty trivial"!\\
\verb!  show True by force!\\
\verb!qed!\\
\verb!text_raw {!\verb!*!\\
\verb!  \end{minipage}\end{center}!\\
\verb!  \caption{Example proof in a figure.}\label{fig:proof}!\\
\verb!  \end{figure}!\\
\verb!*!\verb!}!
\end{quote}

Other theory text, e.g.\ definitions, can be put in figures, too.

\section{Theory snippets}

This section describes how to include snippets of a theory text in some other \LaTeX\ document.
The typical scenario is that the description of your theory is not part of the theory text but
a separate document that antiquotes bits of the theory. This works well for terms and theorems
but there are no antiquotations, for example, for function definitions or proofs. Even if there are antiquotations,
the output is usually a reformatted (by Isabelle) version of the input and may not look like
you wanted it to look. Here is how to include a snippet of theory text (in \LaTeX\ form) in some
other \LaTeX\ document, in 4 easy steps. Beware that these snippets are not processed by
any antiquotation mechanism: the resulting \LaTeX\ text is more or less exactly what you wrote
in the theory, without any added sugar.

\subsection{Theory markup}

Include some markers at the beginning and the end of the theory snippet you want to cut out.
You have to place the following lines before and after the snippet, where snippets must always be
consecutive lines of theory text:
\begin{quote}
\verb!\text_raw{!\verb!*\snip{!\emph{snippetname}\verb!}{1}{2}{%*!\verb!}!\\
\emph{theory text}\\
\verb!\text_raw{!\verb!*!\verb!}%endsnip*!\verb!}!
\end{quote}
where \emph{snippetname} should be a unique name for the snippet. The numbers \texttt{1}
and \texttt{2} are explained in a moment.

\subsection{Generate the \texttt{.tex} file}

Run your theory \texttt{T} with the \texttt{isabelle} \texttt{build} tool
to generate the \LaTeX-file \texttt{T.tex} which is needed for the next step,
extraction of marked snippets.
You may also want to process \texttt{T.tex} to generate a pdf document.
This requires a definition of \texttt{\char`\\snippet}:
\begin{verbatim}
\newcommand{\repeatisanl}[1]
  {\ifnum#1=0\else\isanewline\repeatisanl{\numexpr#1-1}\fi}
\newcommand{\snip}[4]{\repeatisanl#2#4\repeatisanl#3}
\end{verbatim}
Parameter 2 and 3 of \texttt{\char`\\snippet} are numbers (the \texttt{1}
and \texttt{2} above) and determine how many newlines are inserted before and after the snippet.
Unfortunately \texttt{text\_raw} eats up all preceding and following newlines
and they have to be inserted again in this manner. Otherwise the document generated from \texttt{T.tex}
will look ugly around the snippets. It can take some iterations to get the number of required
newlines exactly right.

\subsection{Extract marked snippets}
\label{subsec:extract}

Extract the marked bits of text with a shell-level script, e.g.
\begin{quote}
\verb!sed -n '/\\snip{/,/endsnip/p' T.tex > !\emph{snippets}\verb!.tex!
\end{quote}
File \emph{snippets}\texttt{.tex} (the name is arbitrary) now contains a sequence of blocks like this
\begin{quote}
\verb!\snip{!\emph{snippetname}\verb!}{1}{2}{%!\\
\emph{theory text}\\
\verb!}%endsnip!
\end{quote}

\subsection{Including snippets}

In the preamble of the document where the snippets are to be used you define \texttt{\char`\\snip}
and input \emph{snippets}\texttt{.tex}:
\begin{verbatim}
\newcommand{\snip}[4]
  {\expandafter\newcommand\csname #1\endcsname{#4}}
\input{snippets}
\end{verbatim}
This definition of \texttt{\char`\\snip} simply has the effect of defining for each snippet
\emph{snippetname} a \LaTeX\ command \texttt{\char`\\}\emph{snippetname}
that produces the corresponding snippet text. In the body of your document you can display that text
like this:
\begin{quote}
\verb!\begin{isabelle}!\\
\texttt{\char`\\}\emph{snippetname}\\
\verb!\end{isabelle}!
\end{quote}
The \texttt{isabelle} environment is the one defined in the standard file
\texttt{isabelle.sty} which most likely you are loading anyway.

\section{Antiquotation}

You want to show a constant and its type? Instead of going
\verb!@!\verb!{const myconst}! \verb!@!\verb!{text "::"}! \verb!@!\verb!{typeof myconst}!,
you can just write \verb!@!\verb!{const_typ myconst}! using the new antiquotation
\texttt{const\_typ} defined in \texttt{LaTeXsugar}. For example,
\verb!@!\verb!{const_typ length}! produces @{const_typ length}.

*}

(*<*)
end
(*>*)


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

(* License: BSD, terms see file ./LICENSE *)

theory Vanilla32_typinfo
imports "~~/src/HOL/Word/Word"
begin

type_synonym addr = "32 word"

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

lemma addr_card:
  "addr_card = 2^32"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(32) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


(* module shiftmem(clk,rst,shift,d,addr,q);
    parameter	    MSBD = 63;
    parameter	    DEPTH = 31;
    parameter	    MSBA = 4;
    input	    clk;
    input           rst;
    input [MSBD:0]  d;
    input [MSBA:0]  addr;
    input	    shift;
    output [MSBD:0] q;

    reg [MSBD:0]    mem[0:DEPTH];
    reg [MSBA:0]    write_addr;
     //wire [MSBA:0]  read_addr;
	integer i;

	initial begin
	for (i = 0; i <= DEPTH; i = i + 1)
	    mem[i] = 0;
 	write_addr = 0;
    end // initial begin

    always @ (posedge clk) begin
	if (rst) write_addr = 0;
	else if (shift) begin
		mem[write_addr] = d;
	    write_addr = write_addr +1;
	end
    end // always @ (posedge clock)

    assign q = mem[write_addr-1-addr];

endmodule // *)
theory shiftMem imports paraGste1
begin
abbreviation rst::"expType" where
"rst \<equiv> IVar (Ident ''rst'')"

abbreviation shift::"expType" where
"shift \<equiv> IVar (Ident ''shift'')"

abbreviation adr::"expType" where
"adr \<equiv> IVar (Ident ''adr'')"

abbreviation wrt_adr::"expType" where
"wrt_adr \<equiv> IVar (Ident ''wrt_adr'')"

abbreviation dataIn::"expType" where
"dataIn \<equiv> IVar (Ident ''dataIn'' )"

abbreviation LOW::"expType" where
"LOW \<equiv> Const (boolV False)"
abbreviation HIGH::"expType" where
"HIGH \<equiv> Const (boolV True)"

abbreviation mem::"varType" where
"mem \<equiv>  Ident ''mem''"

abbreviation q::"nat\<Rightarrow>expType" where
"q DEPTH \<equiv> read (Ident ''mem'') (DEPTH - 1) (uif  ''-'' [uif ''-'' [wrt_adr, (Const (index 1))],adr ])"

abbreviation rstForm::"formula" where
"rstForm  \<equiv>  (eqn rst HIGH)"

abbreviation shiftForm::"formula" where
"shiftForm \<equiv>  andForm (eqn rst LOW) (eqn shift HIGH)"

abbreviation readForm::"nat\<Rightarrow>formula" where
"readForm age\<equiv>   eqn adr (Const (index age))"

abbreviation initDataForm::"nat \<Rightarrow>formula" where
" initDataForm D \<equiv>andForm shiftForm  (eqn dataIn (Const (index D)))"

abbreviation retainRead::"formula" where
"retainRead \<equiv> andForm (eqn rst LOW) (eqn shift LOW)"

definition  vertexI::"node" where [simp]:
"vertexI \<equiv>Vertex  0"

definition  vertexL::"nat \<Rightarrow> node list" where [simp]:
"vertexL DEPTH  \<equiv>  vertexI # (map (%i. Vertex  i) (down DEPTH))"

definition edgeL::"nat \<Rightarrow> edge list" where [simp]:
 "edgeL DEPTH \<equiv> [Edge vertexI ( Vertex 1)]

    @ [Edge  ( Vertex 1) ( Vertex 2)]

		@(map (%i.  ( Edge (Vertex ( i ))  (Vertex (  i+1 ))) ) (upt 2  (DEPTH +2) ))  (* self-loop*)
	  @(map (%i.  ( Edge (Vertex ( i ))  (Vertex (  i ))) ) (upt 2  (DEPTH +2) ))  (* self-loop*)

	 "

lemma testUpto:"upt 1 3=[Suc 0,2]" apply auto
by (simp add: upt_rec)

primrec node2Nat::"node \<Rightarrow> nat" where
"node2Nat (Vertex n) = n"

definition antOfShiftMem::"nat\<Rightarrow>edge\<Rightarrow>formula" where [simp]:
"antOfShiftMem   D  edge\<equiv>
  (let from=node2Nat (source edge) in
   let to=node2Nat (sink edge) in
     if (	from = 0) then rstForm	else
     if (from=1) then (initDataForm D) else
     if (from = to) then andForm retainRead (readForm (from - 2))
     else    andForm shiftForm (readForm (from -2)))"

definition consOfShiftMem::" nat\<Rightarrow>nat\<Rightarrow>edge \<Rightarrow>formula" where  [simp]:
"consOfShiftMem    D DEPTH edge \<equiv>
(let from=node2Nat (source edge) in
 let to=node2Nat (sink edge) in
 if 	(from =0 \<or> from=1) then
  chaos
 else
  if (to \<le> DEPTH +1) then
  eqn (q DEPTH) (Const (index D))
  else chaos
  )"

definition shiftGsteSpec::" nat\<Rightarrow>nat\<Rightarrow>gsteSpec" where  [simp]:
"shiftGsteSpec DEPTH  data\<equiv>Graph  vertexI (edgeL  DEPTH )
  (antOfShiftMem data )  (consOfShiftMem data  DEPTH)"

primrec applyPlusN::"expType\<Rightarrow>nat \<Rightarrow>expType" where
"applyPlusN e 0=e" |
"applyPlusN e (Suc N) = uif ''+'' [applyPlusN e N, Const (index 1)]"

definition tagFunOfShiftMem:: " nat\<Rightarrow>nat\<Rightarrow>nodeTagFuncList" where [simp]:
"tagFunOfShiftMem DATA DEPTH  n \<equiv>
  let x=node2Nat n in
   let DataE=(Const (index DATA)) in
   if (x = 0) then [] else
    if (x  = 1) then
        [eqn wrt_adr (Const (index 0))]
    (*else if (x=2) then
        [eqn wrt_adr (Const (index 1)),
        eqn  (q 0) DataE
        ] *)
    else if (x \<le> DEPTH +1 ) then
        [eqn wrt_adr (Const (index ((x-1) ) )), eqn  (read mem (DEPTH - 1) (Const (index 0))) DataE]
    else []
 "

 abbreviation branch1::"generalizeStatement" where  (*  assume c1:"s (Ident ''adr'') = index (i - 2)" and
          c2:"s (Ident ''wrt_adr'') = index (i - Suc 0)" and
          c3:"s (Para mem 0) = index data"
        have b2:"expEval J (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) s=
        expEval J (Const (index 0)) s"
        apply(cut_tac b2 c1 c2,auto) done
        have b3:" expEval J
        (caseExp
        (map (\<lambda>i. (eqn (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) (Const (index i)), IVar (Para mem i))) (down DEPTH)))
        s =
        expEval J  (IVar (Para mem 0)) s"
        apply(cut_tac b2,auto) done
        show "expEval J
        (caseExp
          (map (\<lambda>i. (eqn (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) (Const (index i)), IVar (Para mem i)))
            (down DEPTH)))  s =
        index data "
       done*)
"branch1 \<equiv>
  (let S1=assign (Ident ''wrt_adr'',(Const (index 0))) in
   Parallel [S1])"

abbreviation branch2::"nat\<Rightarrow>generalizeStatement" where
"branch2 DEPTH \<equiv>
  (let S1=map (\<lambda>i. assign ((Para (Ident ''mem'') i),
    iteForm (eqn wrt_adr (Const (index i)))  dataIn
    (IVar (Para (Ident ''mem'')  i)))) (down (DEPTH - 1) ) in
   let wrtAdrPlus=uif ''+'' [wrt_adr, (Const (index 1))] in
   let S2=assign (Ident ''wrt_adr'', wrtAdrPlus ) in
   Parallel (S2#S1))"

abbreviation shiftMem::" nat\<Rightarrow>generalizeStatement" where
"shiftMem  DEPTH\<equiv>
  caseStatement
     [(eqn rst HIGH, branch1),
      (eqn shift HIGH , branch2 DEPTH)]
   "

consts J::"nat \<Rightarrow>  interpretFunType"

axiomatization where axiomOnIAdd [simp,intro]:
" J DEPTH ''+'' [index m, index (Suc 0)] = index ((m + 1))"
(* (if m=DEPTH  then (index 0) else (index (m +1 )))"
index ((m + 1) mod (Suc DEPTH  )) " *)

axiomatization where axiomOnISub [simp,intro ]: "  J DEPTH  ''-'' [index m, index n] = index (m - n)"
(*axiomatization where axiomOnLe [simp,intro]:
"  J DEPTH  ''le'' [index m, index n]  = boolV (m \<le> n)" *)
(*  axiomatization where axiomOn_procCmd  [simp]:"   s (IVar (Para ''procCmd'' i )) \<in> NODE_CMDType "*)

(*lemma test4:"m - 1< DEPTH \<and> 1 \<le> m \<Longrightarrow>I DEPTH ''+'' [index( m - 1 ), index 1] = index ((m   ) )"
apply auto done*)
(*lemma aux1:"J DEPTH ''+'' [index m, index (Suc 0)] \<noteq> index m"

using axiomOnIAdd by simp*)
(*lemma aux2:"
substExp (caseExp (map (\<lambda>i. (f i, IVar (Para mem i))) (down DEPTH)))
            ((Ident v, e) #AS) =
substExp (caseExp (map (\<lambda>i. (f i, IVar (Para mem i))) (down DEPTH)))
            AS           "
proof(induct_tac DEPTH, auto   )
lemma existI:
assumes a1:"formEval  J (uip ''le'' [head,LASTE]) s"
shows "\<exists>i. ((s (Ident ''head'') ) = (index i))" (*  assume c1:"s (Ident ''adr'') = index (i - 2)" and
          c2:"s (Ident ''wrt_adr'') = index (i - Suc 0)" and
          c3:"s (Para mem 0) = index data"
        have b2:"expEval J (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) s=
        expEval J (Const (index 0)) s"
        apply(cut_tac b2 c1 c2,auto) done
        have b3:" expEval J
        (caseExp
        (map (\<lambda>i. (eqn (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) (Const (index i)), IVar (Para mem i))) (down DEPTH)))
        s =
        expEval J  (IVar (Para mem 0)) s"
        apply(cut_tac b2,auto) done
        show "expEval J
        (caseExp
          (map (\<lambda>i. (eqn (uif ''-'' [uif ''-'' [wrt_adr, Const (index (Suc 0))], adr]) (Const (index i)), IVar (Para mem i)))
            (down DEPTH)))  s =
        index data "
       done*)
proof(cut_tac a1,case_tac "s (Ident ''head'')",auto)
qed*)

lemma auxOnReadWrite[simp]:
"expEval I e s=expEval I e' s \<and>expEval I e s=index i\<and> i\<le> DEPTH \<longrightarrow>(\<forall>j. Para mem j \<notin>set (varOfExp e'))\<longrightarrow>

        expEval I  (substExp (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down DEPTH)))
            (map (\<lambda>i. (Para mem i, iteForm (eqn e (Const (index i))) e'' (IVar (Para mem i))))
              (down DEPTH)))
          s = expEval I e'' s "   (is "?P DEPTH")
proof(induct_tac DEPTH)
  show "?P 0"
  proof(rule impI)+
  assume a1:" expEval I e s = expEval I e' s \<and> expEval I e s = index i \<and> i \<le> 0" and
   a2:" \<forall>j. Para mem j \<notin> set (varOfExp e')"
   have a3:"(Para mem 0) \<notin> set (varOfExp e')"
    by(cut_tac a2,auto)
  show " expEval I
     (substExp (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down 0)))
       (map (\<lambda>i. (Para mem i, iteForm (eqn e (Const (index i))) e'' (IVar (Para mem i)))) (down 0)))
     s =
    expEval I e'' s"
   using a1 a3 noEffectSubstExp proof(cut_tac a1,auto)qed
   qed
  next
  fix n
  assume a0:  "?P n"
  show "?P (Suc n)"
  proof(rule impI)+
  assume a1:" expEval I e s = expEval I e' s \<and> expEval I e s = index i \<and> i \<le> Suc n" and
   a2:" \<forall>j. Para mem j \<notin> set (varOfExp e')"
   have a3:"(Para mem  (Suc n)) \<notin> set (varOfExp e')"
    by(cut_tac a2,auto)
   show "expEval I
     (substExp (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down (Suc n))))
       (map (\<lambda>i. (Para mem i, iteForm (eqn e (Const (index i))) e'' (IVar (Para mem i)))) (down (Suc n))))
     s =
    expEval I e'' s" (is "?LHS (Suc n) =?RHS")
   proof(case_tac "i \<le> n")
     assume b1:"i \<le> n"
     have b2:" (Para mem (Suc n)) \<notin> set (varOfExp
     (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down n))))"
      apply(auto)
      apply (simp add: SucnIsNotInDownn)
      by (simp add: a3)

     have b3:"?LHS (Suc n) =?LHS n"
     using a1 a2 a3 b1 b2 by auto
     have b4:"?LHS n =   expEval I e'' s"
     using a1 b1 a2 a0 apply auto  done
     show "?LHS (Suc n) =?RHS"
     using b4 b3 by auto
   next
    assume b1:"\<not>i \<le> n"
    have b2:"i=Suc n"
    using b1 a1 by auto
    show "?LHS (Suc n) =?RHS"
     using b1 b2 a1 a2 a3  apply auto done
  qed
qed
qed

lemma aux1[simp]:"expEval (J DEPTH0) (caseExp (map (\<lambda>i. (eqn (Const (index 0)) (Const (index i)), IVar (Para mem i))) (down DEPTH))) s =
 expEval (J DEPTH0) (IVar ( Para mem 0)) s"
proof(induct_tac DEPTH,auto)
qed

lemma aux2[simp]:

  shows "
         expEval (J DEPTH0)
          (substExp (caseExp (map (\<lambda>i. (eqn (Const (index 0)) (Const (index i)), IVar (Para mem i))) (down DEPTH)))
            subst)
          s =expEval (J DEPTH0) (substExp (IVar (Para mem 0))
          subst) s "
  (is "?P DEPTH")
proof(induct_tac DEPTH)
  show "?P 0"  apply( auto) done
  next
  fix n
  assume b0:"?P n"
  have b1:"expEval (J DEPTH0)
          (substExp (caseExp (map (\<lambda>i. (eqn (Const (index 0)) (Const (index i)), IVar (Para mem i))) (down (Suc n))))
            subst)
          s=expEval (J DEPTH0)
          (substExp (caseExp (map (\<lambda>i. (eqn (Const (index 0)) (Const (index i)), IVar (Para mem i))) (down ( n))))
            subst)
          s"
          apply auto done

  show "?P (Suc n)" by(cut_tac b0 b1,auto)
qed

lemma onMem0[simp]:
  shows "
          (substExp (IVar (Para mem 0))
            (map (\<lambda>i. (Para mem i, iteForm (eqn wrt_adr (Const (index i))) dataIn (IVar (Para mem i)))) (down DEPTH)))  =
        iteForm (eqn wrt_adr (Const (index 0))) dataIn (IVar (Para mem 0))"
proof(induct_tac DEPTH,auto)    qed

lemma caseExpCong:
  assumes a:"tautlogy (eqn e e') I"
  shows "expEval I   (caseExp (map (\<lambda>i. (eqn e (Const (index i)), IVar (Para mem i))) (down DEPTH))) s
  =expEval I  (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down DEPTH))) s"
proof(induct_tac DEPTH,(cut_tac a,simp)+)qed

lemma caseExpCong1:
  assumes a:"formEval I (eqn e e') s "
  shows "expEval I   (caseExp (map (\<lambda>i. (eqn e (Const (index i)), IVar (Para mem i))) (down DEPTH))) s
  =expEval I  (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down DEPTH))) s"
proof(induct_tac DEPTH,(cut_tac a,simp)+)qed

lemma readWrite[simp,intro!]:
assumes a1:"expEval I e s=expEval I e' s " and a2:"expEval I e s=index i" and a3:" i\<le> DEPTH " and
a2:"(\<forall>j. Para mem j \<notin>set (varOfExp e'))"

shows " expEval I  (substExp (caseExp (map (\<lambda>i. (eqn e' (Const (index i)), IVar (Para mem i))) (down DEPTH)))
            (map (\<lambda>i. (Para mem i, iteForm (eqn e (Const (index i))) e'' (IVar (Para mem i))))
              (down DEPTH)))
          s = expEval I e'' s "
using a2 a3 assms(2) auxOnReadWrite local.a1 by blast

(*lemma onApplyPlusI[simp]:"
  0 <  DEPTH \<longrightarrow> J DEPTH ''+'' [index i, index (Suc 0)]  = index ((i + 1) mod DEPTH)  "
  proof(induct_tac i,auto)
qed*)

lemma consistencyOfshiftMem:
  assumes a:"0 < DEPTH "
  shows "consistent' (shiftMem DEPTH ) (J DEPTH) (shiftGsteSpec DEPTH  data)
  (tagFunOfShiftMem  data DEPTH)"
  proof(unfold consistent'_def,rule allI,rule impI)
    fix e
    let ?G=" (shiftGsteSpec DEPTH  data)"
    let ?M="(shiftMem DEPTH   )"
    let ?tag="(tagFunOfShiftMem  data DEPTH)"
    let ?P ="\<lambda>e.
    (let f=andListForm (?tag (sink e)) in
    let f'=andListForm (?tag (source e)) in
    tautlogy (implyForm (andForm f' (antOf ?G e)) (preCond1  f  ( ?M))) (J DEPTH))"

    assume a1:"e \<in> edgesOf (shiftGsteSpec DEPTH  data)"

    have "e=Edge vertexI ( Vertex 1) |
          e=Edge  ( Vertex 1) ( Vertex 2)  |
           (\<exists>i. 2\<le>i \<and> i\<le> DEPTH + 1 \<and>  e=( Edge (Vertex i)  (Vertex (  i+1 ))) )   |
            (\<exists>i. 2\<le>i \<and> i\<le> DEPTH +1  \<and>  e=( Edge (Vertex i)  (Vertex i)) ) "
      apply(cut_tac a a1,auto)  done

    moreover
    {assume b1:"e=Edge vertexI ( Vertex 1)"
     have "?P e"
     apply(cut_tac a b1, simp  )
     done
     }
     moreover
    {assume b1:"e=Edge (Vertex 1) (Vertex 2)"
     have "?P e"
     apply(cut_tac a b1, auto  )done
     (*by (metis One_nat_def Suc_eq_plus1 axiomOnIAdd)*)

     }
    moreover
    {assume b1:" (\<exists>i. 2\<le>i \<and> i\<le> DEPTH+1  \<and>  e=( Edge (Vertex i)  (Vertex (  i + 1 ))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
     have b3:"Ident ''wrt_adr'' \<notin> set
     (varOfExp  (caseExp (map (\<lambda>i. (eqn (Const (index 0)) (Const (index i)), IVar (Para mem i))) (down DEPTH))))"
      by(induct_tac DEPTH,auto)
      have "?P e"
       apply(cut_tac a b2 b3,  simp add:   Let_def)done
    }
    moreover
    {assume b1:" (\<exists>i. 2\<le>i \<and> i\<le> DEPTH +1 \<and>  e=( Edge (Vertex (i))  (Vertex (i))) )  " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac b2, auto simp add: substNIl) done
    }
    ultimately show "?P e" by satx
qed

lemma testAux[simp]:

shows "(expEval I e s =index i \<longrightarrow>
i \<le> DEPTH\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)),  mem0 i)) (down DEPTH)@S))) s
=expEval  I  ( mem0 i) s) \<and>
(expEval I e s =index i \<longrightarrow>
 DEPTH < i\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)),   mem0 i)) (down DEPTH)@S))) s
=expEval  I  (caseExp S) s)"  (is "?P DEPTH")
proof(induct_tac DEPTH,auto )qed

lemma test[simp]:
shows "(expEval I e s =index i \<longrightarrow>
i \<le> DEPTH\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem0 i)) (down DEPTH)))) s
=expEval  I  (mem0 i) s)"
proof -
have a:"(expEval I e s =index i \<longrightarrow>
i \<le> DEPTH\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)), mem0 i)) (down DEPTH)@[]))) s
=expEval  I  (mem0 i) s) \<and>
(expEval I e s =index i \<longrightarrow>
 DEPTH < i\<longrightarrow>expEval I (caseExp ((map (\<lambda>i. (eqn e (Const (index i)),   mem0 i)) (down DEPTH)@[]))) s
=expEval  I  (caseExp []) s)"
apply(rule_tac testAux  [where S="[]"])done
then show ?thesis by auto
qed

lemma instImply:
assumes a:"G=(shiftGsteSpec DEPTH  data)" and b:"0 < DEPTH "  and c:"tag=tagFunOfShiftMem  data DEPTH"
shows
"\<forall> e. e \<in>edgesOf G\<longrightarrow>
tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) (J DEPTH)"
proof(rule allI,rule impI,simp,rule allI,rule impI)
  fix e s
  assume a1:"e \<in> edgesOf G " and a2:"
           formEval (J DEPTH) (antOf G e) s \<and> formEval (J DEPTH) (andListForm (tag (source e))) s"
  let ?P ="\<lambda>e. formEval (J DEPTH) (consOf G e) s"
  have "e=Edge vertexI ( Vertex 1) |
        e=Edge  ( Vertex 1) ( Vertex 2)  |
        (\<exists>i. 2\<le>i \<and> i\<le> DEPTH + 1 \<and>  e=( Edge (Vertex i)  (Vertex (  i+1 ))) )   |
        (\<exists>i. 2\<le>i \<and> i\<le> DEPTH + 1 \<and>  e=( Edge (Vertex i)  (Vertex i)) ) "
         apply(cut_tac  a a1,auto)   done
    moreover
    {assume b1:"e=Edge vertexI ( Vertex 1)"
     have "?P e"
     apply(cut_tac a b1, auto) done
     }

    moreover
    {assume b1:"e=Edge ( Vertex 1) ( Vertex 2)"
     have "?P e"
     apply(cut_tac a b1, auto) done
     }

    moreover
    {assume b1:" (\<exists>i. 2\<le>i \<and> i\<le> DEPTH + 1 \<and>  e=( Edge (Vertex i)  (Vertex (  i+1 ))) )   " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto

      have "?P e"
      proof(cut_tac a b c a2 b2, auto) qed

    }
    moreover
    {assume b1:"  (\<exists>i. 2\<le>i \<and> i\<le> DEPTH+1  \<and>  e=( Edge (Vertex i)  (Vertex (  i ))))   " (is "\<exists>i. ?asm i")
     from b1 obtain i where b2:"?asm i" by auto
      have "?P e"
       apply(cut_tac  a b c a2 b2,auto) done
    }

    ultimately show "?P e" by satx
  qed

lemma main:
assumes a:"G=(shiftGsteSpec DEPTH  data)" and b:"0 < DEPTH "
and c:"tag=tagFunOfShiftMem  data DEPTH" and
d:"M=(shiftMem DEPTH )"
shows " circuitSatGsteSpec M G (J DEPTH)"
proof(rule mainLemma)
have a1:"consistent' (shiftMem DEPTH ) (J DEPTH) (shiftGsteSpec DEPTH  data) (tagFunOfShiftMem  data DEPTH)"
   using b by (rule   consistencyOfshiftMem)
from a c d this show "consistent' M   (J DEPTH) G tag"
  by simp
next
from a b c show "\<forall>e. e \<in> edgesOf G \<longrightarrow>
        tautlogy (implyForm (andForm (antOf G e) (andListForm (tag (source e)))) (consOf G e)) (J DEPTH)"
apply(rule instImply) done
next
from a c show "tag (initOf G) = []"
apply auto done
qed
end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
(*
  Changes since submission on 2009-11-26:

  2009-12-10: OrderedMap, transfer of iterators to OrderedSet

*)
section {* \isaheader{Implementing Sets by Maps} *}
theory SetByMap
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
  "SetGA"
  "MapGA"
begin
text_raw {*\label{thy:SetByMap}*}

text {*
  In this theory, we show how to implement sets
  by maps.
*}

(* TODO: We could also define some more operations directly,
  e.g. union, ball, bex, \<dots> *)

text {* Auxiliary lemma *}
lemma foldli_foldli_map_eq:
  "foldli (foldli l (\<lambda>x. True) (\<lambda>x l. l@[f x]) []) c f' \<sigma>0
    = foldli l c (f' o f) \<sigma>0"
proof -
  show ?thesis
    apply (simp add: map_by_foldl foldli_map foldli_foldl)
    done
qed

locale SetByMapDefs =
  map: StdBasicMapDefs ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  definition "\<alpha> s \<equiv> dom (map.\<alpha> s)"
  definition "invar s \<equiv> map.invar s"
  definition empty where "empty \<equiv> map.empty"
  definition "memb x s \<equiv> map.lookup x s \<noteq> None"
  definition "ins x s \<equiv> map.update x () s"
  definition "ins_dj x s \<equiv> map.update_dj x () s"
  definition "delete x s \<equiv> map.delete x s"
  definition list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "list_it s c f \<sigma>0 \<equiv> it_to_it (map.list_it s) c (f o fst) \<sigma>0"

  local_setup {* Locale_Code.lc_decl_del @{term list_it} *}

  lemma list_it_alt: "list_it s = map_iterator_dom (map.iteratei s)"
  proof -
    have A: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>x. f (fst x))" by auto
    show ?thesis
      unfolding list_it_def[abs_def] map_iterator_dom_def
        poly_map_iteratei_defs.iteratei_def
        set_iterator_image_def set_iterator_image_filter_def
      by (auto simp: comp_def)
  qed

  lemma list_it_unfold:
    "it_to_it (list_it s) c f \<sigma>0 = map.iteratei s c (f o fst) \<sigma>0"
    unfolding list_it_def[abs_def] it_to_it_def
    unfolding poly_map_iteratei_defs.iteratei_def it_to_it_def
    by (simp add: foldli_foldli_map_eq comp_def)

  definition [icf_rec_def]: "dflt_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = \<alpha>,
    bset_op_invar = invar,
    bset_op_empty = empty,
    bset_op_memb = memb,
    bset_op_ins = ins,
    bset_op_ins_dj = ins_dj,
    bset_op_delete = delete,
    bset_op_list_it = list_it
    \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term dflt_basic_ops} *}

end

setup {*
  (Record_Intf.add_unf_thms_global @{thms
    SetByMapDefs.list_it_def[abs_def]
  })
*}

(*lemmas [code_unfold] = SetByMapDefs.list_it_def[abs_def]*)

locale SetByMap = SetByMapDefs ops +
  map: StdBasicMap ops
  for ops :: "('x,unit,'s,'more) map_basic_ops_scheme"
begin
  lemma empty_impl: "set_empty \<alpha> invar empty"
    apply unfold_locales
    unfolding \<alpha>_def invar_def empty_def
    by (auto simp: map.empty_correct)

  lemma memb_impl: "set_memb \<alpha> invar memb"
    apply unfold_locales
    unfolding \<alpha>_def invar_def memb_def
    by (auto simp: map.lookup_correct)

  lemma ins_impl: "set_ins \<alpha> invar ins"
    apply unfold_locales
    unfolding \<alpha>_def invar_def ins_def
    by (auto simp: map.update_correct)

  lemma ins_dj_impl: "set_ins_dj \<alpha> invar ins_dj"
    apply unfold_locales
    unfolding \<alpha>_def invar_def ins_dj_def
    by (auto simp: map.update_dj_correct)

  lemma delete_impl: "set_delete \<alpha> invar delete"
    apply unfold_locales
    unfolding \<alpha>_def invar_def delete_def
    by (auto simp: map.delete_correct)

  lemma list_it_impl: "poly_set_iteratei \<alpha> invar list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    from map_iterator_dom_correct[OF map.iteratei_correct[OF I']]
    show "set_iterator (list_it s) (\<alpha> s)"
      unfolding \<alpha>_def list_it_alt .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])
  qed

  lemma dflt_basic_ops_impl: "StdBasicSet dflt_basic_ops"
    apply (rule StdBasicSet.intro)
    apply (simp_all add: icf_rec_unf)
    apply (rule empty_impl memb_impl ins_impl
      ins_dj_impl delete_impl
      list_it_impl[unfolded SetByMapDefs.list_it_def[abs_def]]
    )+
    done
end

locale OSetByOMapDefs = SetByMapDefs ops +
  map: StdBasicOMapDefs ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  definition ordered_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "ordered_list_it s c f \<sigma>0
    \<equiv> it_to_it (map.ordered_list_it s) c (f o fst) \<sigma>0"
    (*where "list_it s c f \<sigma>0 \<equiv> it_to_it (map.list_it s) c (f o fst) \<sigma>0"*)
  local_setup {* Locale_Code.lc_decl_del @{term ordered_list_it} *}

  definition rev_list_it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    where "rev_list_it s c f \<sigma>0 \<equiv> it_to_it (map.rev_list_it s) c (f o fst) \<sigma>0"
    (*where "rev_list_it s c f \<sigma>0 \<equiv> map.rev_iterateoi s c (f o fst) \<sigma>0"*)
  local_setup {* Locale_Code.lc_decl_del @{term rev_list_it} *}

  definition [icf_rec_def]: "dflt_basic_oops \<equiv>
    set_basic_ops.extend dflt_basic_ops \<lparr>
      bset_op_ordered_list_it = ordered_list_it,
      bset_op_rev_list_it = rev_list_it
      \<rparr>"
  local_setup {* Locale_Code.lc_decl_del @{term dflt_basic_oops} *}

end

setup {*
  (Record_Intf.add_unf_thms_global @{thms
    OSetByOMapDefs.ordered_list_it_def[abs_def]
    OSetByOMapDefs.rev_list_it_def[abs_def]
  })
*}

(*lemmas [code_unfold] = OSetByOMapDefs.ordered_list_it_def[abs_def]
  OSetByOMapDefs.rev_list_it_def[abs_def]*)

locale OSetByOMap = OSetByOMapDefs ops +
  SetByMap ops + map: StdBasicOMap ops
  for ops :: "('x::linorder,unit,'s,'more) omap_basic_ops_scheme"
begin
  lemma ordered_list_it_impl: "poly_set_iterateoi \<alpha> invar ordered_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    have A: "\<And>s. ordered_list_it s = map_iterator_dom (map.iterateoi s)"
      unfolding ordered_list_it_def[abs_def]
        map_iterator_dom_def set_iterator_image_alt_def map.iterateoi_def
      by (simp add: S comp_def)

    from map_iterator_linord_dom_correct[OF map.iterateoi_correct[OF I']]
    show "set_iterator_linord (ordered_list_it s) (\<alpha> s)"
      unfolding \<alpha>_def A .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])
  qed

  lemma rev_list_it_impl: "poly_set_rev_iterateoi \<alpha> invar rev_list_it"
  proof
    fix s
    assume I: "invar s"
    hence I': "map.invar s" unfolding invar_def .

    have S: "\<And>f. (\<lambda>(x,_). f x) = (\<lambda>xy. f (fst xy))"
      by auto

    have A: "\<And>s. rev_list_it s = map_iterator_dom (map.rev_iterateoi s)"
      unfolding rev_list_it_def[abs_def]
        map_iterator_dom_def set_iterator_image_alt_def map.rev_iterateoi_def
      by (simp add: S comp_def)

    from map_iterator_rev_linord_dom_correct[
      OF map.rev_iterateoi_correct[OF I']]
    show "set_iterator_rev_linord (rev_list_it s) (\<alpha> s)"
      unfolding \<alpha>_def A .

    show "finite (\<alpha> s)"
      unfolding \<alpha>_def by (simp add: map.finite[OF I'])

  qed

  lemma dflt_basic_oops_impl: "StdBasicOSet dflt_basic_oops"
  proof -
    interpret aux: StdBasicSet dflt_basic_ops by (rule dflt_basic_ops_impl)

    show ?thesis
      apply (rule StdBasicOSet.intro)
      apply (rule StdBasicSet.intro)
      apply icf_locales
      apply (simp_all add: icf_rec_unf)
      apply (rule
        ordered_list_it_impl[unfolded ordered_list_it_def[abs_def]]
        rev_list_it_impl[unfolded rev_list_it_def[abs_def]]
      )+
      done
  qed
end

sublocale SetByMap < basic: StdBasicSet "dflt_basic_ops"
  by (rule dflt_basic_ops_impl)

sublocale OSetByOMap < obasic: StdBasicOSet "dflt_basic_oops"
  by (rule dflt_basic_oops_impl)

lemma proper_it'_map2set: "proper_it' it it'
  \<Longrightarrow> proper_it' (\<lambda>s c f. it s c (f o fst)) (\<lambda>s c f. it' s c (f o fst))"
  unfolding proper_it'_def
  apply clarsimp
  apply (drule_tac x=s in spec)
  apply (erule proper_itE)
  apply (rule proper_itI)
  apply (auto simp add: foldli_map[symmetric] intro!: ext)
  done

end


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

section \<open>Example application: Subintuitionistic and subminimal logics\<close>

text\<open>\noindent{In this section we examine some special paracomplete logics. The idea is to illustrate an approach by
means of which we can obtain logics which are boldly paracomplete and (non-boldly) paraconsistent at the
same time, Johansson's 'minimal logic' \<^cite>\<open>JML\<close> being the paradigmatic case we aim at modelling.}\<close>

text\<open>\noindent{Drawing upon the literature on Johanson's minimal logic, we introduce an unconstrained propositional
constant Q, which we then employ to define a 'rigid' frontier operation @{text "\<F>'"}.}\<close>
consts Q::"\<sigma>"
abbreviation "\<F>' \<equiv> \<lambda>X. Q"
abbreviation "\<I>' \<equiv> \<I>\<^sub>F \<F>'"
abbreviation "\<C>' \<equiv> \<C>\<^sub>F \<F>'"
abbreviation "\<B>' \<equiv> \<B>\<^sub>F \<F>'"

text\<open>\noindent{As defined, @{text "\<F>'"} (and its corresponding closure operation) satisfies several semantic conditions.}\<close>
lemma "Fr_1 \<F>' \<and> Fr_2 \<F>' \<and> Fr_4 \<F>'" by (simp add: Fr_1_def Fr_2_def Fr_4_def conn)
lemma "Cl_1 \<C>' \<and> Cl_2 \<C>' \<and> Cl_4 \<C>'" using ADDI_def CF2 IDEMb_def Cl_fr_def PC4 unfolding conn by auto
text\<open>\noindent{However Fr-3 is not valid. In fact, adding it by hand would collapse into classical logic (making all sets clopen).}\<close>
lemma "Fr_3 \<F>'" nitpick oops (*counterexample found*)
lemma "Cl_3 \<C>'" nitpick oops (*counterexample found*)
lemma "Fr_3 \<F>' \<Longrightarrow> \<forall>A. \<F>'(A) \<^bold>\<approx> \<^bold>\<bottom>"  by (simp add: NOR_def)

text\<open>\noindent{In order to obtain a paracomplete logic not validating ECQ, we define negation as follows,}\<close>
abbreviation neg_IC::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>")  where  "\<^bold>\<not>A \<equiv> \<C>'(\<I>(\<^bold>\<midarrow>A))"

text\<open>\noindent{and observe that some plausible semantic properties obtain:}\<close>
lemma Q_def1: "\<forall>A. Q \<^bold>\<approx> \<^bold>\<not>A \<^bold>\<and> \<^bold>\<not>(\<^bold>\<not>A)" using Cl_fr_def IF2 dEXP_def conn by auto
lemma Q_def2: "Fr_1b \<F> \<Longrightarrow> \<forall>A. Q \<^bold>\<approx> \<^bold>\<not>(A \<^bold>\<or> \<^bold>\<not>A)" by (smt Cl_fr_def IF2 dEXP_def MONO_def monI conn)
lemma neg_Idef: "\<forall>A. \<^bold>\<not>A \<^bold>\<approx> \<I>(\<^bold>\<midarrow>A) \<^bold>\<or> Q" by (simp add: Cl_fr_def)
lemma neg_Cdef: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<^bold>\<not>A \<^bold>\<approx> \<C>(A) \<^bold>\<rightarrow> Q" using Cl_fr_def Fr_2_def Int_fr_def conn by auto

text\<open>\noindent{The negation so defined validates some properties corresponding to a (rather weak) paracomplete logic:}\<close>
lemma "\<FF> \<F> \<Longrightarrow> TND \<^bold>\<not>" nitpick oops (*counterexample found: negation is paracomplete*)
lemma "\<FF> \<F> \<Longrightarrow> TNDw \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> TNDm \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> ECQ \<^bold>\<not>" nitpick oops (*counterexample found: negation is paraconsistent...*)
lemma ECQw: "ECQw \<^bold>\<not>" using Cl_fr_def Disj_I ECQw_def unfolding conn by auto (*...but not 'boldly' paraconsistent*)
lemma ECQm: "ECQm \<^bold>\<not>" using Cl_fr_def Disj_I ECQm_def unfolding conn by auto
lemma "\<FF> \<F> \<Longrightarrow> LNC \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DNI \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DNE \<^bold>\<not>"  nitpick oops
lemma CoPw: "Fr_1b \<F> \<Longrightarrow> CoPw \<^bold>\<not>" using Cl_fr_def MONO_def monI unfolding Defs conn by smt
lemma "\<FF> \<F> \<Longrightarrow> CoP1 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> CoP2 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> CoP3 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> XCoP \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DM3 \<^bold>\<not>" nitpick oops

text\<open>\noindent{Moreover, we cannot have both DNI and DNE without validating ECQ (thus losing paraconsistency).}\<close>
lemma "DNI \<^bold>\<not> \<and> DNE \<^bold>\<not> \<longrightarrow> ECQ \<^bold>\<not>" using DNE_def ECQ_def Int_fr_def neg_Idef unfolding conn by (metis (no_types, lifting))
text\<open>\noindent{However, we can have all of De Morgan laws while keeping (non-bold) paraconsistency.}\<close>
lemma "\<sim>ECQ \<^bold>\<not> \<and> DM1 \<^bold>\<not> \<and> DM2 \<^bold>\<not> \<and> DM3 \<^bold>\<not> \<and> DM4 \<^bold>\<not> \<and> \<FF> \<F>" nitpick[satisfy,card w=3] oops (*(weakly paraconsistent) model found*)

text\<open>\noindent{Below we combine negation with strict implication and verify some interesting properties.
For instance, the following are not valid (and cannot become valid by adding semantic restrictions). }\<close>
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (\<^bold>\<not>a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample found*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (\<^bold>\<not>a \<^bold>\<rightarrow> (a \<^bold>\<rightarrow> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (b \<^bold>\<or> \<^bold>\<not>b)) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<rightarrow> (b \<^bold>\<or> \<^bold>\<not>b)) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (a \<^bold>\<Rightarrow> \<^bold>\<not>a) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (a \<^bold>\<rightarrow> \<^bold>\<not>a) \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<Rightarrow> b \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<rightarrow> b \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<Rightarrow> (b \<^bold>\<or> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<rightarrow> (b \<^bold>\<or> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<leftrightarrow> b) \<^bold>\<Rightarrow> (\<^bold>\<not>a \<^bold>\<leftrightarrow> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<leftrightarrow> b) \<^bold>\<rightarrow> (\<^bold>\<not>a \<^bold>\<leftrightarrow> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<rightarrow> b) \<^bold>\<and> (a \<^bold>\<rightarrow> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a  \<^bold>\<Rightarrow>  \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a  \<^bold>\<rightarrow>  \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a \<^bold>\<Rightarrow> \<^bold>\<not>(\<^bold>\<not>\<^bold>\<top>)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<not>\<^bold>\<top>)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. \<^bold>\<not>(\<^bold>\<not>(\<^bold>\<not>a)) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. \<^bold>\<not>(\<^bold>\<not>(\<^bold>\<not>a)) \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops

text\<open>\noindent{The (weak) local contraposition axiom is indeed valid under appropriate conditions.}\<close>
lemma lCoPw: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>" and fr4: "Fr_4 \<F>"
  { fix a b
    from fr2 have "\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> (\<C> a \<^bold>\<rightarrow> \<C> b) \<^bold>\<or> Q" using Cl_fr_def Fr_2_def Int_fr_def conn by auto
    moreover from fr1 fr2 fr3 have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<C> a \<^bold>\<rightarrow> \<C> b" using IC_imp by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a" unfolding conn by simp
    moreover from fr1 fr2 fr4 have "let A=(a \<^bold>\<rightarrow> b); B=(\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a) in \<I> A \<^bold>\<preceq> B \<longrightarrow> \<I> A \<^bold>\<preceq> \<I> B"
      using PF1 MONO_MULTa IF1a IF4 PI9 Int_9_def by smt
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<I>(\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a)" by simp
  } hence "lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs conn by blast
  thus ?thesis by simp
qed
lemma lCoPw_strict: "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (\<^bold>\<not>b \<^bold>\<Rightarrow> \<^bold>\<not>a) \<^bold>\<approx> \<^bold>\<top>" by (metis (no_types, lifting) DTw2 lCoPw lCoPw_def)

text\<open>\noindent{However, other (local) contraposition axioms are not valid.}\<close>
lemma "\<FF> \<F> \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops (*counterexample found*)
lemma "\<FF> \<F> \<Longrightarrow> lCoP2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> lCoP3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
text\<open>\noindent{And this time no variant of disjunctive syllogism is valid.}\<close>
lemma "\<FF> \<F> \<Longrightarrow> DS1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS4(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{Interestingly, one of the local contraposition axioms (lCoP1) follows from DNI.}\<close>
lemma DNI_lCoP1: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> DNI \<^bold>\<not> \<longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>" and fr4: "Fr_4 \<F>"
  { assume dni: "DNI \<^bold>\<not>"
    { fix a b
      from fr1 fr2 fr3 fr4 have "lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>"  using lCoPw by simp
      hence 1: "a \<^bold>\<Rightarrow> \<^bold>\<not>b \<^bold>\<preceq> \<^bold>\<not>(\<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a" unfolding lCoPw_def by simp
      from fr1 have 2: "let A=b; B=\<^bold>\<not>(\<^bold>\<not>b); C=\<^bold>\<not>a in A \<^bold>\<preceq> B \<longrightarrow>  \<I>(B \<^bold>\<rightarrow> C) \<^bold>\<preceq> \<I>(A \<^bold>\<rightarrow> C)" by (simp add: MONO_ant PF1 monI)
      from dni have dnib: "b \<^bold>\<preceq> \<^bold>\<not>(\<^bold>\<not>b)" unfolding DNI_def by simp
      from 1 2 dnib have "a \<^bold>\<Rightarrow> \<^bold>\<not>b \<^bold>\<preceq> b \<^bold>\<Rightarrow> \<^bold>\<not>a" unfolding conn by meson
    } hence "lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs by blast
  } thus ?thesis by simp
qed
text\<open>\noindent{This entails some other interesting results.}\<close>
lemma DNI_CoP1: "Fr_1b \<F> \<Longrightarrow> DNI \<^bold>\<not> \<Longrightarrow> CoP1 \<^bold>\<not>" using CoP1_def2 CoPw by blast
lemma CoP1_LNC: "CoP1 \<^bold>\<not> \<Longrightarrow> LNC \<^bold>\<not>" using CoP1_def ECQm_def LNC_def  Cl_fr_def Disj_I ECQm_def unfolding conn by smt
lemma DNI_LNC: "Fr_1b \<F> \<Longrightarrow> DNI \<^bold>\<not> \<Longrightarrow> LNC \<^bold>\<not>" by (simp add: CoP1_LNC DNI_CoP1)

text\<open>\noindent{The following variants of modus tollens also obtain.}\<close>
lemma MT: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> \<^bold>\<not>b \<^bold>\<preceq> \<^bold>\<not>a" using Cl_fr_def Fr_2_def IC_imp Int_fr_def unfolding conn by metis
lemma MT': "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 MT)

text\<open>\noindent{We now semantically characterize (an approximation of) Johansson's Minimal Logic along with some
exemplary 'subminimal' logics (observing that many more are possible). We check some relevant properties.}\<close>
abbreviation "JML \<equiv> \<FF> \<F> \<and> DNI \<^bold>\<not>"
abbreviation "SML1 \<equiv> \<FF> \<F>" (*Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F>*)
abbreviation "SML2 \<equiv> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F>"
abbreviation "SML3 \<equiv> Fr_1 \<F>"
abbreviation "SML4 \<equiv> Fr_1b \<F>"

text\<open>\noindent{TND:}\<close>
lemma "JML \<Longrightarrow> TND \<^bold>\<not>" nitpick oops (*counterexample found*)
lemma "JML \<Longrightarrow> TNDw \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> TNDm \<^bold>\<not>" nitpick oops

text\<open>\noindent{ECQ:}\<close>
lemma "JML \<Longrightarrow> ECQ \<^bold>\<not>" nitpick oops
lemma "ECQw \<^bold>\<not>" using Cl_fr_def Disj_I ECQw_def unfolding conn by auto
lemma "ECQm \<^bold>\<not>" using Cl_fr_def Disj_I ECQm_def unfolding conn by auto

text\<open>\noindent{LNC:}\<close>
lemma "JML \<Longrightarrow> LNC \<^bold>\<not>" using DNI_LNC PF1 by blast
lemma "SML1 \<Longrightarrow> LNC \<^bold>\<not>" nitpick oops

text\<open>\noindent{(r)DNI/DNE:}\<close>
lemma "JML \<Longrightarrow> DNI \<^bold>\<not>" using CoP1_def2 by blast
lemma "SML1 \<Longrightarrow> rDNI \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> rDNE \<^bold>\<not>"  nitpick oops

text\<open>\noindent{CoP/MT:}\<close>
lemma "SML4 \<Longrightarrow> CoPw \<^bold>\<not>" unfolding Defs by (smt Cl_fr_def MONO_def monI conn)
lemma "JML \<Longrightarrow> CoP1 \<^bold>\<not>" using DNI_CoP1 PF1 by blast
lemma "SML1 \<Longrightarrow> MT1 \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> MT2 \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> MT3 \<^bold>\<not>" nitpick oops

text\<open>\noindent{XCoP:}\<close>
lemma "JML \<Longrightarrow> XCoP \<^bold>\<not>" nitpick oops

text\<open>\noindent{DM3/4:}\<close>
lemma "JML \<Longrightarrow> DM3 \<^bold>\<not>" nitpick oops
lemma "SML3 \<Longrightarrow> DM4 \<^bold>\<not>" by (simp add: DM4 PF1)
lemma "SML4 \<Longrightarrow> DM4 \<^bold>\<not>" nitpick oops

text\<open>\noindent{nNor/nDNor:}\<close>
lemma "SML2 \<Longrightarrow> nNor \<^bold>\<not>" using Cl_fr_def nNor_I nNor_def unfolding conn by auto
lemma "SML3 \<Longrightarrow> nNor \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> nDNor \<^bold>\<not>" nitpick oops

text\<open>\noindent{lCoP classical:}\<close>
lemma "JML \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{DS classical:}\<close>
lemma "JML \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{lCoP strict:}\<close>
lemma "SML1 \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" using lCoPw by blast
lemma "SML2 \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" using CoP1_def2 DNI_lCoP1 by blast
lemma "SML1 \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{lMT strict:}\<close>
lemma "SML2 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs using MT by auto
lemma "SML3 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>"  (*nitpick*) oops (*no countermodel found*)
lemma "SML4 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>"  nitpick oops
lemma "JML \<Longrightarrow> lMT1(\<^bold>\<Rightarrow>) \<^bold>\<not>"  by (smt DNI_lCoP1 DT1 lCoP1_def lMT1_def)
lemma "SML1 \<Longrightarrow> lMT1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lMT2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lMT3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{DS strict:}\<close>
lemma "JML \<Longrightarrow> DS1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS4(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

end


theory weird_nat_op_comm_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun op :: "Nat => Nat => Nat => Nat => Nat" where
"op (Z) y (Z) x2 = x2"
| "op (Z) y (S x3) x2 = op Z y x3 (S x2)"
| "op (S x4) y (Z) x2 = op x4 y y x2"
| "op (S x4) y (S c) x2 = op (S x4) y c (S x2)"

(*hipster op *)

theorem x0 :
  "!! (a :: Nat) (b :: Nat) (c :: Nat) (d :: Nat) .
     (op a b c d) = (op b a d c)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory SM_Wrapup
imports SM_Ample_Impl Stuttering_Equivalence.PLTL
begin

  export_code ty_program ltlc_next_free checking SML

  definition "vars_of_aprop e \<equiv> udvars_of_exp e \<union> gvars_of_exp e"
  definition "vars_of_ltlc \<phi> \<equiv> \<Union> (vars_of_aprop ` atoms_ltlc \<phi>)"

  lemma test_aprop_vars_cong:
    assumes "e \<in> atoms_ltlc \<phi>"
    shows "test_aprop e (v |` vars_of_ltlc \<phi>) \<longleftrightarrow> test_aprop e v"
  proof -
    have 1: "eval_exp e (\<lparr> local_state.variables = Map.empty \<rparr>,
      \<lparr> global_state.variables = v |` vars_of_ltlc \<phi> \<rparr>) =
      eval_exp e (\<lparr> local_state.variables = Map.empty \<rparr>, \<lparr> global_state.variables = v \<rparr>)"
    proof (rule eval_dep_vars)
      show "gs_eq_on (vars_of_ltlc \<phi>) \<lparr> global_state.variables = v |` vars_of_ltlc \<phi> \<rparr>
        \<lparr> global_state.variables = v \<rparr>" by (simp add: eq_on_def)
      show "udvars_of_exp e \<subseteq> vars_of_ltlc \<phi>"
        using assms vars_of_aprop_def vars_of_ltlc_def by blast
      show "gvars_of_exp e \<subseteq> vars_of_ltlc \<phi>"
        using assms vars_of_aprop_def vars_of_ltlc_def by blast
    qed
    show ?thesis unfolding test_aprop_def 1 by rule
  qed

  context cprog
  begin

    sublocale ample_impl: sa "\<lparr> g_V = UNIV,
      g_E = ample_step_impl4_impl prog (comp_info_of prog) is_vis_var,
      g_V0 = {pid_init_gc_impl_impl prog (comp_info_of prog)},
      sa_L = pid_interp_gc_impl is_vis_var \<rparr>"
      for is_vis_var by unfold_locales auto

    theorem ample_reduction_correct:
      assumes "ty_program prog"
      assumes NF: "ltlc_next_free \<phi>"
      shows "
        (Collect (SM_LTL.ap_accept prog) \<subseteq> language_ltlc \<phi>)
        \<longleftrightarrow>
        (Collect (ample_impl.accept (\<lambda>x. x\<in>vars_of_ltlc \<phi>)) \<subseteq> language_ltlc \<phi>)"
    proof safe
      interpret visible_prog prog "(\<lambda>x. x\<in>vars_of_ltlc \<phi>)"
        apply unfold_locales
        by fact

      {
        fix w
        assume 1: "(Collect (SM_LTL.ap_accept prog) \<subseteq> language_ltlc \<phi>)"
        and 2: "ample_impl.accept (\<lambda>x. x\<in>vars_of_ltlc \<phi>) w"
        note t2 = 2[unfolded pid_init_gc_impl_impl ample_step_impl4_impl]
        from impl4_accept_subset[OF t2] obtain w' where
          WEQ: "w=interp_gs o w'" and "ref_accept prog w'"
          unfolding lv_accept_conv
          by blast
        hence "ap_accept prog (sm_props o global_state.variables o w')"
          (is "ap_accept prog ?ww")
          unfolding ap_accept_def interp_gs_def[abs_def]
          by auto
        with 1 have "?ww \<in> language_ltlc \<phi>" by blast
        moreover have "pw_eq_on (atoms_ltlc \<phi>) w ?ww"
          apply (simp add: WEQ)
          unfolding pw_eq_on_def interp_gs_def[abs_def]
          unfolding sm_props_def[abs_def]
          by (auto simp: test_aprop_vars_cong)
        ultimately show "w \<in> language_ltlc \<phi>"
          unfolding language_ltlc_def
          by (auto simp: ltlc_eq_on)
      }

      {
        fix w
        assume 1: "Collect (ample_impl.accept (\<lambda>x. x\<in>vars_of_ltlc \<phi>)) \<subseteq> language_ltlc \<phi>"
        and 2: "SM_LTL.ap_accept prog w"
        from 2 obtain w' where
          WEQ: "w = (sm_props o global_state.variables o w')"
          and ACC: "ref_accept prog w'"
          unfolding ap_accept_def by auto
        with lv_accept_conv[THEN iffD2] have ACC': "lv.sa.accept (interp_gs o w')"
          by (auto simp: interp_gs_def[abs_def])

        from impl4_accept_stuttering[OF ACC'] obtain ww where
          E2: "interp_gs o w' \<approx> ww" and "ample_impl.accept (\<lambda>x. x\<in>vars_of_ltlc \<phi>) ww"
          unfolding pid_init_gc_impl_impl ample_step_impl4_impl
          unfolding lv_accept_conv
          by blast
        hence L: "ww \<in> language_ltlc \<phi>" using 1 by blast

        have E1: "pw_eq_on (atoms_ltlc \<phi>) w (interp_gs o w')"
          apply (simp add: WEQ)
          unfolding pw_eq_on_def interp_gs_def[abs_def]
          unfolding sm_props_def[abs_def]
          by (auto simp: test_aprop_vars_cong)

        from ltlc_next_free_stutter_invariant[OF NF E2] L
        have "interp_gs o w' \<in> language_ltlc \<phi>" by (auto simp: language_ltlc_def)
        with ltlc_eq_on[OF E1] show "w\<in>language_ltlc \<phi>" by (auto simp: language_ltlc_def)
      }
    qed

  end

end


subsection \<open>NotNode Phase\<close>

theory NotPhase
  imports
    Common
begin

phase NotNode
  terminating size
begin

(* Word level proofs *)
lemma bin_not_cancel:
 "bin[\<not>(\<not>(e))] = bin[e]"
  by auto

(* Value level proofs *)
lemma val_not_cancel:
  assumes "val[~(new_int b v)] \<noteq> UndefVal"
  shows   "val[~(~(new_int b v))] = (new_int b v)"
  by (simp add: take_bit_not_take_bit)

(* Exp level proofs *)
lemma exp_not_cancel:
   "exp[~(~a)] \<ge> exp[a]"
   using val_not_cancel apply auto
  by (metis eval_unused_bits_zero intval_logic_negation.cases new_int.simps intval_not.simps(1)
      intval_not.simps(2) intval_not.simps(3) intval_not.simps(4))

text \<open>Optimisations\<close>

optimization NotCancel: "exp[~(~a)] \<longmapsto> a"
  by (metis exp_not_cancel)

end (* End of NotPhase *)

end (* End of file *)


theory hoare_logic_test
  imports "~~/src/HOL/Hoare/Separation"
begin

lemma "VARS x
{P}
SKIP
{P}"
  apply vcg
    done

lemma "VARS x
{x=5}
x:=7
{x=5}"
  apply vcg
  apply auto
    sorry

lemma "VARS x
{P}
SKIP;SKIP
{P}"
  apply vcg
    done

lemma "VARS x
{P}
IF R THEN SKIP ELSE SKIP FI
{Q}"
  apply vcg
  sorry

lemma "VARS x
{P}
WHILE S
INV{I}
DO
SKIP
OD
{Q}"
  apply vcg
    sorry

end


section \<open> Dwarf Signal \<close>

theory DwarfSignal
  imports "Z_Machines.Z_Machine"
begin

notation undefined ("???")

subsection \<open> State Space \<close>

enumtype LampId = L1 | L2 | L3

type_synonym Signal = "LampId set"

enumtype ProperState = dark | stop | warning | drive

definition "ProperState = {dark, stop, warning, drive}"

fun signalLamps :: "ProperState \<Rightarrow> LampId set" where
"signalLamps dark = {}" |
"signalLamps stop = {L1, L2}" |
"signalLamps warning = {L1, L3}" |
"signalLamps drive = {L2, L3}"

text \<open> Could we have separate processes for the actual lamp and its controller? We would then
  try to verify that the controller preserves the lamp-based safety properties. The current
  set up doesn't preserve them. \<close>

zstore Dwarf =
  last_proper_state :: "ProperState"
  turn_off :: "LampId set"
  turn_on  :: "LampId set"
  last_state :: "Signal"
  current_state :: "Signal"
  desired_proper_state :: "ProperState"
  where
    "(current_state - turn_off) \<union> turn_on = signalLamps desired_proper_state"
    "turn_on \<inter> turn_off = {}"

subsection \<open> Operations and Machine \<close>

zoperation SetNewProperState =
  over Dwarf
  params st\<in>"ProperState - {desired_proper_state}"
  pre "current_state = signalLamps desired_proper_state"
  update "[last_proper_state\<Zprime> = desired_proper_state
          ,turn_off\<Zprime> = current_state - signalLamps st
          ,turn_on\<Zprime> = signalLamps st - current_state
          ,last_state\<Zprime> = current_state
          ,desired_proper_state\<Zprime> = st]"

zoperation TurnOff =
  over Dwarf
  params l\<in>turn_off
  update "[turn_off\<Zprime> = turn_off - {l}
          ,turn_on\<Zprime> = turn_on - {l}
          ,last_state\<Zprime> = current_state
          ,current_state\<Zprime> = current_state - {l}]"

zoperation TurnOn =
  over Dwarf
  params l\<in>turn_on
  update "[turn_off\<Zprime> = turn_off - {l}
          ,turn_on\<Zprime> = turn_on - {l}
          ,last_state\<Zprime> = current_state
          ,current_state\<Zprime> = current_state \<union> {l}]"

zoperation Shine =
  over Dwarf
  params l\<in>"{current_state}"

definition Init :: "Dwarf subst" where
  [z_defs]:
  "Init =
  [ last_proper_state \<leadsto> stop
  , turn_off \<leadsto> {}
  , turn_on \<leadsto> {}
  , last_state \<leadsto> signalLamps stop
  , current_state \<leadsto> signalLamps stop
  , desired_proper_state \<leadsto> stop ]"

zmachine DwarfSignal =
  init Init
  invariant Dwarf_inv
  operations SetNewProperState TurnOn TurnOff Shine

subsection \<open> Structural Invariants and Deadlock Freedom \<close>

lemma "Init establishes Dwarf_inv"
  by zpog_full

lemma [hoare_lemmas]: "(SetNewProperState p) preserves Dwarf_inv"
  by (zpog_full; auto)

lemma [hoare_lemmas]: "TurnOn l preserves Dwarf_inv"
  by (zpog_full, auto)

lemma [hoare_lemmas]: "TurnOff l preserves Dwarf_inv"
  by (zpog_full, auto)

lemma [hoare_lemmas]: "Shine l preserves Dwarf_inv"
  by (zpog_full; auto)

lemma deadlock_free_DwarfSignal: "deadlock_free DwarfSignal"
  unfolding DwarfSignal_def by deadlock_free

subsection \<open> Requirements \<close>

zexpr NeverShowAll
  is "current_state \<noteq> {L1, L2, L3}"

zexpr MaxOneLampChange
  is "(\<exists> l. current_state - last_state = {l} \<or> last_state - current_state = {l} \<or> last_state = current_state)"

zexpr ForbidStopToDrive
  is "(last_proper_state = stop \<longrightarrow> desired_proper_state \<noteq> drive)"

zexpr DarkOnlyToStop
  is "(last_proper_state = dark \<longrightarrow> desired_proper_state = stop)"

zexpr DarkOnlyFromStop
  is "(desired_proper_state = dark \<longrightarrow> last_proper_state = stop)"

zexpr DwarfReq
  is "NeverShowAll \<and> MaxOneLampChange \<and> ForbidStopToDrive \<and> DarkOnlyToStop \<and> DarkOnlyFromStop"

zoperation ViolNeverShowAll =
  pre "\<not> NeverShowAll"

zmachine DwarfSignalTest =
  init Init
  operations SetNewProperState TurnOn TurnOff Shine ViolNeverShowAll

animate DwarfSignalTest

lemma "(SetNewProperState p) preserves NeverShowAll"
  by zpog_full

lemma "(SetNewProperState p) preserves MaxOneLampChange"
  by zpog_full

lemma "(SetNewProperState p) preserves ForbidStopToDrive"
  apply zpog_full
  quickcheck
  oops

lemma "TurnOn l preserves NeverShowAll"
  apply zpog_full
  quickcheck
  oops

end