(*  Title:      Doc/Functions/Functions.thy
    Author:     Alexander Krauss, TU Muenchen

Tutorial for function definitions with the new "function" package.
*)

theory Functions
imports Main
begin

section \<open>Function Definitions for Dummies\<close>

text \<open>
  In most cases, defining a recursive function is just as simple as other definitions:
\<close>

fun fib :: "nat \<Rightarrow> nat"
where
  "fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib n + fib (Suc n)"

text \<open>
  The syntax is rather self-explanatory: We introduce a function by
  giving its name, its type,
  and a set of defining recursive equations.
  If we leave out the type, the most general type will be
  inferred, which can sometimes lead to surprises: Since both @{term
  "1::nat"} and @{text "+"} are overloaded, we would end up
  with @{text "fib :: nat \<Rightarrow> 'a::{one,plus}"}.
\<close>

text \<open>
  The function always terminates, since its argument gets smaller in
  every recursive call.
  Since HOL is a logic of total functions, termination is a
  fundamental requirement to prevent inconsistencies\footnote{From the
  \qt{definition} @{text "f(n) = f(n) + 1"} we could prove
  @{text "0 = 1"} by subtracting @{text "f(n)"} on both sides.}.
  Isabelle tries to prove termination automatically when a definition
  is made. In \S\ref{termination}, we will look at cases where this
  fails and see what to do then.
\<close>

subsection \<open>Pattern matching\<close>

text \<open>\label{patmatch}
  Like in functional programming, we can use pattern matching to
  define functions. At the moment we will only consider \emph{constructor
  patterns}, which only consist of datatype constructors and
  variables. Furthermore, patterns must be linear, i.e.\ all variables
  on the left hand side of an equation must be distinct. In
  \S\ref{genpats} we discuss more general pattern matching.

  If patterns overlap, the order of the equations is taken into
  account. The following function inserts a fixed element between any
  two elements of a list:
\<close>

fun sep :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "sep a (x#y#xs) = x # a # sep a (y # xs)"
| "sep a xs       = xs"

text \<open>
  Overlapping patterns are interpreted as \qt{increments} to what is
  already there: The second equation is only meant for the cases where
  the first one does not match. Consequently, Isabelle replaces it
  internally by the remaining cases, making the patterns disjoint:
\<close>

thm sep.simps

text \<open>@{thm [display] sep.simps[no_vars]}\<close>

text \<open>
  \noindent The equations from function definitions are automatically used in
  simplification:
\<close>

lemma "sep 0 [1, 2, 3] = [1, 0, 2, 0, 3]"
by simp

subsection \<open>Induction\<close>

text \<open>

  Isabelle provides customized induction rules for recursive
  functions. These rules follow the recursive structure of the
  definition. Here is the rule @{thm [source] sep.induct} arising from the
  above definition of @{const sep}:

  @{thm [display] sep.induct}

  We have a step case for list with at least two elements, and two
  base cases for the zero- and the one-element list. Here is a simple
  proof about @{const sep} and @{const map}
\<close>

lemma "map f (sep x ys) = sep (f x) (map f ys)"
apply (induct x ys rule: sep.induct)

text \<open>
  We get three cases, like in the definition.

  @{subgoals [display]}
\<close>

apply auto
done
text \<open>

  With the \cmd{fun} command, you can define about 80\% of the
  functions that occur in practice. The rest of this tutorial explains
  the remaining 20\%.
\<close>

section \<open>fun vs.\ function\<close>

text \<open>
  The \cmd{fun} command provides a
  convenient shorthand notation for simple function definitions. In
  this mode, Isabelle tries to solve all the necessary proof obligations
  automatically. If any proof fails, the definition is
  rejected. This can either mean that the definition is indeed faulty,
  or that the default proof procedures are just not smart enough (or
  rather: not designed) to handle the definition.

  By expanding the abbreviation to the more verbose \cmd{function} command, these proof obligations become visible and can be analyzed or
  solved manually. The expansion from \cmd{fun} to \cmd{function} is as follows:

\end{isamarkuptext}

\[\left[\;\begin{minipage}{0.25\textwidth}\vspace{6pt}
\cmd{fun} @{text "f :: \<tau>"}\\%
\cmd{where}\\%
\hspace*{2ex}{\it equations}\\%
\hspace*{2ex}\vdots\vspace*{6pt}
\end{minipage}\right]
\quad\equiv\quad
\left[\;\begin{minipage}{0.48\textwidth}\vspace{6pt}
\cmd{function} @{text "("}\cmd{sequential}@{text ") f :: \<tau>"}\\%
\cmd{where}\\%
\hspace*{2ex}{\it equations}\\%
\hspace*{2ex}\vdots\\%
\cmd{by} @{text "pat_completeness auto"}\\%
\cmd{termination by} @{text "lexicographic_order"}\vspace{6pt}
\end{minipage}
\right]\]

\begin{isamarkuptext}
  \vspace*{1em}
  \noindent Some details have now become explicit:

  \begin{enumerate}
  \item The \cmd{sequential} option enables the preprocessing of
  pattern overlaps which we already saw. Without this option, the equations
  must already be disjoint and complete. The automatic completion only
  works with constructor patterns.

  \item A function definition produces a proof obligation which
  expresses completeness and compatibility of patterns (we talk about
  this later). The combination of the methods @{text "pat_completeness"} and
  @{text "auto"} is used to solve this proof obligation.

  \item A termination proof follows the definition, started by the
  \cmd{termination} command. This will be explained in \S\ref{termination}.
 \end{enumerate}
  Whenever a \cmd{fun} command fails, it is usually a good idea to
  expand the syntax to the more verbose \cmd{function} form, to see
  what is actually going on.
\<close>

section \<open>Termination\<close>

text \<open>\label{termination}
  The method @{text "lexicographic_order"} is the default method for
  termination proofs. It can prove termination of a
  certain class of functions by searching for a suitable lexicographic
  combination of size measures. Of course, not all functions have such
  a simple termination argument. For them, we can specify the termination
  relation manually.
\<close>

subsection \<open>The {\tt relation} method\<close>
text\<open>
  Consider the following function, which sums up natural numbers up to
  @{text "N"}, using a counter @{text "i"}:
\<close>

function sum :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "sum i N = (if i > N then 0 else i + sum (Suc i) N)"
by pat_completeness auto

text \<open>
  \noindent The @{text "lexicographic_order"} method fails on this example, because none of the
  arguments decreases in the recursive call, with respect to the standard size ordering.
  To prove termination manually, we must provide a custom wellfounded relation.

  The termination argument for @{text "sum"} is based on the fact that
  the \emph{difference} between @{text "i"} and @{text "N"} gets
  smaller in every step, and that the recursion stops when @{text "i"}
  is greater than @{text "N"}. Phrased differently, the expression
  @{text "N + 1 - i"} always decreases.

  We can use this expression as a measure function suitable to prove termination.
\<close>

termination sum
apply (relation "measure (\<lambda>(i,N). N + 1 - i)")

text \<open>
  The \cmd{termination} command sets up the termination goal for the
  specified function @{text "sum"}. If the function name is omitted, it
  implicitly refers to the last function definition.

  The @{text relation} method takes a relation of
  type @{typ "('a \<times> 'a) set"}, where @{typ "'a"} is the argument type of
  the function. If the function has multiple curried arguments, then
  these are packed together into a tuple, as it happened in the above
  example.

  The predefined function @{term[source] "measure :: ('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set"} constructs a
  wellfounded relation from a mapping into the natural numbers (a
  \emph{measure function}).

  After the invocation of @{text "relation"}, we must prove that (a)
  the relation we supplied is wellfounded, and (b) that the arguments
  of recursive calls indeed decrease with respect to the
  relation:

  @{subgoals[display,indent=0]}

  These goals are all solved by @{text "auto"}:
\<close>

apply auto
done

text \<open>
  Let us complicate the function a little, by adding some more
  recursive calls:
\<close>

function foo :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "foo i N = (if i > N
              then (if N = 0 then 0 else foo 0 (N - 1))
              else i + foo (Suc i) N)"
by pat_completeness auto

text \<open>
  When @{text "i"} has reached @{text "N"}, it starts at zero again
  and @{text "N"} is decremented.
  This corresponds to a nested
  loop where one index counts up and the other down. Termination can
  be proved using a lexicographic combination of two measures, namely
  the value of @{text "N"} and the above difference. The @{const
  "measures"} combinator generalizes @{text "measure"} by taking a
  list of measure functions.
\<close>

termination
by (relation "measures [\<lambda>(i, N). N, \<lambda>(i,N). N + 1 - i]") auto

subsection \<open>How @{text "lexicographic_order"} works\<close>

(*fun fails :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
where
  "fails a [] = a"
| "fails a (x#xs) = fails (x + a) (x # xs)"
*)

text \<open>
  To see how the automatic termination proofs work, let's look at an
  example where it fails\footnote{For a detailed discussion of the
  termination prover, see @{cite bulwahnKN07}}:

\end{isamarkuptext}
\cmd{fun} @{text "fails :: \"nat \<Rightarrow> nat list \<Rightarrow> nat\""}\\%
\cmd{where}\\%
\hspace*{2ex}@{text "\"fails a [] = a\""}\\%
|\hspace*{1.5ex}@{text "\"fails a (x#xs) = fails (x + a) (x#xs)\""}\\
\begin{isamarkuptext}

\noindent Isabelle responds with the following error:

\begin{isabelle}
*** Unfinished subgoals:\newline
*** (a, 1, <):\newline
*** \ 1.~@{text "\<And>x. x = 0"}\newline
*** (a, 1, <=):\newline
*** \ 1.~False\newline
*** (a, 2, <):\newline
*** \ 1.~False\newline
*** Calls:\newline
*** a) @{text "(a, x # xs) -->> (x + a, x # xs)"}\newline
*** Measures:\newline
*** 1) @{text "\<lambda>x. size (fst x)"}\newline
*** 2) @{text "\<lambda>x. size (snd x)"}\newline
*** Result matrix:\newline
*** \ \ \ \ 1\ \ 2  \newline
*** a:  ?   <= \newline
*** Could not find lexicographic termination order.\newline
*** At command "fun".\newline
\end{isabelle}
\<close>
text \<open>
  The key to this error message is the matrix at the bottom. The rows
  of that matrix correspond to the different recursive calls (In our
  case, there is just one). The columns are the function's arguments
  (expressed through different measure functions, which map the
  argument tuple to a natural number).

  The contents of the matrix summarize what is known about argument
  descents: The second argument has a weak descent (@{text "<="}) at the
  recursive call, and for the first argument nothing could be proved,
  which is expressed by @{text "?"}. In general, there are the values
  @{text "<"}, @{text "<="} and @{text "?"}.

  For the failed proof attempts, the unfinished subgoals are also
  printed. Looking at these will often point to a missing lemma.
\<close>

subsection \<open>The @{text size_change} method\<close>

text \<open>
  Some termination goals that are beyond the powers of
  @{text lexicographic_order} can be solved automatically by the
  more powerful @{text size_change} method, which uses a variant of
  the size-change principle, together with some other
  techniques. While the details are discussed
  elsewhere @{cite krauss_phd},
  here are a few typical situations where
  @{text lexicographic_order} has difficulties and @{text size_change}
  may be worth a try:
  \begin{itemize}
  \item Arguments are permuted in a recursive call.
  \item Several mutually recursive functions with multiple arguments.
  \item Unusual control flow (e.g., when some recursive calls cannot
  occur in sequence).
  \end{itemize}

  Loading the theory @{text Multiset} makes the @{text size_change}
  method a bit stronger: it can then use multiset orders internally.
\<close>

section \<open>Mutual Recursion\<close>

text \<open>
  If two or more functions call one another mutually, they have to be defined
  in one step. Here are @{text "even"} and @{text "odd"}:
\<close>

function even :: "nat \<Rightarrow> bool"
    and odd  :: "nat \<Rightarrow> bool"
where
  "even 0 = True"
| "odd 0 = False"
| "even (Suc n) = odd n"
| "odd (Suc n) = even n"
by pat_completeness auto

text \<open>
  To eliminate the mutual dependencies, Isabelle internally
  creates a single function operating on the sum
  type @{typ "nat + nat"}. Then, @{const even} and @{const odd} are
  defined as projections. Consequently, termination has to be proved
  simultaneously for both functions, by specifying a measure on the
  sum type:
\<close>

termination
by (relation "measure (\<lambda>x. case x of Inl n \<Rightarrow> n | Inr n \<Rightarrow> n)") auto

text \<open>
  We could also have used @{text lexicographic_order}, which
  supports mutual recursive termination proofs to a certain extent.
\<close>

subsection \<open>Induction for mutual recursion\<close>

text \<open>

  When functions are mutually recursive, proving properties about them
  generally requires simultaneous induction. The induction rule @{thm [source] "even_odd.induct"}
  generated from the above definition reflects this.

  Let us prove something about @{const even} and @{const odd}:
\<close>

lemma even_odd_mod2:
  "even n = (n mod 2 = 0)"
  "odd n = (n mod 2 = 1)"

text \<open>
  We apply simultaneous induction, specifying the induction variable
  for both goals, separated by \cmd{and}:\<close>

apply (induct n and n rule: even_odd.induct)

text \<open>
  We get four subgoals, which correspond to the clauses in the
  definition of @{const even} and @{const odd}:
  @{subgoals[display,indent=0]}
  Simplification solves the first two goals, leaving us with two
  statements about the @{text "mod"} operation to prove:
\<close>

apply simp_all

text \<open>
  @{subgoals[display,indent=0]}

  \noindent These can be handled by Isabelle's arithmetic decision procedures.

\<close>

apply arith
apply arith
done

text \<open>
  In proofs like this, the simultaneous induction is really essential:
  Even if we are just interested in one of the results, the other
  one is necessary to strengthen the induction hypothesis. If we leave
  out the statement about @{const odd} and just write @{term True} instead,
  the same proof fails:
\<close>

lemma failed_attempt:
  "even n = (n mod 2 = 0)"
  "True"
apply (induct n rule: even_odd.induct)

text \<open>
  \noindent Now the third subgoal is a dead end, since we have no
  useful induction hypothesis available:

  @{subgoals[display,indent=0]}
\<close>

oops

section \<open>Elimination\<close>

text \<open>
  A definition of function @{text f} gives rise to two kinds of elimination rules. Rule @{text f.cases}
  simply describes case analysis according to the patterns used in the definition:
\<close>

fun list_to_option :: "'a list \<Rightarrow> 'a option"
where
  "list_to_option [x] = Some x"
| "list_to_option _ = None"

thm list_to_option.cases
text \<open>
  @{thm[display] list_to_option.cases}

  Note that this rule does not mention the function at all, but only describes the cases used for
  defining it. In contrast, the rule @{thm[source] list_to_option.elims} also tell us what the function
  value will be in each case:
\<close>
thm list_to_option.elims
text \<open>
  @{thm[display] list_to_option.elims}

  \noindent
  This lets us eliminate an assumption of the form @{prop "list_to_option xs = y"} and replace it
  with the two cases, e.g.:
\<close>

lemma "list_to_option xs = y \<Longrightarrow> P"
proof (erule list_to_option.elims)
  fix x assume "xs = [x]" "y = Some x" thus P sorry
next
  assume "xs = []" "y = None" thus P sorry
next
  fix a b xs' assume "xs = a # b # xs'" "y = None" thus P sorry
qed

text \<open>
  Sometimes it is convenient to derive specialized versions of the @{text elim} rules above and
  keep them around as facts explicitly. For example, it is natural to show that if
  @{prop "list_to_option xs = Some y"}, then @{term xs} must be a singleton. The command
  \cmd{fun\_cases} derives such facts automatically, by instantiating and simplifying the general
  elimination rules given some pattern:
\<close>

fun_cases list_to_option_SomeE[elim]: "list_to_option xs = Some y"

thm list_to_option_SomeE
text \<open>
  @{thm[display] list_to_option_SomeE}
\<close>

section \<open>General pattern matching\<close>
text\<open>\label{genpats}\<close>

subsection \<open>Avoiding automatic pattern splitting\<close>

text \<open>

  Up to now, we used pattern matching only on datatypes, and the
  patterns were always disjoint and complete, and if they weren't,
  they were made disjoint automatically like in the definition of
  @{const "sep"} in \S\ref{patmatch}.

  This automatic splitting can significantly increase the number of
  equations involved, and this is not always desirable. The following
  example shows the problem:

  Suppose we are modeling incomplete knowledge about the world by a
  three-valued datatype, which has values @{term "T"}, @{term "F"}
  and @{term "X"} for true, false and uncertain propositions, respectively.
\<close>

datatype P3 = T | F | X

text \<open>\noindent Then the conjunction of such values can be defined as follows:\<close>

fun And :: "P3 \<Rightarrow> P3 \<Rightarrow> P3"
where
  "And T p = p"
| "And p T = p"
| "And p F = F"
| "And F p = F"
| "And X X = X"

text \<open>
  This definition is useful, because the equations can directly be used
  as simplification rules. But the patterns overlap: For example,
  the expression @{term "And T T"} is matched by both the first and
  the second equation. By default, Isabelle makes the patterns disjoint by
  splitting them up, producing instances:
\<close>

thm And.simps

text \<open>
  @{thm[indent=4] And.simps}

  \vspace*{1em}
  \noindent There are several problems with this:

  \begin{enumerate}
  \item If the datatype has many constructors, there can be an
  explosion of equations. For @{const "And"}, we get seven instead of
  five equations, which can be tolerated, but this is just a small
  example.

  \item Since splitting makes the equations \qt{less general}, they
  do not always match in rewriting. While the term @{term "And x F"}
  can be simplified to @{term "F"} with the original equations, a
  (manual) case split on @{term "x"} is now necessary.

  \item The splitting also concerns the induction rule @{thm [source]
  "And.induct"}. Instead of five premises it now has seven, which
  means that our induction proofs will have more cases.

  \item In general, it increases clarity if we get the same definition
  back which we put in.
  \end{enumerate}

  If we do not want the automatic splitting, we can switch it off by
  leaving out the \cmd{sequential} option. However, we will have to
  prove that our pattern matching is consistent\footnote{This prevents
  us from defining something like @{term "f x = True"} and @{term "f x
  = False"} simultaneously.}:
\<close>

function And2 :: "P3 \<Rightarrow> P3 \<Rightarrow> P3"
where
  "And2 T p = p"
| "And2 p T = p"
| "And2 p F = F"
| "And2 F p = F"
| "And2 X X = X"

text \<open>
  \noindent Now let's look at the proof obligations generated by a
  function definition. In this case, they are:

  @{subgoals[display,indent=0]}\vspace{-1.2em}\hspace{3cm}\vdots\vspace{1.2em}

  The first subgoal expresses the completeness of the patterns. It has
  the form of an elimination rule and states that every @{term x} of
  the function's input type must match at least one of the patterns\footnote{Completeness could
  be equivalently stated as a disjunction of existential statements:
@{term "(\<exists>p. x = (T, p)) \<or> (\<exists>p. x = (p, T)) \<or> (\<exists>p. x = (p, F)) \<or>
  (\<exists>p. x = (F, p)) \<or> (x = (X, X))"}, and you can use the method @{text atomize_elim} to get that form instead.}. If the patterns just involve
  datatypes, we can solve it with the @{text "pat_completeness"}
  method:
\<close>

apply pat_completeness

text \<open>
  The remaining subgoals express \emph{pattern compatibility}. We do
  allow that an input value matches multiple patterns, but in this
  case, the result (i.e.~the right hand sides of the equations) must
  also be equal. For each pair of two patterns, there is one such
  subgoal. Usually this needs injectivity of the constructors, which
  is used automatically by @{text "auto"}.
\<close>

by auto
termination by (relation "{}") simp

subsection \<open>Non-constructor patterns\<close>

text \<open>
  Most of Isabelle's basic types take the form of inductive datatypes,
  and usually pattern matching works on the constructors of such types.
  However, this need not be always the case, and the \cmd{function}
  command handles other kind of patterns, too.

  One well-known instance of non-constructor patterns are
  so-called \emph{$n+k$-patterns}, which are a little controversial in
  the functional programming world. Here is the initial fibonacci
  example with $n+k$-patterns:
\<close>

function fib2 :: "nat \<Rightarrow> nat"
where
  "fib2 0 = 1"
| "fib2 1 = 1"
| "fib2 (n + 2) = fib2 n + fib2 (Suc n)"

text \<open>
  This kind of matching is again justified by the proof of pattern
  completeness and compatibility.
  The proof obligation for pattern completeness states that every natural number is
  either @{term "0::nat"}, @{term "1::nat"} or @{term "n +
  (2::nat)"}:

  @{subgoals[display,indent=0,goals_limit=1]}

  This is an arithmetic triviality, but unfortunately the
  @{text arith} method cannot handle this specific form of an
  elimination rule. However, we can use the method @{text
  "atomize_elim"} to do an ad-hoc conversion to a disjunction of
  existentials, which can then be solved by the arithmetic decision procedure.
  Pattern compatibility and termination are automatic as usual.
\<close>
apply atomize_elim
apply arith
apply auto
done
termination by lexicographic_order
text \<open>
  We can stretch the notion of pattern matching even more. The
  following function is not a sensible functional program, but a
  perfectly valid mathematical definition:
\<close>

function ev :: "nat \<Rightarrow> bool"
where
  "ev (2 * n) = True"
| "ev (2 * n + 1) = False"
apply atomize_elim
by arith+
termination by (relation "{}") simp

text \<open>
  This general notion of pattern matching gives you a certain freedom
  in writing down specifications. However, as always, such freedom should
  be used with care:

  If we leave the area of constructor
  patterns, we have effectively departed from the world of functional
  programming. This means that it is no longer possible to use the
  code generator, and expect it to generate ML code for our
  definitions. Also, such a specification might not work very well together with
  simplification. Your mileage may vary.
\<close>

subsection \<open>Conditional equations\<close>

text \<open>
  The function package also supports conditional equations, which are
  similar to guards in a language like Haskell. Here is Euclid's
  algorithm written with conditional patterns\footnote{Note that the
  patterns are also overlapping in the base case}:
\<close>

function gcd :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "gcd x 0 = x"
| "gcd 0 y = y"
| "x < y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (Suc x) (y - x)"
| "\<not> x < y \<Longrightarrow> gcd (Suc x) (Suc y) = gcd (x - y) (Suc y)"
by (atomize_elim, auto, arith)
termination by lexicographic_order

text \<open>
  By now, you can probably guess what the proof obligations for the
  pattern completeness and compatibility look like.

  Again, functions with conditional patterns are not supported by the
  code generator.
\<close>

subsection \<open>Pattern matching on strings\<close>

text \<open>
  As strings (as lists of characters) are normal datatypes, pattern
  matching on them is possible, but somewhat problematic. Consider the
  following definition:

\end{isamarkuptext}
\noindent\cmd{fun} @{text "check :: \"string \<Rightarrow> bool\""}\\%
\cmd{where}\\%
\hspace*{2ex}@{text "\"check (''good'') = True\""}\\%
@{text "| \"check s = False\""}
\begin{isamarkuptext}

  \noindent An invocation of the above \cmd{fun} command does not
  terminate. What is the problem? Strings are lists of characters, and
  characters are a datatype with a lot of constructors. Splitting the
  catch-all pattern thus leads to an explosion of cases, which cannot
  be handled by Isabelle.

  There are two things we can do here. Either we write an explicit
  @{text "if"} on the right hand side, or we can use conditional patterns:
\<close>

function check :: "string \<Rightarrow> bool"
where
  "check (''good'') = True"
| "s \<noteq> ''good'' \<Longrightarrow> check s = False"
by auto
termination by (relation "{}") simp

section \<open>Partiality\<close>

text \<open>
  In HOL, all functions are total. A function @{term "f"} applied to
  @{term "x"} always has the value @{term "f x"}, and there is no notion
  of undefinedness.
  This is why we have to do termination
  proofs when defining functions: The proof justifies that the
  function can be defined by wellfounded recursion.

  However, the \cmd{function} package does support partiality to a
  certain extent. Let's look at the following function which looks
  for a zero of a given function f.
\<close>

function (*<*)(domintros)(*>*)findzero :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "findzero f n = (if f n = 0 then n else findzero f (Suc n))"
by pat_completeness auto

text \<open>
  \noindent Clearly, any attempt of a termination proof must fail. And without
  that, we do not get the usual rules @{text "findzero.simps"} and
  @{text "findzero.induct"}. So what was the definition good for at all?
\<close>

subsection \<open>Domain predicates\<close>

text \<open>
  The trick is that Isabelle has not only defined the function @{const findzero}, but also
  a predicate @{term "findzero_dom"} that characterizes the values where the function
  terminates: the \emph{domain} of the function. If we treat a
  partial function just as a total function with an additional domain
  predicate, we can derive simplification and
  induction rules as we do for total functions. They are guarded
  by domain conditions and are called @{text psimps} and @{text
  pinduct}:
\<close>

text \<open>
  \noindent\begin{minipage}{0.79\textwidth}@{thm[display,margin=85] findzero.psimps}\end{minipage}
  \hfill(@{thm [source] "findzero.psimps"})
  \vspace{1em}

  \noindent\begin{minipage}{0.79\textwidth}@{thm[display,margin=85] findzero.pinduct}\end{minipage}
  \hfill(@{thm [source] "findzero.pinduct"})
\<close>

text \<open>
  Remember that all we
  are doing here is use some tricks to make a total function appear
  as if it was partial. We can still write the term @{term "findzero
  (\<lambda>x. 1) 0"} and like any other term of type @{typ nat} it is equal
  to some natural number, although we might not be able to find out
  which one. The function is \emph{underdefined}.

  But it is defined enough to prove something interesting about it. We
  can prove that if @{term "findzero f n"}
  terminates, it indeed returns a zero of @{term f}:
\<close>

lemma findzero_zero: "findzero_dom (f, n) \<Longrightarrow> f (findzero f n) = 0"

text \<open>\noindent We apply induction as usual, but using the partial induction
  rule:\<close>

apply (induct f n rule: findzero.pinduct)

text \<open>\noindent This gives the following subgoals:

  @{subgoals[display,indent=0]}

  \noindent The hypothesis in our lemma was used to satisfy the first premise in
  the induction rule. However, we also get @{term
  "findzero_dom (f, n)"} as a local assumption in the induction step. This
  allows unfolding @{term "findzero f n"} using the @{text psimps}
  rule, and the rest is trivial.
\<close>
apply (simp add: findzero.psimps)
done

text \<open>
  Proofs about partial functions are often not harder than for total
  functions. Fig.~\ref{findzero_isar} shows a slightly more
  complicated proof written in Isar. It is verbose enough to show how
  partiality comes into play: From the partial induction, we get an
  additional domain condition hypothesis. Observe how this condition
  is applied when calls to @{term findzero} are unfolded.
\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>
lemma "\<lbrakk>findzero_dom (f, n); x \<in> {n ..< findzero f n}\<rbrakk> \<Longrightarrow> f x \<noteq> 0"
proof (induct rule: findzero.pinduct)
  fix f n assume dom: "findzero_dom (f, n)"
               and IH: "\<lbrakk>f n \<noteq> 0; x \<in> {Suc n ..< findzero f (Suc n)}\<rbrakk> \<Longrightarrow> f x \<noteq> 0"
               and x_range: "x \<in> {n ..< findzero f n}"
  have "f n \<noteq> 0"
  proof
    assume "f n = 0"
    with dom have "findzero f n = n" by (simp add: findzero.psimps)
    with x_range show False by auto
  qed

  from x_range have "x = n \<or> x \<in> {Suc n ..< findzero f n}" by auto
  thus "f x \<noteq> 0"
  proof
    assume "x = n"
    with \<open>f n \<noteq> 0\<close> show ?thesis by simp
  next
    assume "x \<in> {Suc n ..< findzero f n}"
    with dom and \<open>f n \<noteq> 0\<close> have "x \<in> {Suc n ..< findzero f (Suc n)}" by (simp add: findzero.psimps)
    with IH and \<open>f n \<noteq> 0\<close>
    show ?thesis by simp
  qed
qed
text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{A proof about a partial function}\label{findzero_isar}
\end{figure}
\<close>

subsection \<open>Partial termination proofs\<close>

text \<open>
  Now that we have proved some interesting properties about our
  function, we should turn to the domain predicate and see if it is
  actually true for some values. Otherwise we would have just proved
  lemmas with @{term False} as a premise.

  Essentially, we need some introduction rules for @{text
  findzero_dom}. The function package can prove such domain
  introduction rules automatically. But since they are not used very
  often (they are almost never needed if the function is total), this
  functionality is disabled by default for efficiency reasons. So we have to go
  back and ask for them explicitly by passing the @{text
  "(domintros)"} option to the function package:

\vspace{1ex}
\noindent\cmd{function} @{text "(domintros) findzero :: \"(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat\""}\\%
\cmd{where}\isanewline%
\ \ \ldots\\

  \noindent Now the package has proved an introduction rule for @{text findzero_dom}:
\<close>

thm findzero.domintros

text \<open>
  @{thm[display] findzero.domintros}

  Domain introduction rules allow to show that a given value lies in the
  domain of a function, if the arguments of all recursive calls
  are in the domain as well. They allow to do a \qt{single step} in a
  termination proof. Usually, you want to combine them with a suitable
  induction principle.

  Since our function increases its argument at recursive calls, we
  need an induction principle which works \qt{backwards}. We will use
  @{thm [source] inc_induct}, which allows to do induction from a fixed number
  \qt{downwards}:

  \begin{center}@{thm inc_induct}\hfill(@{thm [source] "inc_induct"})\end{center}

  Figure \ref{findzero_term} gives a detailed Isar proof of the fact
  that @{text findzero} terminates if there is a zero which is greater
  or equal to @{term n}. First we derive two useful rules which will
  solve the base case and the step case of the induction. The
  induction is then straightforward, except for the unusual induction
  principle.

\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>
lemma findzero_termination:
  assumes "x \<ge> n" and "f x = 0"
  shows "findzero_dom (f, n)"
proof -
  have base: "findzero_dom (f, x)"
    by (rule findzero.domintros) (simp add:\<open>f x = 0\<close>)

  have step: "\<And>i. findzero_dom (f, Suc i)
    \<Longrightarrow> findzero_dom (f, i)"
    by (rule findzero.domintros) simp

  from \<open>x \<ge> n\<close> show ?thesis
  proof (induct rule:inc_induct)
    show "findzero_dom (f, x)" by (rule base)
  next
    fix i assume "findzero_dom (f, Suc i)"
    thus "findzero_dom (f, i)" by (rule step)
  qed
qed
text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{Termination proof for @{text findzero}}\label{findzero_term}
\end{figure}
\<close>

text \<open>
  Again, the proof given in Fig.~\ref{findzero_term} has a lot of
  detail in order to explain the principles. Using more automation, we
  can also have a short proof:
\<close>

lemma findzero_termination_short:
  assumes zero: "x >= n"
  assumes [simp]: "f x = 0"
  shows "findzero_dom (f, n)"
using zero
by (induct rule:inc_induct) (auto intro: findzero.domintros)

text \<open>
  \noindent It is simple to combine the partial correctness result with the
  termination lemma:
\<close>

lemma findzero_total_correctness:
  "f x = 0 \<Longrightarrow> f (findzero f 0) = 0"
by (blast intro: findzero_zero findzero_termination)

subsection \<open>Definition of the domain predicate\<close>

text \<open>
  Sometimes it is useful to know what the definition of the domain
  predicate looks like. Actually, @{text findzero_dom} is just an
  abbreviation:

  @{abbrev[display] findzero_dom}

  The domain predicate is the \emph{accessible part} of a relation @{const
  findzero_rel}, which was also created internally by the function
  package. @{const findzero_rel} is just a normal
  inductive predicate, so we can inspect its definition by
  looking at the introduction rules @{thm [source] findzero_rel.intros}.
  In our case there is just a single rule:

  @{thm[display] findzero_rel.intros}

  The predicate @{const findzero_rel}
  describes the \emph{recursion relation} of the function
  definition. The recursion relation is a binary relation on
  the arguments of the function that relates each argument to its
  recursive calls. In general, there is one introduction rule for each
  recursive call.

  The predicate @{term "Wellfounded.accp findzero_rel"} is the accessible part of
  that relation. An argument belongs to the accessible part, if it can
  be reached in a finite number of steps (cf.~its definition in @{text
  "Wellfounded.thy"}).

  Since the domain predicate is just an abbreviation, you can use
  lemmas for @{const Wellfounded.accp} and @{const findzero_rel} directly. Some
  lemmas which are occasionally useful are @{thm [source] accpI}, @{thm [source]
  accp_downward}, and of course the introduction and elimination rules
  for the recursion relation @{thm [source] "findzero_rel.intros"} and @{thm
  [source] "findzero_rel.cases"}.
\<close>

section \<open>Nested recursion\<close>

text \<open>
  Recursive calls which are nested in one another frequently cause
  complications, since their termination proof can depend on a partial
  correctness property of the function itself.

  As a small example, we define the \qt{nested zero} function:
\<close>

function nz :: "nat \<Rightarrow> nat"
where
  "nz 0 = 0"
| "nz (Suc n) = nz (nz n)"
by pat_completeness auto

text \<open>
  If we attempt to prove termination using the identity measure on
  naturals, this fails:
\<close>

termination
  apply (relation "measure (\<lambda>n. n)")
  apply auto

text \<open>
  We get stuck with the subgoal

  @{subgoals[display]}

  Of course this statement is true, since we know that @{const nz} is
  the zero function. And in fact we have no problem proving this
  property by induction.
\<close>
(*<*)oops(*>*)
lemma nz_is_zero: "nz_dom n \<Longrightarrow> nz n = 0"
  by (induct rule:nz.pinduct) (auto simp: nz.psimps)

text \<open>
  We formulate this as a partial correctness lemma with the condition
  @{term "nz_dom n"}. This allows us to prove it with the @{text
  pinduct} rule before we have proved termination. With this lemma,
  the termination proof works as expected:
\<close>

termination
  by (relation "measure (\<lambda>n. n)") (auto simp: nz_is_zero)

text \<open>
  As a general strategy, one should prove the statements needed for
  termination as a partial property first. Then they can be used to do
  the termination proof. This also works for less trivial
  examples. Figure \ref{f91} defines the 91-function, a well-known
  challenge problem due to John McCarthy, and proves its termination.
\<close>

text_raw \<open>
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
\<close>

function f91 :: "nat \<Rightarrow> nat"
where
  "f91 n = (if 100 < n then n - 10 else f91 (f91 (n + 11)))"
by pat_completeness auto

lemma f91_estimate:
  assumes trm: "f91_dom n"
  shows "n < f91 n + 11"
using trm by induct (auto simp: f91.psimps)

termination
proof
  let ?R = "measure (\<lambda>x. 101 - x)"
  show "wf ?R" ..

  fix n :: nat assume "\<not> 100 < n" -- "Assumptions for both calls"

  thus "(n + 11, n) \<in> ?R" by simp -- "Inner call"

  assume inner_trm: "f91_dom (n + 11)" -- "Outer call"
  with f91_estimate have "n + 11 < f91 (n + 11) + 11" .
  with \<open>\<not> 100 < n\<close> show "(f91 (n + 11), n) \<in> ?R" by simp
qed

text_raw \<open>
\isamarkupfalse\isabellestyle{tt}
\end{minipage}
\vspace{6pt}\hrule
\caption{McCarthy's 91-function}\label{f91}
\end{figure}
\<close>

section \<open>Higher-Order Recursion\<close>

text \<open>
  Higher-order recursion occurs when recursive calls
  are passed as arguments to higher-order combinators such as @{const
  map}, @{term filter} etc.
  As an example, imagine a datatype of n-ary trees:
\<close>

datatype 'a tree =
  Leaf 'a
| Branch "'a tree list"

text \<open>\noindent We can define a function which swaps the left and right subtrees recursively, using the
  list functions @{const rev} and @{const map}:\<close>

fun mirror :: "'a tree \<Rightarrow> 'a tree"
where
  "mirror (Leaf n) = Leaf n"
| "mirror (Branch l) = Branch (rev (map mirror l))"

text \<open>
  Although the definition is accepted without problems, let us look at the termination proof:
\<close>

termination proof
  text \<open>

  As usual, we have to give a wellfounded relation, such that the
  arguments of the recursive calls get smaller. But what exactly are
  the arguments of the recursive calls when mirror is given as an
  argument to @{const map}? Isabelle gives us the
  subgoals

  @{subgoals[display,indent=0]}

  So the system seems to know that @{const map} only
  applies the recursive call @{term "mirror"} to elements
  of @{term "l"}, which is essential for the termination proof.

  This knowledge about @{const map} is encoded in so-called congruence rules,
  which are special theorems known to the \cmd{function} command. The
  rule for @{const map} is

  @{thm[display] map_cong}

  You can read this in the following way: Two applications of @{const
  map} are equal, if the list arguments are equal and the functions
  coincide on the elements of the list. This means that for the value
  @{term "map f l"} we only have to know how @{term f} behaves on
  the elements of @{term l}.

  Usually, one such congruence rule is
  needed for each higher-order construct that is used when defining
  new functions. In fact, even basic functions like @{const
  If} and @{const Let} are handled by this mechanism. The congruence
  rule for @{const If} states that the @{text then} branch is only
  relevant if the condition is true, and the @{text else} branch only if it
  is false:

  @{thm[display] if_cong}

  Congruence rules can be added to the
  function package by giving them the @{term fundef_cong} attribute.

  The constructs that are predefined in Isabelle, usually
  come with the respective congruence rules.
  But if you define your own higher-order functions, you may have to
  state and prove the required congruence rules yourself, if you want to use your
  functions in recursive definitions.
\<close>
(*<*)oops(*>*)

subsection \<open>Congruence Rules and Evaluation Order\<close>

text \<open>
  Higher order logic differs from functional programming languages in
  that it has no built-in notion of evaluation order. A program is
  just a set of equations, and it is not specified how they must be
  evaluated.

  However for the purpose of function definition, we must talk about
  evaluation order implicitly, when we reason about termination.
  Congruence rules express that a certain evaluation order is
  consistent with the logical definition.

  Consider the following function.
\<close>

function f :: "nat \<Rightarrow> bool"
where
  "f n = (n = 0 \<or> f (n - 1))"
(*<*)by pat_completeness auto(*>*)

text \<open>
  For this definition, the termination proof fails. The default configuration
  specifies no congruence rule for disjunction. We have to add a
  congruence rule that specifies left-to-right evaluation order:

  \vspace{1ex}
  \noindent @{thm disj_cong}\hfill(@{thm [source] "disj_cong"})
  \vspace{1ex}

  Now the definition works without problems. Note how the termination
  proof depends on the extra condition that we get from the congruence
  rule.

  However, as evaluation is not a hard-wired concept, we
  could just turn everything around by declaring a different
  congruence rule. Then we can make the reverse definition:
\<close>

lemma disj_cong2[fundef_cong]:
  "(\<not> Q' \<Longrightarrow> P = P') \<Longrightarrow> (Q = Q') \<Longrightarrow> (P \<or> Q) = (P' \<or> Q')"
  by blast

fun f' :: "nat \<Rightarrow> bool"
where
  "f' n = (f' (n - 1) \<or> n = 0)"

text \<open>
  \noindent These examples show that, in general, there is no \qt{best} set of
  congruence rules.

  However, such tweaking should rarely be necessary in
  practice, as most of the time, the default set of congruence rules
  works well.
\<close>

end


theory Chapter3
imports "HOL-IMP.BExp"
        "HOL-IMP.ASM"
begin

(*
\section*{Chapter 3}

\exercise
To show that @{const asimp_const} really folds all subexpressions of the form
@{term "Plus (N i) (N j)"}, define a function
*)

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal (N _) = True"
| "optimal (V _) = True"
| "optimal (Plus (N _) (N _)) = False"
| "optimal (Plus a1 a2) = (case ((optimal a1),(optimal a2)) of
      (False,_) \<Rightarrow> False
      |(_,False) \<Rightarrow> False
      |_ \<Rightarrow> True)"
(*
that checks that its argument does not contain a subexpression of the form
@{term "Plus (N i) (N j)"}. Then prove that the result of @{const asimp_const}
is optimal:
*)

lemma "optimal (asimp_const a)"
  apply(induction a rule:asimp_const.induct)
  apply(auto split:aexp.split)
  done
(*
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
*)

lemma "optimal (asimp_const a)" (is "?P a")
proof (induction a rule:asimp_const.induct)
  fix n
  let ?a = "N n"
  show "?P ?a" by simp
next
  fix x
  let ?a = "V x"
  show "?P ?a" by simp
next
  fix a1 a2
  assume ind1: "optimal (asimp_const a1)" "optimal (asimp_const a2)"
  let ?a = "Plus a1 a2"
  show "?P ?a"
    using ind1 by (auto split : aexp.split)
qed

(*
This proof needs the same @{text "split:"} directive as the correctness proof of
@{const asimp_const}. This increases the chance of nontermination
of the simplifier. Therefore @{const optimal} should be defined purely by
pattern matching on the left-hand side,
without @{text case} expressions on the right-hand side.
\endexercise

\exercise
In this exercise we verify constant folding for @{typ aexp}
where we sum up all constants, even if they are not next to each other.
For example, @{term "Plus (N 1) (Plus (V x) (N 2))"} becomes
@{term "Plus (V x) (N 3)"}. This goes beyond @{const asimp}.
Below we follow a particular solution strategy but there are many others.

First, define a function @{text sumN} that returns the sum of all
constants in an expression and a function @{text zeroN} that replaces all
constants in an expression by zeroes (they will be optimized away later):*)

fun sumN :: "aexp \<Rightarrow> int" where
  "sumN (N n) = n"
| "sumN (V x) = 0"
| "sumN (Plus a1 a2) = (+) (sumN a1) (sumN a2)"

fun zeroN :: "aexp \<Rightarrow> aexp" where
  "zeroN (N n) = N 0"
| "zeroN (V x) = V x"
| "zeroN (Plus a1 a2) = Plus (zeroN a1) (zeroN a2)"

(*
Next, define a function @{text sepN} that produces an arithmetic expression
that adds the results of @{const sumN} and @{const zeroN}. Prove that
@{text sepN} preserves the value of an expression.
*)

definition sepN :: "aexp \<Rightarrow> aexp" where
  "sepN a = Plus (N (sumN a)) (zeroN a)"

lemma aval_sepN: "aval (sepN t) s = aval t s"
  apply(induction t)
  apply(auto simp add : sepN_def)
  done

lemma aval_sepN_isar: "aval (sepN t) s = aval t s" (is "?P t s")
proof (induction t arbitrary : s)
  fix x s
  let ?t = "N x"
  have "aval (sepN ?t) s = (aval (Plus (N (sumN ?t)) (zeroN ?t)) s)" by (auto simp add : sepN_def)
  also have "(aval (Plus (N (sumN ?t)) (zeroN ?t)) s) = (aval ?t s)" by simp
  finally show "?P ?t s" by simp
next
  fix x s
  let ?t = "V x"
  show "?P ?t s" by (simp add : sepN_def)
next
  fix t1 t2 s
  assume IH : "\<And>s. aval (sepN t1) s = aval t1 s" "\<And>s. aval (sepN t2) s = aval t2 s"
  let ?t = "Plus t1 t2"
  have "aval (sepN (Plus t1 t2)) s = aval (Plus (N (sumN ?t)) (zeroN ?t)) s" using sepN_def by simp
  also have "... = (+) (aval (N (sumN ?t)) s) (aval (zeroN ?t) s)" by simp
  also have "... = (+) ((+) (aval (N (sumN t1)) s) (aval (N (sumN t2)) s))
                       ((+) (aval (zeroN t1) s) (aval (zeroN t2) s))" by simp
  also have "... = (+) ((+) (aval (N (sumN t1)) s) (aval (zeroN t1) s))
                       ((+) (aval (N (sumN t2)) s) (aval (zeroN t2) s))" by simp
  also have "... = (+) (aval (sepN t1) s)
                       (aval (sepN t2) s)" using sepN_def by simp
  also have "... = aval ?t s" using IH by simp
  finally show "?P ?t s" using sepN_def by auto
qed

(*
Finally, define a function @{text full_asimp} that uses @{const asimp}
to eliminate the zeroes left over by @{const sepN}.
Prove that it preserves the value of an arithmetic expression.
*)

definition full_asimp :: "aexp \<Rightarrow> aexp" where
  "full_asimp a = asimp (sepN a)"

lemma aval_full_asimp: "aval (full_asimp t) s = aval t s"
  apply(induction t)
  apply(auto simp add:full_asimp_def sepN_def)
  done

lemma aval_full_asimp_isar : "aval (full_asimp t) s = aval t s" (is "?P t s")
proof (induction t)
  fix x
  let ?t = "N x"
  show "?P ?t s" by (simp add : full_asimp_def sepN_def)
next
  fix x
  let ?t = "V x"
  show "?P ?t s" by (simp add : full_asimp_def sepN_def)
next
  fix t1 t2
  assume ind : "aval (full_asimp t1) s = aval t1 s" "aval (full_asimp t2) s = aval t2 s"
  let ?t = "Plus t1 t2"
  have "aval (full_asimp ?t) s = aval (asimp (sepN ?t)) s" by (simp add : full_asimp_def)
  also have "... = aval (asimp (Plus (N (sumN ?t)) (zeroN ?t))) s" by (simp add : sepN_def)
  finally show "?P ?t s" using ind full_asimp_def sepN_def by simp
qed

 (*
Substitution is the process of replacing a variable
by an expression in an expression. Define a substitution function
*)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst x a (V y) = (if x = y then a else V y)"
| "subst _ _ (N n) = N n"
| "subst x a1 (Plus a2 a3) = Plus (subst x a1 a2) (subst x a1 a3)"

(*
such that @{term "subst x a e"} is the result of replacing
every occurrence of variable @{text x} by @{text a} in @{text e}.
For example:
@{lemma[display] "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')" by simp}

Prove the so-called \concept{substitution lemma} that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
*)

lemma subst_lemma: "aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
    apply(auto)
  done
lemma subst_lemma_isar : "aval (subst x a e) s = aval e (s (x := aval a s))" (is "?P e")
proof (induction e)
  fix n
  let ?e = "N n"
  show "?P ?e" by auto
next
  fix v
  let ?e = "V v"
  show "?P ?e" by auto
next
  fix e1 e2
  assume ind : "aval (subst x a e1) s = aval e1 (s(x := aval a s))"
               "aval (subst x a e2) s = aval e2 (s(x := aval a s))"
  let ?e ="Plus e1 e2"
  have "aval (subst x a ?e) s = aval (Plus (subst x a e1) (subst x a e2)) s" by simp
  also have "... = (aval (subst x a e1) s) + (aval (subst x a e2) s)" by simp
  also have "... = (aval e1 (s(x := aval a s))) + (aval e2 (s(x := aval a s)))" using ind by simp
  also have "... = aval (Plus e1 e2) (s (x := aval a s))" by simp
  (* finally show "?P ?e" by simp   *) (* qqq : pourquoi pas *)
  finally show "aval (subst x a ?e) s = aval ?e (s (x := aval a s))" by simp
qed

(*
As a consequence prove that we can substitute equal expressions by equal expressions
and obtain the same result under evaluation:
*)

lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(induction e)
    apply(auto)
  done

lemma "aval a1 s = aval a2 s
  \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
proof-
  fix a1 a2 s
  assume H : "aval a1 s = aval a2 s"
  show "aval (subst x a1 e) s = aval (subst x a2 e) s" (is "?P e")
  proof (induction e)
    fix n
    let ?e = "N n"
    show "?P ?e" by simp
  next
    fix v
    let ?e = "V v"
(*    have "aval (subst x a1 ?e) s = aval (if x = v then a1 else V v) s" (is "?Q = ?R")
      by simp
    also have "... = (if x = v then aval a1 s else aval (V v) s)" by simp
    finally show "?P ?e" using \<open>aval a1 s = aval a2 s\<close> by simp  *)
    show "?P ?e" using \<open>aval a1 s = aval a2 s\<close> by simp
  next
    fix e1 e2
    assume id : "aval (subst x a1 e1) s = aval (subst x a2 e1) s"
                "aval (subst x a1 e2) s = aval (subst x a2 e2) s"
    let ?e = "Plus e1 e2"
    show "?P ?e" using H id by simp
  qed
qed

(*
Take a copy of theory @{short_theory "AExp"} and modify it as follows.
Extend type @{typ aexp} with a binary constructor @{text Times} that
represents multiplication. Modify the definition of the functions @{const aval}
and @{const asimp} accordingly. You can remove @{const asimp_const}.
Function @{const asimp} should eliminate 0 and 1 from multiplications
as well as evaluate constant subterms. Update all proofs concerned.
*)

datatype myaexp = N int | V vname | Plus myaexp myaexp | Times myaexp myaexp

fun myaval :: "myaexp \<Rightarrow> state \<Rightarrow> val" where
  "myaval (N n) _ = n"
| "myaval (V x) s = s x"
| "myaval (Plus a1 a2) s = (+) (myaval a1 s) (myaval a2 s)"
| "myaval (Times a1 a2) s = (*) (myaval a1 s) (myaval a2 s)"

fun myplus :: "myaexp \<Rightarrow> myaexp \<Rightarrow> myaexp" where
  "myplus (N n1) (N n2) = N (n1 + n2)"
| "myplus (N n) a = (if n = 0 then a else (Plus (N n) a))"
| "myplus a (N n) = (if n = 0 then a else (Plus a (N n)))"
| "myplus a1 a2 = Plus a1 a2"

fun mytimes :: "myaexp \<Rightarrow> myaexp \<Rightarrow> myaexp" where
  "mytimes (N n1) (N n2) = N (n1 * n2)"
| "mytimes (N n) a = (if n = 0 then N 0 else if n = 1 then a else (Times (N n) a))"
| "mytimes a (N n) = (if n = 0 then N 0 else if n = 1 then a else (Times a (N n)))"
| "mytimes a1 a2 = Times a1 a2"

fun myasimp :: "myaexp \<Rightarrow> myaexp" where
  "myasimp (N x) = (N x)"
| "myasimp (V x) = (V x)"
| "myasimp (Plus a1 a2) = myplus (myasimp a1) (myasimp a2)"
| "myasimp (Times a1 a2) = mytimes (myasimp a1) (myasimp a2)"

(*
Define a datatype @{text aexp2} of extended arithmetic expressions that has,
in addition to the constructors of @{typ aexp}, a constructor for
modelling a C-like post-increment operation $x{++}$, where $x$ must be a
variable. Define an evaluation function @{text "aval2 :: aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state"}
that returns both the value of the expression and the new state.
The latter is required because post-increment changes the state.

Extend @{text aexp2} and @{text aval2} with a division operation. Model partiality of
division by changing the return type of @{text aval2} to
@{typ "(val \<times> state) option"}. In case of division by 0 let @{text aval2}
return @{const None}. Division on @{typ int} is the infix @{text div}.
*)

(*

The following type adds a @{text LET} construct to arithmetic expressions:
*)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

(* The @{const LET} constructor introduces a local variable:
the value of @{term "LET x e\<^sub>1 e\<^sub>2"} is the value of @{text e\<^sub>2}
in the state where @{text x} is bound to the value of @{text e\<^sub>1} in the original state.
Define a function @{const lval} @{text"::"} @{typ "lexp \<Rightarrow> state \<Rightarrow> int"}
that evaluates @{typ lexp} expressions. Remember @{term"s(x := i)"}.*)

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
  "lval (Nl n) _ = n"
| "lval (Vl v) s = s v"
| "lval (Plusl e1 e2) s = (+) (lval e1 s) (lval e2 s)"
| "lval (LET x e1 e2) s = lval e2 (s (x := lval e1 s))"

(*
Define a conversion @{const inline} @{text"::"} @{typ "lexp \<Rightarrow> aexp"}.
The expression \mbox{@{term "LET x e\<^sub>1 e\<^sub>2"}} is inlined by substituting
the converted form of @{text e\<^sub>1} for @{text x} in the converted form of @{text e\<^sub>2}.
See Exercise~\ref{exe:subst} for more on substitution.
Prove that @{const inline} is correct w.r.t.\ evaluation.
\endexercise
*)

fun inline :: "lexp \<Rightarrow> aexp" where
  "inline (Nl n) = (aexp.N n)"
| "inline (Vl v) = (aexp.V v)"
| "inline (Plusl e1 e2) = aexp.Plus (inline e1) (inline e2)"
| "inline (LET x e1 e2) = subst x (inline e1) (inline e2)"

(*
lemma "lval e s = aval (inline e) s"
  apply(induction e rule:lexp.induct)
  apply(auto split:aexp.split lexp.split)
*)

(*
\exercise
Show that equality and less-or-equal tests on @{text aexp} are definable
*)

definition Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Le a1 a2 = Not (Less a2 a1)"

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "Eq a1 a2 = And (Le a1 a2) (Le a2 a1)"

(*
and prove that they do what they are supposed to:
*)

lemma bval_Le: "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
  apply(simp add : Le_def)
  apply(auto)
  done

lemma bval_Le_isar : "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
proof-
  fix a1 a2 s
  have "bval (Le a1 a2) s = bval (Not (Less a2 a1)) s" by (simp add : Le_def)
  also have "... = (\<not> bval (Less a2 a1) s)" by simp
  also have "... = (\<not> (aval a2 s) < (aval a1 s))" by simp
  also have "... = ((aval a1 s) \<le> (aval a2 s))" by auto
  finally show "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)" by simp
qed

lemma bval_Eq: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  apply(simp add : Eq_def Le_def)
  apply(auto)
  done

lemma bval_Eq_isar: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
  unfolding Eq_def Le_def
proof
  fix a1 a2 s
  assume "bval (And (bexp.Not (Less a2 a1)) (bexp.Not (Less a1 a2))) s"
  then show "aval a1 s = aval a2 s" by simp
next
  fix a1 a2 s
  assume "aval a1 s = aval a2 s"
  then show "bval (And (bexp.Not (Less a2 a1)) (bexp.Not (Less a1 a2))) s" by simp
qed

(*
Consider an alternative type of boolean expressions featuring a conditional:
*)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

(* First define an evaluation function analogously to @{const bval}: *)

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool" where
  "ifval (Bc2 b) s = b"
| "ifval (If ife1 ife2 ife3) s = (if (ifval ife1 s) then (ifval ife2 s) else (ifval ife3 s))"
| "ifval (Less2 ae1 ae2) s = ((aval ae1 s) < (aval ae2 s))"

text{* Then define two translation functions *}

fun b2ifexp :: "bexp \<Rightarrow> ifexp" where
  "b2ifexp (Bc v) = (Bc2 v)"
| "b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))"
| "b2ifexp (And b1 b2) = (If (b2ifexp b1) (If (b2ifexp b2) (Bc2 True) (Bc2 False)) (Bc2 False))"
| "b2ifexp (Less a1 a2) = (Less2 a1 a2)"

fun if2bexp :: "ifexp \<Rightarrow> bexp" where
  "if2bexp (Bc2 b) = (Bc b)"
| "if2bexp (If e1 e2 e3) = (Not (And (Not (And (if2bexp e1) (if2bexp e2)))
                                     (Not (And (Not (if2bexp e1)) (if2bexp e3)))
                                 ))"
| "if2bexp (Less2 a1 a2) = (Less a1 a2)"

text{* and prove their correctness: *}

lemma "bval (if2bexp exp) s = ifval exp s"
  by induction auto

lemma "bval (if2bexp exp) s = ifval exp s" (is "?P ?exp")
proof (induction)
  fix x
  let ?exp = "Bc2 x"
  show "bval (if2bexp ?exp) s = ifval ?exp s" by auto
next
  fix a1 a2
  let ?exp = "Less2 a1 a2"
  show "bval (if2bexp ?exp) s = ifval ?exp s" by auto
next
  fix e1 e2 e3
  assume ind : "bval (if2bexp e1) s = ifval e1 s"
               "bval (if2bexp e2) s = ifval e2 s"
               "bval (if2bexp e3) s = ifval e3 s"
  let ?exp = "If e1 e2 e3"
  have "bval (if2bexp (ifexp.If e1 e2 e3)) s =
           bval (Not (And (Not (And (if2bexp e1) (if2bexp e2)))
                     (Not (And (Not (if2bexp e1)) (if2bexp e3)))
                 )) s" by simp
  then show "bval (if2bexp ?exp) s = ifval ?exp s" using ind by auto
qed

lemma "ifval (b2ifexp exp) s = bval exp s"
  by (induction exp) auto

text{*
\endexercise

\exercise
We define a new type of purely boolean expressions without any arithmetic
*}

datatype pbexp =
  VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

text{*
where variables range over values of type @{typ bool},
as can be seen from the evaluation function:
*}

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool" where
"pbval (VAR x) s = s x"  |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

text {* Define a function that checks whether a boolean exression is in NNF
(negation normal form), i.e., if @{const NOT} is only applied directly
to @{const VAR}s: *}

fun is_nnf :: "pbexp \<Rightarrow> bool" where
  "is_nnf (AND b1 b2) = ((is_nnf b1) \<and> (is_nnf b2))"
| "is_nnf (OR b1 b2) = ((is_nnf b1) \<and> (is_nnf b2))"
| "is_nnf (NOT (VAR _)) = True"
| "is_nnf (NOT _) = False"
| "is_nnf (VAR _) = True"

(*
Now define a function that converts a @{text bexp} into NNF by pushing
@{const NOT} inwards as much as possible:
*)

fun nnf :: "pbexp \<Rightarrow> pbexp" where
  "nnf (VAR x) = (VAR x)"
| "nnf (AND e1 e2) = (AND (nnf e1) (nnf e2))"
| "nnf (OR e1 e2) = (OR (nnf e1) (nnf e2))"
| "nnf (NOT (NOT e)) = (nnf e)"
| "nnf (NOT (VAR x)) = (NOT (VAR x))"
| "nnf (NOT (AND e1 e2)) = (OR (nnf (NOT e1)) (nnf (NOT e2)))"
| "nnf (NOT (OR e1 e2)) = (AND (nnf (NOT e1)) (nnf (NOT e2)))"

(*
Prove that @{const nnf} does what it is supposed to do:
*)

lemma pbval_nnf: "pbval (nnf b) s = pbval b s"
  apply(induction b rule : nnf.induct)
        apply(auto)
  done

lemma pbval_nnf_isar : "pbval (nnf b) s = pbval b s" (is "?P b")
proof (induction b rule : nnf.induct)
  fix x
  let ?b = "VAR x"
  show "?P ?b" by simp
next
  fix e1 e2
  assume ind : "pbval (nnf e1) s = pbval e1 s"
                "pbval (nnf e2) s = pbval e2 s"
  let ?b = "AND e1 e2"
  show "?P ?b" using ind by simp

next
  fix e1 e2
  assume ind : "pbval (nnf e1) s = pbval e1 s"
                "pbval (nnf e2) s = pbval e2 s"
  show "?P (OR e1 e2)" using ind by simp
next
  fix e
  assume ind : "pbval (nnf e) s = pbval e s"
  show "?P (NOT (NOT e))" using ind by simp
next
  fix x
  show "?P (NOT (VAR x))"  by simp
next
  fix e1 e2
  assume ind : "pbval (nnf (NOT e1)) s = pbval (NOT e1) s"
         "pbval (nnf (NOT e2)) s = pbval (NOT e2) s"
  show "?P (NOT (AND e1 e2))" using ind by simp
next
  fix e1 e2
  assume ind : "pbval (nnf (NOT e1)) s = pbval (NOT e1) s"
               "pbval (nnf (NOT e2)) s = pbval (NOT e2) s"
  show "?P (NOT (OR e1 e2))" using ind by simp
qed

lemma is_nnf_nnf: "is_nnf (nnf b)"
  apply (induction b rule:nnf.induct)
  apply(auto)
  done

lemma is_nnf_nnf_isar: "is_nnf (nnf b)" (is "?P b")
proof (induction b rule : nnf.induct)
  (* 1*)
  fix x
  let ?b = "VAR x"
  show "?P ?b" by simp
next
  (* 2 *)
  fix e1 e2
  assume ind : "is_nnf (nnf e1)" "is_nnf (nnf e2)"
  let ?b = "AND e1 e2"
  show "?P ?b" using ind by simp
next
  (* 3 *)
  fix e1 e2
  assume ind : "is_nnf (nnf e1)" "is_nnf (nnf e2)"
  let ?b = "OR e1 e2"
  show "?P ?b" using ind by simp
next
  (* 4*)
  fix e
  assume ind : "is_nnf (nnf e)"
  let ?b = "NOT (NOT e)"
  show "?P ?b" using ind by simp
next
  (* 5 *)
  fix x
  let ?b ="NOT (VAR x)"
  show "?P ?b" by simp
next
  (* 6 *)
  fix e1 e2
  show "\<lbrakk>is_nnf (nnf (NOT e1)); is_nnf (nnf (NOT e2))\<rbrakk> \<Longrightarrow> is_nnf (nnf (NOT (AND e1 e2)))" by simp
next
  (* 7 *)
  fix e1 e2
  show "\<lbrakk>is_nnf (nnf (NOT e1)); is_nnf (nnf (NOT e2))\<rbrakk> \<Longrightarrow> is_nnf (nnf (NOT (OR e1 e2)))" by simp
qed

(*
An expression is in DNF (disjunctive normal form) if it is in NNF
and if no @{const OR} occurs below an @{const AND}. Define a corresponding
test:
*)

fun is_dnf :: "pbexp \<Rightarrow> bool" where
(* your definition/proof here *)

text {*
An NNF can be converted into a DNF in a bottom-up manner.
The critical case is the conversion of @{term (sub) "AND b1 b2"}.
Having converted @{text b\<^sub>1} and @{text b\<^sub>2}, apply distributivity of @{const AND}
over @{const OR}. If we write @{const OR} as a multi-argument function,
we can express the distributivity step as follows:
@{text "dist_AND (OR a\<^sub>1 ... a\<^sub>n) (OR b\<^sub>1 ... b\<^sub>m)"}
= @{text "OR (AND a\<^sub>1 b\<^sub>1) (AND a\<^sub>1 b\<^sub>2) ... (AND a\<^sub>n b\<^sub>m)"}. Define
*}

fun dist_AND :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* and prove that it behaves as follows: *}

lemma pbval_dist: "pbval (dist_AND b1 b2) s = pbval (AND b1 b2) s"
(* your definition/proof here *)

lemma is_dnf_dist: "is_dnf b1 \<Longrightarrow> is_dnf b2 \<Longrightarrow> is_dnf (dist_AND b1 b2)"
(* your definition/proof here *)

text {* Use @{const dist_AND} to write a function that converts an NNF
  to a DNF in the above bottom-up manner.
*}

fun dnf_of_nnf :: "pbexp \<Rightarrow> pbexp" where
(* your definition/proof here *)

text {* Prove the correctness of your function: *}

lemma "pbval (dnf_of_nnf b) s = pbval b s"
(* your definition/proof here *)

lemma "is_nnf b \<Longrightarrow> is_dnf (dnf_of_nnf b)"
(* your definition/proof here *)

(*
exe:stack-underflow
A \concept{stack underflow} occurs when executing an @{text ADD}
instruction on a stack of size less than 2. In our semantics
a term @{term "exec1 ADD s stk"} where @{prop "length stk < 2"}
is simply some unspecified value, not an error or exception --- HOL does not have those concepts.
Modify theory @{short_theory "ASM"}
such that stack underflow is modelled by @{const None}
and normal execution by @{text Some}, i.e., the execution functions
have return type @{typ "stack option"}. Modify all theorems and proofs
accordingly.
Hint: you may find @{text"split: option.split"} useful in your proofs.
*)

(*
\endexercise

\exercise\label{exe:register-machine}
This exercise is about a register machine
and compiler for @{typ aexp}. The machine instructions are
*)
type_synonym reg = nat
datatype instr = LDI val reg | LD vname reg | ADD reg reg

(*
where type @{text reg} is a synonym for @{typ nat}.
Instruction @{term "LDI i r"} loads @{text i} into register @{text r},
@{term "LD x r"} loads the value of @{text x} into register @{text r},
and @{term[names_short] "ADD r\<^sub>1 r\<^sub>2"} adds   register @{text r\<^sub>2} to register @{text r\<^sub>1}.

Define the execution of an instruction given a state and a register state;
the result is the new register state: *)

type_synonym rstate = "reg \<Rightarrow> val"

fun exec_mr_1 :: "instr \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec_mr_1 (LDI i r) _ rs = rs(r:=i)"
| "exec_mr_1 (LD v r) s rs = rs(r:=s v)"
| "exec_mr_1 (ADD r1 r2) _ rs = rs(r1 := (rs r1) + (rs r2))"

(*
Define the execution @{const[source] exec} of a list of instructions as for the stack machine.
*)
(*The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into @{text r}. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "< r"} should be left alone.
Define the compiler and prove it correct:
*)

fun comp_mr :: "aexp \<Rightarrow> reg \<Rightarrow> instr list" where
  "comp_mr (aexp.N n) r = [LDI n r]"
| "comp_mr (aexp.V x) r = [LD x r]"
| "comp_mr (aexp.Plus e1 e2) r = (comp_mr e1 r) @ (comp_mr e2 (r+1)) @ [ADD r (r + 1)]"

fun exec_mr :: "instr list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec_mr [] _ rs = rs"
| "exec_mr (i#is) s rs = exec_mr is s (exec_mr_1 i s rs)"

lemma frame_exec1_LDI :"r' < r \<Longrightarrow> (exec_mr_1 (LDI n r) s rs) r' = rs r'"
  by simp

lemma frame_exec1_LD :"r' < r \<Longrightarrow> (exec_mr_1 (LD v r) s rs) r' = rs r'"
  by simp

lemma frame_exec1_ADD :"r' < r1 \<Longrightarrow> (exec_mr_1 (ADD r1 r2) s rs) r' = rs r'"
  by simp

lemma correct_aux : "exec_mr (is1 @ is2) s rs r =
        exec_mr is2 s (exec_mr is1 s rs) r"
  apply(induction is1 arbitrary:s rs r)
  apply(auto)
  done

lemma frame_exec : "r' < r \<Longrightarrow> exec_mr (comp_mr a r) s rs r' = rs r'"
  using correct_aux by (induction a arbitrary : r r' s rs) auto

lemma  "r' < r \<Longrightarrow> exec_mr (comp_mr a r) s rs r' = rs r'"
proof (induction a arbitrary:r r' s rs)
  case (N x)
  then show ?case by auto
next
  case (V x)
then show ?case by auto
next
  case ind : (Plus a1 a2)
  have " exec_mr (comp_mr a1 r) s rs r' = rs r'" using ind.IH ind.prems by auto
  also have " exec_mr (comp_mr a2 r) s rs r' = rs r'" using ind.IH ind.prems by auto
  finally show "exec_mr (comp_mr (aexp.Plus a1 a2) r) s rs r' = rs r'"
    using correct_aux ind.IH ind.prems by auto
qed

theorem correct : "exec_mr (comp_mr a r) s rs r = aval a s"
  using frame_exec correct_aux by (induction a arbitrary : r s rs) auto

theorem correct_isar : "exec_mr (comp_mr a r) s rs r = aval a s"
proof (induction a arbitrary : r s rs)
  fix x r s rs
  show "exec_mr (comp_mr (aexp.N x) r) s rs r = aval (aexp.N x) s" by simp
next
  fix x r s rs
  show "exec_mr (comp_mr (aexp.V x) r) s rs r = aval (aexp.V x) s" by simp
next
  fix a1 a2 r s rs

  let ?l1 = "comp_mr a1 r"
  let ?l2 = "comp_mr a2 (r+1)"
  let ?l3 = "[ADD r (r+1)]"
  let ?rs' = "exec_mr (comp_mr a1 r) s rs"
  let ?rs'' = "exec_mr (comp_mr a2 (r+1)) s ?rs' "

  assume ind : "\<And>r s rs. (exec_mr (comp_mr a1 r) s rs) r = aval a1 s"
               "\<And>r s rs. (exec_mr (comp_mr a2 r) s rs) r = aval a2 s"

  have "?rs' r = ?rs'' r" using frame_exec by simp
  have "?rs'' (r+1) = aval a2 s" using ind by simp

  have "exec_mr (comp_mr (aexp.Plus a1 a2) r) s rs r =
    exec_mr (?l1 @ ?l2 @ ?l3) s rs r"
    by simp
  also have "... = exec_mr (?l2 @ ?l3) s ?rs' r"
    using correct_aux by simp
  also have "... = exec_mr ?l3 s ?rs'' r"
    using correct_aux by simp
  also have "... = (?rs'' r) + (?rs'' (r+1))"
    by simp
  also have "... = (aval a1 s) +(?rs'' (r+1))"
    using \<open>?rs' r = ?rs'' r\<close> ind by simp
  also have "... = (aval a1 s) +(aval a2 s)"
    using ind by simp
  also have "... = aval (aexp.Plus a1 a2) s" by simp
  finally show "exec_mr (comp_mr (aexp.Plus a1 a2) r) s rs r = aval (aexp.Plus a1 a2) s" using ind by auto
qed

(*
This exercise is a variation of the previous one
with a different instruction set:
*)

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

(*
All instructions refer implicitly to register 0 as a source or target:
@{const LDI0} and @{const LD0} load a value into register 0, @{term "MV0 r"}
copies the value in register 0 into register @{text r}, and @{term "ADD0 r"}
adds the value in register @{text r} to the value in register 0;
@{term "MV0 0"} and @{term "ADD0 0"} are legal. Define the execution functions
*)

fun exec0_1 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec0_1 (LDI0 n) _ rs = rs (0 := n)"
| "exec0_1 (LD0 x) s rs = rs (0 := s x)"
| "exec0_1 (MV0 r) _ rs = rs (r := rs 0)"
| "exec0_1 (ADD0 r) _ rs = rs (0 := rs 0 + rs r)"

fun exec0 :: "instr0 list \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec0 [] _ rs = rs"
| "exec0 (i#is) s rs = exec0 is s (exec0_1 i s rs)"

text{*
and @{const exec0} for instruction lists.

The compiler takes an arithmetic expression @{text a} and a register @{text r}
and produces a list of instructions whose execution places the value of @{text a}
into register 0. The registers @{text "> r"} should be used in a stack-like fashion
for intermediate results, the ones @{text "\<le> r"} should be left alone
(with the exception of 0). Define the compiler and prove it correct:
*}

fun comp0 :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
  "comp0 (aexp.N n) _ = [LDI0 n]"
| "comp0 (aexp.V x) _ = [LD0 x]"
| "comp0 (aexp.Plus a1 a2) r = (comp0 a1 (r+1)) @ [MV0 r] @ (comp0 a2 (r+1)) @ [ADD0 r]"

(*datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg *)
(*datatype aexp = N int | V vname | Plus aexp aexp*)

lemma correct_exec0_aux : "exec0 (is1 @ is2) s rs r =
        exec0 is2 s (exec0 is1 s rs) r"
  apply(induction is1 arbitrary:s rs r)
  apply(auto)
  done
(*fun exec0_1 :: "instr0 \<Rightarrow> state \<Rightarrow> rstate \<Rightarrow> rstate" where
  "exec0_1 (LDI0 n) _ rs = rs (0 := n)"
| "exec0_1 (LD0 x) s rs = rs (0 := s x)"
| "exec0_1 (MV0 r) _ rs = rs (r := rs 0)"
| "exec0_1 (ADD0 r) _ rs = rs (0 := rs 0 + rs r)"*)

lemma frame_exec0_LDI : "r \<noteq> 0 \<Longrightarrow> (exec0_1 (LDI0 n) s rs) r = rs r"
  by simp

lemma frame_exec0_LD : "r \<noteq> 0 \<Longrightarrow> (exec0_1 (LD0 x) s rs) r = rs r"
  by simp

lemma frame_exec0_MV0 : "r' \<noteq> r \<Longrightarrow> (exec0_1 (MV0 r) s rs) r' = rs r'"
  by simp

lemma frame_exec0_ADD :"r' \<noteq> 0 \<Longrightarrow> (exec0_1 (ADD0 r) s rs) r' = rs r'"
  by simp

lemma frame_exec0 : "0 < r' \<Longrightarrow> r' \<le> r \<Longrightarrow> exec_0 (comp0 a (r+1)) s rs r' = rs r'"
  apply(induction a arbitrary : r' r s rs)
  apply(auto)

proof (induction a arbitrary : r s rs)
  fix x r s rs
  show "exec_0 (comp0 (aexp.N x) (r + 1)) s rs r = rs r" by auto

theorem correct_exec0 : "exec0 (comp0 a r) s rs 0 = aval a s"
proof (induction a arbitrary : r s rs)
  case (N n)
  show ?case by simp
next
  case (V x)
  show ?case by simp
next
  fix a1 a2 r s rs
  assume ind : "\<And>r s rs. exec0 (comp0 a1 r) s rs 0 = aval a1 s"
         "\<And>r s rs. exec0 (comp0 a2 r) s rs 0 = aval a2 s"
  let ?rs' = "exec0 (comp0 a1 (r+1)) s rs"
  let ?rs'' = "?rs' (r := ?rs' 0)"
  let ?rs''' = "exec0 (comp0 a2 (r+1)) s ?rs''"
  have "exec0 (comp0 (aexp.Plus a1 a2) r) s rs 0 =
        exec0 ((comp0 a1 (r+1)) @ [MV0 r] @ (comp0 a2 (r+1)) @ [ADD0 r]) s rs 0"
    by simp
  also have "... = exec0 ([MV0 r] @ (comp0 a2 (r+1)) @ [ADD0 r]) s ?rs' 0"
    using correct_exec0_aux by simp
  also have "... = exec0 ((comp0 a2 (r+1)) @ [ADD0 r]) s ?rs'' 0"
    using correct_exec0_aux by simp
  also have "... = exec0 ([ADD0 r]) s ?rs''' 0"
    using correct_exec0_aux by simp
  also have "... = (?rs''' (0 := ?rs''' r + ?rs''' 0)) 0"
    using correct_exec0_aux by simp
  also have "... = ?rs''' r + ?rs''' 0" by simp
  also have "... = ?rs''' r +  aval a2 s" using ind by simp
  also have "?rs''' =
    exec0 (comp0 a2 (r+1)) s ((exec0 (comp0 a1 (r+1)) s rs) (r := (exec0 (comp0 a1 (r+1)) s rs) 0))"
    by simp
  also have "... =
    exec0 (comp0 a2 (r+1)) s ((exec0 (comp0 a1 (r+1)) s rs) (r := aval a1 s rs))"
    using ind by simp
  finally show "exec0 (comp0 (aexp.Plus a1 a2) r) s rs 0 = aval (aexp.Plus a1 a2) s"
      using ind by auto
end


(*  Title:      HOL/Nonstandard_Analysis/NSComplex.thy
    Author:     Jacques D. Fleuriot, University of Edinburgh
    Author:     Lawrence C Paulson
*)

section \<open>Nonstandard Complex Numbers\<close>

theory NSComplex
  imports NSA
begin

type_synonym hcomplex = "complex star"

abbreviation hcomplex_of_complex :: "complex \<Rightarrow> complex star"
  where "hcomplex_of_complex \<equiv> star_of"

abbreviation hcmod :: "complex star \<Rightarrow> real star"
  where "hcmod \<equiv> hnorm"

subsubsection \<open>Real and Imaginary parts\<close>

definition hRe :: "hcomplex \<Rightarrow> hypreal"
  where "hRe = *f* Re"

definition hIm :: "hcomplex \<Rightarrow> hypreal"
  where "hIm = *f* Im"

subsubsection \<open>Imaginary unit\<close>

definition iii :: hcomplex
  where "iii = star_of \<i>"

subsubsection \<open>Complex conjugate\<close>

definition hcnj :: "hcomplex \<Rightarrow> hcomplex"
  where "hcnj = *f* cnj"

subsubsection \<open>Argand\<close>

definition hsgn :: "hcomplex \<Rightarrow> hcomplex"
  where "hsgn = *f* sgn"

definition harg :: "hcomplex \<Rightarrow> hypreal"
  where "harg = *f* Arg"

definition  \<comment> \<open>abbreviation for \<open>cos a + i sin a\<close>\<close>
  hcis :: "hypreal \<Rightarrow> hcomplex"
  where "hcis = *f* cis"

subsubsection \<open>Injection from hyperreals\<close>

abbreviation hcomplex_of_hypreal :: "hypreal \<Rightarrow> hcomplex"
  where "hcomplex_of_hypreal \<equiv> of_hypreal"

definition  \<comment> \<open>abbreviation for \<open>r * (cos a + i sin a)\<close>\<close>
  hrcis :: "hypreal \<Rightarrow> hypreal \<Rightarrow> hcomplex"
  where "hrcis = *f2* rcis"

subsubsection \<open>\<open>e ^ (x + iy)\<close>\<close>

definition hExp :: "hcomplex \<Rightarrow> hcomplex"
  where "hExp = *f* exp"

definition HComplex :: "hypreal \<Rightarrow> hypreal \<Rightarrow> hcomplex"
  where "HComplex = *f2* Complex"

lemmas hcomplex_defs [transfer_unfold] =
  hRe_def hIm_def iii_def hcnj_def hsgn_def harg_def hcis_def
  hrcis_def hExp_def HComplex_def

lemma Standard_hRe [simp]: "x \<in> Standard \<Longrightarrow> hRe x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hIm [simp]: "x \<in> Standard \<Longrightarrow> hIm x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_iii [simp]: "iii \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hcnj [simp]: "x \<in> Standard \<Longrightarrow> hcnj x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hsgn [simp]: "x \<in> Standard \<Longrightarrow> hsgn x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_harg [simp]: "x \<in> Standard \<Longrightarrow> harg x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hcis [simp]: "r \<in> Standard \<Longrightarrow> hcis r \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hExp [simp]: "x \<in> Standard \<Longrightarrow> hExp x \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_hrcis [simp]: "r \<in> Standard \<Longrightarrow> s \<in> Standard \<Longrightarrow> hrcis r s \<in> Standard"
  by (simp add: hcomplex_defs)

lemma Standard_HComplex [simp]: "r \<in> Standard \<Longrightarrow> s \<in> Standard \<Longrightarrow> HComplex r s \<in> Standard"
  by (simp add: hcomplex_defs)

lemma hcmod_def: "hcmod = *f* cmod"
  by (rule hnorm_def)

subsection \<open>Properties of Nonstandard Real and Imaginary Parts\<close>

lemma hcomplex_hRe_hIm_cancel_iff: "\<And>w z. w = z \<longleftrightarrow> hRe w = hRe z \<and> hIm w = hIm z"
  by transfer (rule complex_eq_iff)

lemma hcomplex_equality [intro?]: "\<And>z w. hRe z = hRe w \<Longrightarrow> hIm z = hIm w \<Longrightarrow> z = w"
  by transfer (rule complex_eqI)

lemma hcomplex_hRe_zero [simp]: "hRe 0 = 0"
  by transfer simp

lemma hcomplex_hIm_zero [simp]: "hIm 0 = 0"
  by transfer simp

lemma hcomplex_hRe_one [simp]: "hRe 1 = 1"
  by transfer simp

lemma hcomplex_hIm_one [simp]: "hIm 1 = 0"
  by transfer simp

subsection \<open>Addition for Nonstandard Complex Numbers\<close>

lemma hRe_add: "\<And>x y. hRe (x + y) = hRe x + hRe y"
  by transfer simp

lemma hIm_add: "\<And>x y. hIm (x + y) = hIm x + hIm y"
  by transfer simp

subsection \<open>More Minus Laws\<close>

lemma hRe_minus: "\<And>z. hRe (- z) = - hRe z"
  by transfer (rule uminus_complex.sel)

lemma hIm_minus: "\<And>z. hIm (- z) = - hIm z"
  by transfer (rule uminus_complex.sel)

lemma hcomplex_add_minus_eq_minus: "x + y = 0 \<Longrightarrow> x = - y"
  for x y :: hcomplex
  apply (drule minus_unique)
  apply (simp add: minus_equation_iff [of x y])
  done

lemma hcomplex_i_mult_eq [simp]: "iii * iii = - 1"
  by transfer (rule i_squared)

lemma hcomplex_i_mult_left [simp]: "\<And>z. iii * (iii * z) = - z"
  by transfer (rule complex_i_mult_minus)

lemma hcomplex_i_not_zero [simp]: "iii \<noteq> 0"
  by transfer (rule complex_i_not_zero)

subsection \<open>More Multiplication Laws\<close>

lemma hcomplex_mult_minus_one: "- 1 * z = - z"
  for z :: hcomplex
  by simp

lemma hcomplex_mult_minus_one_right: "z * - 1 = - z"
  for z :: hcomplex
  by simp

lemma hcomplex_mult_left_cancel: "c \<noteq> 0 \<Longrightarrow> c * a = c * b \<longleftrightarrow> a = b"
  for a b c :: hcomplex
  by simp

lemma hcomplex_mult_right_cancel: "c \<noteq> 0 \<Longrightarrow> a * c = b * c \<longleftrightarrow> a = b"
  for a b c :: hcomplex
  by simp

subsection \<open>Subtraction and Division\<close>

(* TODO: delete *)
lemma hcomplex_diff_eq_eq [simp]: "x - y = z \<longleftrightarrow> x = z + y"
  for x y z :: hcomplex
  by (rule diff_eq_eq)

subsection \<open>Embedding Properties for \<^term>\<open>hcomplex_of_hypreal\<close> Map\<close>

lemma hRe_hcomplex_of_hypreal [simp]: "\<And>z. hRe (hcomplex_of_hypreal z) = z"
  by transfer (rule Re_complex_of_real)

lemma hIm_hcomplex_of_hypreal [simp]: "\<And>z. hIm (hcomplex_of_hypreal z) = 0"
  by transfer (rule Im_complex_of_real)

lemma hcomplex_of_epsilon_not_zero [simp]: "hcomplex_of_hypreal \<epsilon> \<noteq> 0"
  by (simp add: epsilon_not_zero)

subsection \<open>\<open>HComplex\<close> theorems\<close>

lemma hRe_HComplex [simp]: "\<And>x y. hRe (HComplex x y) = x"
  by transfer simp

lemma hIm_HComplex [simp]: "\<And>x y. hIm (HComplex x y) = y"
  by transfer simp

lemma hcomplex_surj [simp]: "\<And>z. HComplex (hRe z) (hIm z) = z"
  by transfer (rule complex_surj)

lemma hcomplex_induct [case_names rect(*, induct type: hcomplex*)]:
  "(\<And>x y. P (HComplex x y)) \<Longrightarrow> P z"
  by (rule hcomplex_surj [THEN subst]) blast

subsection \<open>Modulus (Absolute Value) of Nonstandard Complex Number\<close>

lemma hcomplex_of_hypreal_abs:
  "hcomplex_of_hypreal \<bar>x\<bar> = hcomplex_of_hypreal (hcmod (hcomplex_of_hypreal x))"
  by simp

lemma HComplex_inject [simp]: "\<And>x y x' y'. HComplex x y = HComplex x' y' \<longleftrightarrow> x = x' \<and> y = y'"
  by transfer (rule complex.inject)

lemma HComplex_add [simp]:
  "\<And>x1 y1 x2 y2. HComplex x1 y1 + HComplex x2 y2 = HComplex (x1 + x2) (y1 + y2)"
  by transfer (rule complex_add)

lemma HComplex_minus [simp]: "\<And>x y. - HComplex x y = HComplex (- x) (- y)"
  by transfer (rule complex_minus)

lemma HComplex_diff [simp]:
  "\<And>x1 y1 x2 y2. HComplex x1 y1 - HComplex x2 y2 = HComplex (x1 - x2) (y1 - y2)"
  by transfer (rule complex_diff)

lemma HComplex_mult [simp]:
  "\<And>x1 y1 x2 y2. HComplex x1 y1 * HComplex x2 y2 = HComplex (x1*x2 - y1*y2) (x1*y2 + y1*x2)"
  by transfer (rule complex_mult)

text \<open>\<open>HComplex_inverse\<close> is proved below.\<close>

lemma hcomplex_of_hypreal_eq: "\<And>r. hcomplex_of_hypreal r = HComplex r 0"
  by transfer (rule complex_of_real_def)

lemma HComplex_add_hcomplex_of_hypreal [simp]:
  "\<And>x y r. HComplex x y + hcomplex_of_hypreal r = HComplex (x + r) y"
  by transfer (rule Complex_add_complex_of_real)

lemma hcomplex_of_hypreal_add_HComplex [simp]:
  "\<And>r x y. hcomplex_of_hypreal r + HComplex x y = HComplex (r + x) y"
  by transfer (rule complex_of_real_add_Complex)

lemma HComplex_mult_hcomplex_of_hypreal:
  "\<And>x y r. HComplex x y * hcomplex_of_hypreal r = HComplex (x * r) (y * r)"
  by transfer (rule Complex_mult_complex_of_real)

lemma hcomplex_of_hypreal_mult_HComplex:
  "\<And>r x y. hcomplex_of_hypreal r * HComplex x y = HComplex (r * x) (r * y)"
  by transfer (rule complex_of_real_mult_Complex)

lemma i_hcomplex_of_hypreal [simp]: "\<And>r. iii * hcomplex_of_hypreal r = HComplex 0 r"
  by transfer (rule i_complex_of_real)

lemma hcomplex_of_hypreal_i [simp]: "\<And>r. hcomplex_of_hypreal r * iii = HComplex 0 r"
  by transfer (rule complex_of_real_i)

subsection \<open>Conjugation\<close>

lemma hcomplex_hcnj_cancel_iff [iff]: "\<And>x y. hcnj x = hcnj y \<longleftrightarrow> x = y"
  by transfer (rule complex_cnj_cancel_iff)

lemma hcomplex_hcnj_hcnj [simp]: "\<And>z. hcnj (hcnj z) = z"
  by transfer (rule complex_cnj_cnj)

lemma hcomplex_hcnj_hcomplex_of_hypreal [simp]:
  "\<And>x. hcnj (hcomplex_of_hypreal x) = hcomplex_of_hypreal x"
  by transfer (rule complex_cnj_complex_of_real)

lemma hcomplex_hmod_hcnj [simp]: "\<And>z. hcmod (hcnj z) = hcmod z"
  by transfer (rule complex_mod_cnj)

lemma hcomplex_hcnj_minus: "\<And>z. hcnj (- z) = - hcnj z"
  by transfer (rule complex_cnj_minus)

lemma hcomplex_hcnj_inverse: "\<And>z. hcnj (inverse z) = inverse (hcnj z)"
  by transfer (rule complex_cnj_inverse)

lemma hcomplex_hcnj_add: "\<And>w z. hcnj (w + z) = hcnj w + hcnj z"
  by transfer (rule complex_cnj_add)

lemma hcomplex_hcnj_diff: "\<And>w z. hcnj (w - z) = hcnj w - hcnj z"
  by transfer (rule complex_cnj_diff)

lemma hcomplex_hcnj_mult: "\<And>w z. hcnj (w * z) = hcnj w * hcnj z"
  by transfer (rule complex_cnj_mult)

lemma hcomplex_hcnj_divide: "\<And>w z. hcnj (w / z) = hcnj w / hcnj z"
  by transfer (rule complex_cnj_divide)

lemma hcnj_one [simp]: "hcnj 1 = 1"
  by transfer (rule complex_cnj_one)

lemma hcomplex_hcnj_zero [simp]: "hcnj 0 = 0"
  by transfer (rule complex_cnj_zero)

lemma hcomplex_hcnj_zero_iff [iff]: "\<And>z. hcnj z = 0 \<longleftrightarrow> z = 0"
  by transfer (rule complex_cnj_zero_iff)

lemma hcomplex_mult_hcnj: "\<And>z. z * hcnj z = hcomplex_of_hypreal ((hRe z)\<^sup>2 + (hIm z)\<^sup>2)"
  by transfer (rule complex_mult_cnj)

subsection \<open>More Theorems about the Function \<^term>\<open>hcmod\<close>\<close>

lemma hcmod_hcomplex_of_hypreal_of_nat [simp]:
  "hcmod (hcomplex_of_hypreal (hypreal_of_nat n)) = hypreal_of_nat n"
  by simp

lemma hcmod_hcomplex_of_hypreal_of_hypnat [simp]:
  "hcmod (hcomplex_of_hypreal(hypreal_of_hypnat n)) = hypreal_of_hypnat n"
  by simp

lemma hcmod_mult_hcnj: "\<And>z. hcmod (z * hcnj z) = (hcmod z)\<^sup>2"
  by transfer (rule complex_mod_mult_cnj)

lemma hcmod_triangle_ineq2 [simp]: "\<And>a b. hcmod (b + a) - hcmod b \<le> hcmod a"
  by transfer (rule complex_mod_triangle_ineq2)

lemma hcmod_diff_ineq [simp]: "\<And>a b. hcmod a - hcmod b \<le> hcmod (a + b)"
  by transfer (rule norm_diff_ineq)

subsection \<open>Exponentiation\<close>

lemma hcomplexpow_0 [simp]: "z ^ 0 = 1"
  for z :: hcomplex
  by (rule power_0)

lemma hcomplexpow_Suc [simp]: "z ^ (Suc n) = z * (z ^ n)"
  for z :: hcomplex
  by (rule power_Suc)

lemma hcomplexpow_i_squared [simp]: "iii\<^sup>2 = -1"
  by transfer (rule power2_i)

lemma hcomplex_of_hypreal_pow: "\<And>x. hcomplex_of_hypreal (x ^ n) = hcomplex_of_hypreal x ^ n"
  by transfer (rule of_real_power)

lemma hcomplex_hcnj_pow: "\<And>z. hcnj (z ^ n) = hcnj z ^ n"
  by transfer (rule complex_cnj_power)

lemma hcmod_hcomplexpow: "\<And>x. hcmod (x ^ n) = hcmod x ^ n"
  by transfer (rule norm_power)

lemma hcpow_minus:
  "\<And>x n. (- x :: hcomplex) pow n = (if ( *p* even) n then (x pow n) else - (x pow n))"
  by transfer simp

lemma hcpow_mult: "(r * s) pow n = (r pow n) * (s pow n)"
  for r s :: hcomplex
  by (fact hyperpow_mult)

lemma hcpow_zero2 [simp]: "\<And>n. 0 pow (hSuc n) = (0::'a::semiring_1 star)"
  by transfer (rule power_0_Suc)

lemma hcpow_not_zero [simp,intro]: "\<And>r n. r \<noteq> 0 \<Longrightarrow> r pow n \<noteq> (0::hcomplex)"
  by (fact hyperpow_not_zero)

lemma hcpow_zero_zero: "r pow n = 0 \<Longrightarrow> r = 0"
  for r :: hcomplex
  by (blast intro: ccontr dest: hcpow_not_zero)

subsection \<open>The Function \<^term>\<open>hsgn\<close>\<close>

lemma hsgn_zero [simp]: "hsgn 0 = 0"
  by transfer (rule sgn_zero)

lemma hsgn_one [simp]: "hsgn 1 = 1"
  by transfer (rule sgn_one)

lemma hsgn_minus: "\<And>z. hsgn (- z) = - hsgn z"
  by transfer (rule sgn_minus)

lemma hsgn_eq: "\<And>z. hsgn z = z / hcomplex_of_hypreal (hcmod z)"
  by transfer (rule sgn_eq)

lemma hcmod_i: "\<And>x y. hcmod (HComplex x y) = ( *f* sqrt) (x\<^sup>2 + y\<^sup>2)"
  by transfer (rule complex_norm)

lemma hcomplex_eq_cancel_iff1 [simp]:
  "hcomplex_of_hypreal xa = HComplex x y \<longleftrightarrow> xa = x \<and> y = 0"
  by (simp add: hcomplex_of_hypreal_eq)

lemma hcomplex_eq_cancel_iff2 [simp]:
  "HComplex x y = hcomplex_of_hypreal xa \<longleftrightarrow> x = xa \<and> y = 0"
  by (simp add: hcomplex_of_hypreal_eq)

lemma HComplex_eq_0 [simp]: "\<And>x y. HComplex x y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by transfer (rule Complex_eq_0)

lemma HComplex_eq_1 [simp]: "\<And>x y. HComplex x y = 1 \<longleftrightarrow> x = 1 \<and> y = 0"
  by transfer (rule Complex_eq_1)

lemma i_eq_HComplex_0_1: "iii = HComplex 0 1"
  by transfer (simp add: complex_eq_iff)

lemma HComplex_eq_i [simp]: "\<And>x y. HComplex x y = iii \<longleftrightarrow> x = 0 \<and> y = 1"
  by transfer (rule Complex_eq_i)

lemma hRe_hsgn [simp]: "\<And>z. hRe (hsgn z) = hRe z / hcmod z"
  by transfer (rule Re_sgn)

lemma hIm_hsgn [simp]: "\<And>z. hIm (hsgn z) = hIm z / hcmod z"
  by transfer (rule Im_sgn)

lemma HComplex_inverse: "\<And>x y. inverse (HComplex x y) = HComplex (x / (x\<^sup>2 + y\<^sup>2)) (- y / (x\<^sup>2 + y\<^sup>2))"
  by transfer (rule complex_inverse)

lemma hRe_mult_i_eq[simp]: "\<And>y. hRe (iii * hcomplex_of_hypreal y) = 0"
  by transfer simp

lemma hIm_mult_i_eq [simp]: "\<And>y. hIm (iii * hcomplex_of_hypreal y) = y"
  by transfer simp

lemma hcmod_mult_i [simp]: "\<And>y. hcmod (iii * hcomplex_of_hypreal y) = \<bar>y\<bar>"
  by transfer (simp add: norm_complex_def)

lemma hcmod_mult_i2 [simp]: "\<And>y. hcmod (hcomplex_of_hypreal y * iii) = \<bar>y\<bar>"
  by transfer (simp add: norm_complex_def)

subsubsection \<open>\<open>harg\<close>\<close>

lemma cos_harg_i_mult_zero [simp]: "\<And>y. y \<noteq> 0 \<Longrightarrow> ( *f* cos) (harg (HComplex 0 y)) = 0"
  by transfer (simp add: Complex_eq)

subsection \<open>Polar Form for Nonstandard Complex Numbers\<close>

lemma complex_split_polar2: "\<forall>n. \<exists>r a. (z n) = complex_of_real r * Complex (cos a) (sin a)"
  unfolding Complex_eq by (auto intro: complex_split_polar)

lemma hcomplex_split_polar:
  "\<And>z. \<exists>r a. z = hcomplex_of_hypreal r * (HComplex (( *f* cos) a) (( *f* sin) a))"
  by transfer (simp add: Complex_eq complex_split_polar)

lemma hcis_eq:
  "\<And>a. hcis a = hcomplex_of_hypreal (( *f* cos) a) + iii * hcomplex_of_hypreal (( *f* sin) a)"
  by transfer (simp add: complex_eq_iff)

lemma hrcis_Ex: "\<And>z. \<exists>r a. z = hrcis r a"
  by transfer (rule rcis_Ex)

lemma hRe_hcomplex_polar [simp]:
  "\<And>r a. hRe (hcomplex_of_hypreal r * HComplex (( *f* cos) a) (( *f* sin) a)) = r * ( *f* cos) a"
  by transfer simp

lemma hRe_hrcis [simp]: "\<And>r a. hRe (hrcis r a) = r * ( *f* cos) a"
  by transfer (rule Re_rcis)

lemma hIm_hcomplex_polar [simp]:
  "\<And>r a. hIm (hcomplex_of_hypreal r * HComplex (( *f* cos) a) (( *f* sin) a)) = r * ( *f* sin) a"
  by transfer simp

lemma hIm_hrcis [simp]: "\<And>r a. hIm (hrcis r a) = r * ( *f* sin) a"
  by transfer (rule Im_rcis)

lemma hcmod_unit_one [simp]: "\<And>a. hcmod (HComplex (( *f* cos) a) (( *f* sin) a)) = 1"
  by transfer (simp add: cmod_unit_one)

lemma hcmod_complex_polar [simp]:
  "\<And>r a. hcmod (hcomplex_of_hypreal r * HComplex (( *f* cos) a) (( *f* sin) a)) = \<bar>r\<bar>"
  by transfer (simp add: Complex_eq cmod_complex_polar)

lemma hcmod_hrcis [simp]: "\<And>r a. hcmod(hrcis r a) = \<bar>r\<bar>"
  by transfer (rule complex_mod_rcis)

text \<open>\<open>(r1 * hrcis a) * (r2 * hrcis b) = r1 * r2 * hrcis (a + b)\<close>\<close>

lemma hcis_hrcis_eq: "\<And>a. hcis a = hrcis 1 a"
  by transfer (rule cis_rcis_eq)
declare hcis_hrcis_eq [symmetric, simp]

lemma hrcis_mult: "\<And>a b r1 r2. hrcis r1 a * hrcis r2 b = hrcis (r1 * r2) (a + b)"
  by transfer (rule rcis_mult)

lemma hcis_mult: "\<And>a b. hcis a * hcis b = hcis (a + b)"
  by transfer (rule cis_mult)

lemma hcis_zero [simp]: "hcis 0 = 1"
  by transfer (rule cis_zero)

lemma hrcis_zero_mod [simp]: "\<And>a. hrcis 0 a = 0"
  by transfer (rule rcis_zero_mod)

lemma hrcis_zero_arg [simp]: "\<And>r. hrcis r 0 = hcomplex_of_hypreal r"
  by transfer (rule rcis_zero_arg)

lemma hcomplex_i_mult_minus [simp]: "\<And>x. iii * (iii * x) = - x"
  by transfer (rule complex_i_mult_minus)

lemma hcomplex_i_mult_minus2 [simp]: "iii * iii * x = - x"
  by simp

lemma hcis_hypreal_of_nat_Suc_mult:
  "\<And>a. hcis (hypreal_of_nat (Suc n) * a) = hcis a * hcis (hypreal_of_nat n * a)"
  by transfer (simp add: distrib_right cis_mult)

lemma NSDeMoivre: "\<And>a. (hcis a) ^ n = hcis (hypreal_of_nat n * a)"
  by transfer (rule DeMoivre)

lemma hcis_hypreal_of_hypnat_Suc_mult:
  "\<And>a n. hcis (hypreal_of_hypnat (n + 1) * a) = hcis a * hcis (hypreal_of_hypnat n * a)"
  by transfer (simp add: distrib_right cis_mult)

lemma NSDeMoivre_ext: "\<And>a n. (hcis a) pow n = hcis (hypreal_of_hypnat n * a)"
  by transfer (rule DeMoivre)

lemma NSDeMoivre2: "\<And>a r. (hrcis r a) ^ n = hrcis (r ^ n) (hypreal_of_nat n * a)"
  by transfer (rule DeMoivre2)

lemma DeMoivre2_ext: "\<And>a r n. (hrcis r a) pow n = hrcis (r pow n) (hypreal_of_hypnat n * a)"
  by transfer (rule DeMoivre2)

lemma hcis_inverse [simp]: "\<And>a. inverse (hcis a) = hcis (- a)"
  by transfer (rule cis_inverse)

lemma hrcis_inverse: "\<And>a r. inverse (hrcis r a) = hrcis (inverse r) (- a)"
  by transfer (simp add: rcis_inverse inverse_eq_divide [symmetric])

lemma hRe_hcis [simp]: "\<And>a. hRe (hcis a) = ( *f* cos) a"
  by transfer simp

lemma hIm_hcis [simp]: "\<And>a. hIm (hcis a) = ( *f* sin) a"
  by transfer simp

lemma cos_n_hRe_hcis_pow_n: "( *f* cos) (hypreal_of_nat n * a) = hRe (hcis a ^ n)"
  by (simp add: NSDeMoivre)

lemma sin_n_hIm_hcis_pow_n: "( *f* sin) (hypreal_of_nat n * a) = hIm (hcis a ^ n)"
  by (simp add: NSDeMoivre)

lemma cos_n_hRe_hcis_hcpow_n: "( *f* cos) (hypreal_of_hypnat n * a) = hRe (hcis a pow n)"
  by (simp add: NSDeMoivre_ext)

lemma sin_n_hIm_hcis_hcpow_n: "( *f* sin) (hypreal_of_hypnat n * a) = hIm (hcis a pow n)"
  by (simp add: NSDeMoivre_ext)

lemma hExp_add: "\<And>a b. hExp (a + b) = hExp a * hExp b"
  by transfer (rule exp_add)

subsection \<open>\<^term>\<open>hcomplex_of_complex\<close>: the Injection from type \<^typ>\<open>complex\<close> to to \<^typ>\<open>hcomplex\<close>\<close>

lemma hcomplex_of_complex_i: "iii = hcomplex_of_complex \<i>"
  by (rule iii_def)

lemma hRe_hcomplex_of_complex: "hRe (hcomplex_of_complex z) = hypreal_of_real (Re z)"
  by transfer (rule refl)

lemma hIm_hcomplex_of_complex: "hIm (hcomplex_of_complex z) = hypreal_of_real (Im z)"
  by transfer (rule refl)

lemma hcmod_hcomplex_of_complex: "hcmod (hcomplex_of_complex x) = hypreal_of_real (cmod x)"
  by transfer (rule refl)

subsection \<open>Numerals and Arithmetic\<close>

lemma hcomplex_of_hypreal_eq_hcomplex_of_complex:
  "hcomplex_of_hypreal (hypreal_of_real x) = hcomplex_of_complex (complex_of_real x)"
  by transfer (rule refl)

lemma hcomplex_hypreal_numeral:
  "hcomplex_of_complex (numeral w) = hcomplex_of_hypreal(numeral w)"
  by transfer (rule of_real_numeral [symmetric])

lemma hcomplex_hypreal_neg_numeral:
  "hcomplex_of_complex (- numeral w) = hcomplex_of_hypreal(- numeral w)"
  by transfer (rule of_real_neg_numeral [symmetric])

lemma hcomplex_numeral_hcnj [simp]: "hcnj (numeral v :: hcomplex) = numeral v"
  by transfer (rule complex_cnj_numeral)

lemma hcomplex_numeral_hcmod [simp]: "hcmod (numeral v :: hcomplex) = (numeral v :: hypreal)"
  by transfer (rule norm_numeral)

lemma hcomplex_neg_numeral_hcmod [simp]: "hcmod (- numeral v :: hcomplex) = (numeral v :: hypreal)"
  by transfer (rule norm_neg_numeral)

lemma hcomplex_numeral_hRe [simp]: "hRe (numeral v :: hcomplex) = numeral v"
  by transfer (rule complex_Re_numeral)

lemma hcomplex_numeral_hIm [simp]: "hIm (numeral v :: hcomplex) = 0"
  by transfer (rule complex_Im_numeral)

end


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

text {* Define a universal and an existential quantifier on lists
using primitive recursion.  Expression @{term "alls P xs"} should
be true iff @{term "P x"} holds for every element @{term x} of
@{term xs}, and @{term "exs P xs"} should be true iff @{term "P x"}
holds for some element @{term x} of @{term xs}.
*}

primrec   alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  where "alls f [] = True"
  |"alls f (x#xs) = (f x \<and> alls f xs)"

primrec   exs  :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  where "exs f [] = False"
  |"exs f (x#xs) = (f x \<or> exs f xs)"

text {*
Prove or disprove (by counterexample) the following theorems.
You may have to prove some lemmas first.

Use the @{text "[simp]"}-attribute only if the equation is truly a
simplification and is necessary for some later proof.
*}

lemma "alls (\<lambda>x. P x \<and> Q x) xs = (alls P xs \<and> alls Q xs)"
  apply (induct xs)
   apply auto
  done

lemma alls_1[simp]: "alls P (x@xs) = (alls P x \<and> (alls P xs))"
  apply (induct x)
  apply auto
  done

lemma "alls P (rev xs) = alls P xs"
  apply (induct xs)
  apply (auto)
  oops

lemma "exs (\<lambda>x. P x \<and> Q x) xs = (exs P xs \<and> exs Q xs)"
  quickcheck oops

lemma "exs P (map f xs) = exs (P o f) xs"
  apply (induct xs)
   apply auto
  done

lemma exs_1 [simp]:"exs P (x @ y) = (exs P x \<or> exs P y)"
  apply (induct x)
   apply auto
  done

lemma "exs P (rev xs) = exs P xs"
  apply (induct xs)
   apply auto
  done

text {* Find a (non-trivial) term @{text Z} such that the following equation holds: *}

lemma "exs (\<lambda>x. P x \<or> Q x) xs =(exs (\<lambda>x. P x) xs  \<or> exs (\<lambda>x. Q x) xs )"
  apply (induct xs)
   apply auto
  done

text {* Express the existential via the universal quantifier --
@{text exs} should not occur on the right-hand side: *}

lemma "exs P xs = (\<not> alls (\<lambda>x. \<not> P x) xs)"
  apply(induct xs)
   apply auto
  done

text {*
Define a primitive-recursive function @{term "is_in x xs"} that
checks if @{term x} occurs in @{term xs}. Now express
@{text is_in} via @{term exs}:
*}
primrec is_in :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  where "is_in a [] = False"
  |"is_in a (x#xs) = (a=x \<or> is_in a xs)"

lemma "is_in a xs = exs (\<lambda> y. y=a) xs"
  apply(induct xs)
   apply auto
  done

text {* Define a primitive-recursive function @{term "nodups xs"}
that is true iff @{term xs} does not contain duplicates, and a
function @{term "deldups xs"} that removes all duplicates.  Note
that @{term "deldups[x,y,x]"} (where @{term x} and @{term y} are
distinct) can be either @{term "[x,y]"} or @{term "[y,x]"}.

Prove or disprove (by counterexample) the following theorems.
*}
primrec nodups::" 'a list \<Rightarrow> bool"
  where "nodups [] = True"
  |"nodups (x#xs) = (nodups xs \<and> (\<not> is_in x xs))"
primrec deldups::" 'a list \<Rightarrow> 'a list"
  where "deldups [] = []"
  |"deldups (x#xs) = (if (is_in x xs) then deldups xs else (x# (deldups xs)))"

lemma "length (deldups xs) <= length xs"
  apply (induct xs)
   apply auto
  done

lemma prop1[simp]:
  "(is_in a (deldups xs)) = is_in a xs"
  apply (induct xs)
   apply auto
  done

lemma "nodups (deldups xs)"
  apply(induct xs)
   apply auto
  done

lemma "deldups (rev xs) = rev (deldups xs)"
  quickcheck
  oops

(*<*) end (*>*)


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_07
  imports "../../Test_Base" (*"../../../src/Build_Database/Build_Database"*)
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (nil2) y = y"
| "qrev (cons2 z xs) y = qrev xs (cons2 z y)"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y xs) = S (length xs)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y = y"
| "t2 (S z) y = S (t2 z y)"

theorem property0 :
  "((length (qrev x y)) = (t2 (length x) (length y)))"
  apply(induct x arbitrary: y (*rule: TIP_prop_07.length.induct*))
   apply auto[1]
  apply(subst qrev.simps)
    (*Note that we insert only the conclusion.*)
  apply(subgoal_tac
      "length (qrev x (cons2 x1 y)) = S (length (qrev x y)) &&&
    S (length (qrev x y)) = t2 (length (cons2 x1 x)) (length y)")
   apply presburger
  apply(rule conjunctionI)
   apply(thin_tac "(\<And>y. TIP_prop_07.length (qrev x y) = t2 (TIP_prop_07.length x) (TIP_prop_07.length y))")
   apply(rule meta_allI)
   back
   back
   back
   back
   apply(rule meta_allI)
   back
   back
   back
   apply(induct_tac rule: TIP_prop_07.length.induct)(*Note that "induct" does not work here.*)
    apply fastforce+
  done

lemma aux:
  "t2 (TIP_prop_07.length x) (S (TIP_prop_07.length y)) = S (t2 (TIP_prop_07.length x) (TIP_prop_07.length y))"
  apply (induct arbitrary: y)
   apply auto done

theorem property:
  "((length (qrev x y)) = (t2 (length x) (length y)))"
  apply(induct x arbitrary: y)
   apply fastforce
  apply clarsimp
  apply(rule aux) done (*abductive reasoning: remove_assumption.*)

end