(*  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 {* Function Definitions for Dummies *}

text {*
  In most cases, defining a recursive function is just as simple as other definitions:
*}

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

text {*
  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}"}.
*}

text {*
  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.
*}

subsection {* Pattern matching *}

text {* \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:
*}

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 {*
  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:
*}

thm sep.simps

text {* @{thm [display] sep.simps[no_vars]} *}

text {*
  \noindent The equations from function definitions are automatically used in
  simplification:
*}

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

subsection {* Induction *}

text {*

  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}
*}

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

text {*
  We get three cases, like in the definition.

  @{subgoals [display]}
*}

apply auto
done
text {*

  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\%.
*}

section {* fun vs.\ function *}

text {*
  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.
 *}

section {* Termination *}

text {*\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.
*}

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

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 {*
  \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.
*}

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

text {*
  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"}:
*}

apply auto
done

text {*
  Let us complicate the function a little, by adding some more
  recursive calls:
*}

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 {*
  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.
*}

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

subsection {* How @{text "lexicographic_order"} works *}

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

text {*
  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}
*}
text {*
  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.
*}

subsection {* The @{text size_change} method *}

text {*
  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.
*}

section {* Mutual Recursion *}

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

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 {*
  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:
*}

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

text {*
  We could also have used @{text lexicographic_order}, which
  supports mutual recursive termination proofs to a certain extent.
*}

subsection {* Induction for mutual recursion *}

text {*

  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}:
*}

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

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

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

text {*
  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:
*}

apply simp_all

text {*
  @{subgoals[display,indent=0]}

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

*}

apply arith
apply arith
done

text {*
  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:
*}

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

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

  @{subgoals[display,indent=0]}
*}

oops

section {* Elimination *}

text {*
  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:
*}

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 {*
  @{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:
*}
thm list_to_option.elims
text {*
  @{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.:
*}

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 {*
  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:
*}

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

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

section {* General pattern matching *}
text{*\label{genpats} *}

subsection {* Avoiding automatic pattern splitting *}

text {*

  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.
*}

datatype P3 = T | F | X

text {* \noindent Then the conjunction of such values can be defined as follows: *}

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 {*
  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:
*}

thm And.simps

text {*
  @{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.}:
*}

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 {*
  \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:
*}

apply pat_completeness

text {*
  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"}.
*}

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

subsection {* Non-constructor patterns *}

text {*
  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:
*}

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

text {*
  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.
*}
apply atomize_elim
apply arith
apply auto
done
termination by lexicographic_order
text {*
  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:
*}

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 {*
  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.
*}

subsection {* Conditional equations *}

text {*
  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}:
*}

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 {*
  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.
*}

subsection {* Pattern matching on strings *}

text {*
  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:
*}

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

section {* Partiality *}

text {*
  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.
*}

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 {*
  \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?
*}

subsection {* Domain predicates *}

text {*
  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}:
*}

text {*
  \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"})
*}

text {*
  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}:
*}

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

text {* \noindent We apply induction as usual, but using the partial induction
  rule: *}

apply (induct f n rule: findzero.pinduct)

text {* \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.
 *}
apply (simp add: findzero.psimps)
done

text {*
  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.
*}

text_raw {*
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
*}
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 `f n \<noteq> 0` show ?thesis by simp
  next
    assume "x \<in> {Suc n ..< findzero f n}"
    with dom and `f n \<noteq> 0` have "x \<in> {Suc n ..< findzero f (Suc n)}" by (simp add: findzero.psimps)
    with IH and `f n \<noteq> 0`
    show ?thesis by simp
  qed
qed
text_raw {*
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{A proof about a partial function}\label{findzero_isar}
\end{figure}
*}

subsection {* Partial termination proofs *}

text {*
  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}:
*}

thm findzero.domintros

text {*
  @{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.

*}

text_raw {*
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
*}
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:`f x = 0`)

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

  from `x \<ge> n` 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 {*
\isamarkupfalse\isabellestyle{tt}
\end{minipage}\vspace{6pt}\hrule
\caption{Termination proof for @{text findzero}}\label{findzero_term}
\end{figure}
*}

text {*
  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:
*}

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 {*
  \noindent It is simple to combine the partial correctness result with the
  termination lemma:
*}

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

subsection {* Definition of the domain predicate *}

text {*
  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"}.
*}

section {* Nested recursion *}

text {*
  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:
*}

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

text {*
  If we attempt to prove termination using the identity measure on
  naturals, this fails:
*}

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

text {*
  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.
*}
(*<*)oops(*>*)
lemma nz_is_zero: "nz_dom n \<Longrightarrow> nz n = 0"
  by (induct rule:nz.pinduct) (auto simp: nz.psimps)

text {*
  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:
*}

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

text {*
  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.
*}

text_raw {*
\begin{figure}
\hrule\vspace{6pt}
\begin{minipage}{0.8\textwidth}
\isabellestyle{it}
\isastyle\isamarkuptrue
*}

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 `\<not> 100 < n` show "(f91 (n + 11), n) \<in> ?R" by simp
qed

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

section {* Higher-Order Recursion *}

text {*
  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:
*}

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

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

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

text {*
  Although the definition is accepted without problems, let us look at the termination proof:
*}

termination proof
  text {*

  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.
*}
(*<*)oops(*>*)

subsection {* Congruence Rules and Evaluation Order *}

text {*
  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.
*}

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

text {*
  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:
*}

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 {*
  \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.
*}

end


theory Identifier_List
  imports
    Main
    Ecore.Model_Namespace
    Namespace_List
begin

section "Identifier to list mapping for arbitrary types"

text "Maps an identifier of arbitrary type to a list of the same type. This mapping is lossless."

definition id_to_list :: "'t Id \<Rightarrow> 't list" where
  "id_to_list ident \<equiv> ns_to_list (Identifier ident)"

definition list_to_id :: "'t list \<Rightarrow> 't Id" where
  "list_to_id l = ns_to_id (list_to_ns l)"

subsection "Domain & Range"

definition list_identifier_domain :: "'t Id set" where
  [simp]: "list_identifier_domain \<equiv> identifier_domain"

inductive_set list_identifier_range :: "'t list set"
  where
    rule_identifier: "[n] \<in> list_identifier_range" |
    rule_nested: "l \<in> list_identifier_range \<Longrightarrow> l @ [n] \<in> list_identifier_range"

subsection "Inverse function"

lemma id_to_list_inverse: "list_to_id (id_to_list x) = x"
  using id_to_list_def list_to_id_def ns_to_id.simps(1) ns_to_list_inverse
  by metis

lemma list_to_id_inverse: "l \<noteq> [] \<Longrightarrow> id_to_list (list_to_id l) = l"
proof (induction l)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    unfolding list_to_id_def id_to_list_def
    using ns_to_id.elims list_to_ns_inverse ns_to_list.simps(1)
    by metis
qed

subsection "Range of mapping functions"

lemma id_to_list_range: "range id_to_list = list_identifier_range"
proof
  show "range id_to_list \<subseteq> list_identifier_range"
  proof
    fix x :: "'t list"
    assume "x \<in> range id_to_list"
    then show "x \<in> list_identifier_range"
      unfolding id_to_list_def
    proof (induction x)
      case Nil
      then show ?case
        using Namespace.distinct(1) ns_to_list.simps(1) ns_to_list_inverse rangeE
        by metis
    next
      case (Cons a x)
      then show ?case
        by (simp add: list_identifier_range_def list_identifier_rangep.rule_identifier list_identifier_rangep.rule_nested rev_nonempty_induct)
    qed
  qed
next
  show "list_identifier_range \<subseteq> range id_to_list"
    using Nil_is_append_conv list.distinct(1) list_identifier_range.cases list_to_id_inverse rangeI subset_iff
    by metis
qed

lemma list_to_id_range: "range list_to_id = list_identifier_domain"
proof
  show "range list_to_id \<subseteq> list_identifier_domain"
    by (simp add: identifier_domain_alt)
next
  show "list_identifier_domain \<subseteq> range list_to_id"
    using id_to_list_inverse subset_UNIV surj_def
    by metis
qed

subsection "Surjectivity"

lemma list_to_id_surj[simp]: "surj list_to_id"
proof
  show "range list_to_id \<subseteq> UNIV"
    by simp
next
  show "UNIV \<subseteq> range list_to_id"
  proof
    fix x :: "'t Id"
    have "x \<in> list_identifier_domain"
      using list_to_id_def list_to_id_range ns_to_id.simps(1) ns_to_list_inverse rangeI
      by metis
    then show "x \<in> range list_to_id"
      by (simp add: list_to_id_range)
  qed
qed

subsection "Injectivity"

lemma id_to_list_inj[simp]: "inj id_to_list"
proof
  fix x y :: "'t Id"
  assume mapping_eq: "id_to_list x = id_to_list y"
  then show "x = y"
    using id_to_list_inverse
    by metis
qed

lemma list_to_id_inj[simp]: "inj_on list_to_id list_identifier_range"
proof
  fix x y :: "'t list"
  assume x_def: "x \<in> list_identifier_range"
  assume y_def: "y \<in> list_identifier_range"
  assume mapping_eq: "list_to_id x = list_to_id y"
  then show "x = y"
    using x_def y_def id_to_list_inverse id_to_list_range rangeE
    by metis
qed

subsection "Bijectivity"

lemma id_to_list_bij[simp]: "bij_betw id_to_list UNIV list_identifier_range"
  unfolding bij_betw_def
proof
  show "inj id_to_list"
    by (fact id_to_list_inj)
  show "range id_to_list = list_identifier_range"
    by (fact id_to_list_range)
qed

lemma list_to_id_bij[simp]: "bij_betw list_to_id list_identifier_range UNIV"
  unfolding bij_betw_def
proof
  show "inj_on list_to_id list_identifier_range"
    by (fact list_to_id_inj)
  show "list_to_id ` list_identifier_range = UNIV"
    using UNIV_eq_I id_to_list_inverse id_to_list_range imageI rangeI
    by metis
qed

subsection "Subnamespaces"

definition id_list_in_ns_list :: "'t list \<Rightarrow> 't list \<Rightarrow> bool" where
  "id_list_in_ns_list \<equiv> ns_list_in_ns_list"

lemma id_to_list_in_ns_to_list: "\<And>x y. x \<in> identifier_domain \<Longrightarrow> id_in_ns x y \<longleftrightarrow> id_list_in_ns_list (id_to_list x) (ns_to_list y)"
proof-
  fix x :: "'t Id"
  fix y :: "'t Namespace"
  assume "x \<in> identifier_domain"
  show "id_in_ns x y \<longleftrightarrow> id_list_in_ns_list (id_to_list x) (ns_to_list y)"
    by (simp add: id_in_ns_def id_list_in_ns_list_def id_to_list_def ns_to_list_in_ns_to_list)
qed

lemma list_to_id_in_list_to_ns: "\<And>x y. x \<in> list_identifier_range \<Longrightarrow> id_in_ns (list_to_id x) (list_to_ns y) \<longleftrightarrow> id_list_in_ns_list x y"
  using id_to_list_in_ns_to_list id_to_list_inverse id_to_list_range identifier_domainI inj_on_eq_iff list_to_id_inj list_to_ns_inverse rangeI
  by metis

end


theory Exercises_Chapter_02
imports Main
begin

section "Exercise 2.1"

value "1 + (2::nat)"
value "1 + (2::int)"
value "1 - (2::nat)"
value "1 - (2::int)"

section "Exercise 2.2"

(* datatype nat = Zero | Suc nat *)

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "add 0 n = n"
| "add (Suc m) n = Suc (add m n)"

theorem add_assoc [simp]: "add (add xs ys) zs = add xs (add ys zs)"
  apply(induction xs)
  apply(auto)
  done

lemma add_zero [simp]: "add xs 0 = xs"
  apply(induction xs)
  apply(auto)
  done

lemma add_suc [simp]: "add x (Suc y) = Suc (add x y)"
  apply(induction x)
  apply(auto)
  done

theorem add_comm [simp]: "add xs ys = add ys xs"
  apply(induction xs)
  apply(auto)
  done

fun double :: "nat \<Rightarrow> nat" where
  "double 0 = 0"
| "double n = add n n"

theorem double_two_adds [simp]: "double m = add m m"
  apply(induction m)
  apply(auto)
  done

section "Exercise 2.3"

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x [] = 0"
| "count x (y # xs) = (if x = y then Suc(count x xs) else count x xs)"

theorem count_less_than_length [simp]: "(count x xs) \<le> (length xs)"
  apply(induction xs)
  apply(auto)
  done

value "count (1::int) [(1::int), (2::int), (3::int), (1::int)]"

section "Exercise 2.4"

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

fun reverse :: "'a list \<Rightarrow> 'a list" where
  "reverse [] = []"
| "reverse (x # xs) = snoc (reverse xs) x"

lemma reverse_snoc [simp]: "reverse (snoc xs x) = x # reverse xs"
  apply(induction xs)
  apply(auto)
  done

theorem reverse_cancels [simp]: "reverse(reverse(xs)) = xs"
  apply(induction xs)
  apply(auto)
  done

section "Exercise 2.5"

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

theorem sum_formula [simp]: "sum_upto n = n * (n + 1) div 2"
  apply(induction n)
  apply(auto)
  done

end


(*  Title:      HOL/Metis_Examples/Binary_Tree.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring binary trees.
*)

section {* Metis Example Featuring Binary Trees *}

theory Binary_Tree
imports Main
begin

declare [[metis_new_skolem]]

datatype 'a bt =
    Lf
  | Br 'a  "'a bt"  "'a bt"

primrec n_nodes :: "'a bt => nat" where
  "n_nodes Lf = 0"
| "n_nodes (Br a t1 t2) = Suc (n_nodes t1 + n_nodes t2)"

primrec n_leaves :: "'a bt => nat" where
  "n_leaves Lf = Suc 0"
| "n_leaves (Br a t1 t2) = n_leaves t1 + n_leaves t2"

primrec depth :: "'a bt => nat" where
  "depth Lf = 0"
| "depth (Br a t1 t2) = Suc (max (depth t1) (depth t2))"

primrec reflect :: "'a bt => 'a bt" where
  "reflect Lf = Lf"
| "reflect (Br a t1 t2) = Br a (reflect t2) (reflect t1)"

primrec bt_map :: "('a => 'b) => ('a bt => 'b bt)" where
  "bt_map f Lf = Lf"
| "bt_map f (Br a t1 t2) = Br (f a) (bt_map f t1) (bt_map f t2)"

primrec preorder :: "'a bt => 'a list" where
  "preorder Lf = []"
| "preorder (Br a t1 t2) = [a] @ (preorder t1) @ (preorder t2)"

primrec inorder :: "'a bt => 'a list" where
  "inorder Lf = []"
| "inorder (Br a t1 t2) = (inorder t1) @ [a] @ (inorder t2)"

primrec postorder :: "'a bt => 'a list" where
  "postorder Lf = []"
| "postorder (Br a t1 t2) = (postorder t1) @ (postorder t2) @ [a]"

primrec append :: "'a bt => 'a bt => 'a bt" where
  "append Lf t = t"
| "append (Br a t1 t2) t = Br a (append t1 t) (append t2 t)"

text {* \medskip BT simplification *}

lemma n_leaves_reflect: "n_leaves (reflect t) = n_leaves t"
proof (induct t)
  case Lf thus ?case
  proof -
    let "?p\<^sub>1 x\<^sub>1" = "x\<^sub>1 \<noteq> n_leaves (reflect (Lf::'a bt))"
    have "\<not> ?p\<^sub>1 (Suc 0)" by (metis reflect.simps(1) n_leaves.simps(1))
    hence "\<not> ?p\<^sub>1 (n_leaves (Lf::'a bt))" by (metis n_leaves.simps(1))
    thus "n_leaves (reflect (Lf::'a bt)) = n_leaves (Lf::'a bt)" by metis
  qed
next
  case (Br a t1 t2) thus ?case
    by (metis n_leaves.simps(2) add.commute reflect.simps(2))
qed

lemma n_nodes_reflect: "n_nodes (reflect t) = n_nodes t"
proof (induct t)
  case Lf thus ?case by (metis reflect.simps(1))
next
  case (Br a t1 t2) thus ?case
    by (metis add.commute n_nodes.simps(2) reflect.simps(2))
qed

lemma depth_reflect: "depth (reflect t) = depth t"
apply (induct t)
 apply (metis depth.simps(1) reflect.simps(1))
by (metis depth.simps(2) max.commute reflect.simps(2))

text {*
The famous relationship between the numbers of leaves and nodes.
*}

lemma n_leaves_nodes: "n_leaves t = Suc (n_nodes t)"
apply (induct t)
 apply (metis n_leaves.simps(1) n_nodes.simps(1))
by auto

lemma reflect_reflect_ident: "reflect (reflect t) = t"
apply (induct t)
 apply (metis reflect.simps(1))
proof -
  fix a :: 'a and t1 :: "'a bt" and t2 :: "'a bt"
  assume A1: "reflect (reflect t1) = t1"
  assume A2: "reflect (reflect t2) = t2"
  have "\<And>V U. reflect (Br U V (reflect t1)) = Br U t1 (reflect V)"
    using A1 by (metis reflect.simps(2))
  hence "\<And>V U. Br U t1 (reflect (reflect V)) = reflect (reflect (Br U t1 V))"
    by (metis reflect.simps(2))
  hence "\<And>U. reflect (reflect (Br U t1 t2)) = Br U t1 t2"
    using A2 by metis
  thus "reflect (reflect (Br a t1 t2)) = Br a t1 t2" by blast
qed

lemma bt_map_ident: "bt_map (%x. x) = (%y. y)"
apply (rule ext)
apply (induct_tac y)
 apply (metis bt_map.simps(1))
by (metis bt_map.simps(2))

lemma bt_map_append: "bt_map f (append t u) = append (bt_map f t) (bt_map f u)"
apply (induct t)
 apply (metis append.simps(1) bt_map.simps(1))
by (metis append.simps(2) bt_map.simps(2))

lemma bt_map_compose: "bt_map (f o g) t = bt_map f (bt_map g t)"
apply (induct t)
 apply (metis bt_map.simps(1))
by (metis bt_map.simps(2) o_eq_dest_lhs)

lemma bt_map_reflect: "bt_map f (reflect t) = reflect (bt_map f t)"
apply (induct t)
 apply (metis bt_map.simps(1) reflect.simps(1))
by (metis bt_map.simps(2) reflect.simps(2))

lemma preorder_bt_map: "preorder (bt_map f t) = map f (preorder t)"
apply (induct t)
 apply (metis bt_map.simps(1) list.map(1) preorder.simps(1))
by simp

lemma inorder_bt_map: "inorder (bt_map f t) = map f (inorder t)"
proof (induct t)
  case Lf thus ?case
  proof -
    have "map f [] = []" by (metis list.map(1))
    hence "map f [] = inorder Lf" by (metis inorder.simps(1))
    hence "inorder (bt_map f Lf) = map f []" by (metis bt_map.simps(1))
    thus "inorder (bt_map f Lf) = map f (inorder Lf)" by (metis inorder.simps(1))
  qed
next
  case (Br a t1 t2) thus ?case by simp
qed

lemma postorder_bt_map: "postorder (bt_map f t) = map f (postorder t)"
apply (induct t)
 apply (metis Nil_is_map_conv bt_map.simps(1) postorder.simps(1))
by simp

lemma depth_bt_map [simp]: "depth (bt_map f t) = depth t"
apply (induct t)
 apply (metis bt_map.simps(1) depth.simps(1))
by simp

lemma n_leaves_bt_map [simp]: "n_leaves (bt_map f t) = n_leaves t"
apply (induct t)
 apply (metis bt_map.simps(1) n_leaves.simps(1))
proof -
  fix a :: 'b and t1 :: "'b bt" and t2 :: "'b bt"
  assume A1: "n_leaves (bt_map f t1) = n_leaves t1"
  assume A2: "n_leaves (bt_map f t2) = n_leaves t2"
  have "\<And>V U. n_leaves (Br U (bt_map f t1) V) = n_leaves t1 + n_leaves V"
    using A1 by (metis n_leaves.simps(2))
  hence "\<And>V U. n_leaves (bt_map f (Br U t1 V)) = n_leaves t1 + n_leaves (bt_map f V)"
    by (metis bt_map.simps(2))
  hence F1: "\<And>U. n_leaves (bt_map f (Br U t1 t2)) = n_leaves t1 + n_leaves t2"
    using A2 by metis
  have "n_leaves t1 + n_leaves t2 = n_leaves (Br a t1 t2)"
    by (metis n_leaves.simps(2))
  thus "n_leaves (bt_map f (Br a t1 t2)) = n_leaves (Br a t1 t2)"
    using F1 by metis
qed

lemma preorder_reflect: "preorder (reflect t) = rev (postorder t)"
apply (induct t)
 apply (metis Nil_is_rev_conv postorder.simps(1) preorder.simps(1)
              reflect.simps(1))
apply simp
done

lemma inorder_reflect: "inorder (reflect t) = rev (inorder t)"
apply (induct t)
 apply (metis Nil_is_rev_conv inorder.simps(1) reflect.simps(1))
by simp
(* Slow:
by (metis append.simps(1) append_eq_append_conv2 inorder.simps(2)
          reflect.simps(2) rev.simps(2) rev_append)
*)

lemma postorder_reflect: "postorder (reflect t) = rev (preorder t)"
apply (induct t)
 apply (metis Nil_is_rev_conv postorder.simps(1) preorder.simps(1)
              reflect.simps(1))
by (metis preorder_reflect reflect_reflect_ident rev_swap)

text {*
Analogues of the standard properties of the append function for lists.
*}

lemma append_assoc [simp]: "append (append t1 t2) t3 = append t1 (append t2 t3)"
apply (induct t1)
 apply (metis append.simps(1))
by (metis append.simps(2))

lemma append_Lf2 [simp]: "append t Lf = t"
apply (induct t)
 apply (metis append.simps(1))
by (metis append.simps(2))

declare max_add_distrib_left [simp]

lemma depth_append [simp]: "depth (append t1 t2) = depth t1 + depth t2"
apply (induct t1)
 apply (metis append.simps(1) depth.simps(1) plus_nat.simps(1))
by simp

lemma n_leaves_append [simp]:
     "n_leaves (append t1 t2) = n_leaves t1 * n_leaves t2"
apply (induct t1)
 apply (metis append.simps(1) n_leaves.simps(1) nat_mult_1 plus_nat.simps(1)
              Suc_eq_plus1)
by (simp add: distrib_right)

lemma (*bt_map_append:*)
     "bt_map f (append t1 t2) = append (bt_map f t1) (bt_map f t2)"
apply (induct t1)
 apply (metis append.simps(1) bt_map.simps(1))
by (metis bt_map_append)

end


theory Chapter4Guisen

imports "HOL-IMP.ASM"

begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
refl:  "star r x x" |
step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text\<open>
\section*{Chapter 4}

\exercise
Start from the data type of binary trees defined earlier:
\<close>

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

text\<open>
An @{typ "int tree"} is ordered if for every @{term "Node l i r"} in the tree,
@{text l} and @{text r} are ordered
and all values in @{text l} are @{text "< i"}
and all values in @{text r} are @{text "> i"}.
Define a function that returns the elements in a tree and one
that tests if a tree is ordered:
\<close>

fun set :: "'a tree \<Rightarrow> 'a set"  where
(* your definition/proof here *)
"set Tip = {}"|
"set (Node l i r) = (set l) \<union> {i} \<union> (set r)"

text\<open>test\<close>
value "set ((Node Tip (2::int)) Tip)"

fun ord :: "int tree \<Rightarrow> bool"  where
(* your definition/proof here *)
"ord Tip = True"|
"ord (Node l i r) = ((\<forall>x\<in>(set l).i>x)\<and>(\<forall>y\<in>(set r).(y>i))\<and>(ord l)\<and>(ord r) )"

text\<open>test\<close>
value "ord (Node Tip ((- 1)::int) (Node Tip (- 1) Tip))"

text\<open> Hint: use quantifiers.

"ord (Node l i r) = ((\<forall>x\<in>(set l).i>x)\<and>(\<forall>y\<in>(set r).(y>i))\<and>(ord l)\<and>(ord r) )"

"ord (Node l i r) = ( ( \<forall>x\<in>(set l).( \<forall>y\<in>(set r).(y>i\<and>i>x) ) ) \<and> (ord l) \<and> (ord r) )" why?

Define a function @{text ins} that inserts an element into an ordered @{typ "int tree"}
while maintaining the order of the tree. If the element is already in the tree, the
same tree should be returned.
\<close>

fun ins :: "int \<Rightarrow> int tree \<Rightarrow> int tree"  where
(* your definition/proof here *)
"ins a Tip =  Node Tip a Tip "|
"ins a (Node l i r) = (if a<i then (Node (ins a l) i r) else if a=i then (Node l i r) else (Node l i (ins a r)))"

text\<open>test\<close>
value "ins (-3) (Node Tip ((- 1)::int) (Node Tip (- 1) Tip))"
value "ord (ins (-3) (Node Tip ((- 1)::int) (Node Tip (- 1) Tip))) "

text\<open> Prove correctness of @{const ins}: \<close>

lemma set_ins: "set(ins x t) = {x} \<union> set t"
(* your definition/proof here *)
apply(induction t arbitrary:x)
apply(auto)
(*<*)done(*>*)
theorem ord_ins: "ord t \<Longrightarrow> ord(ins i t)"
(* your definition/proof here *)
apply(induction t rule:ord.induct)
apply(auto simp add:set_ins)
(*<*)done(*>*)
text\<open>
\endexercise

\exercise
Formalize the following definition of palindromes
\begin{itemize}
\item The empty list and a singleton list are palindromes.
\item If @{text xs} is a palindrome, so is @{term "a # xs @ [a]"}.
\end{itemize}
as an inductive predicate
\<close>

inductive palindrome :: "'a list \<Rightarrow> bool" where
(* your definition/proof here *)
palindrome0: "palindrome (Nil)"|
palindrome1: "palindrome ([a])"|
palindromeSS: "(palindrome xs) \<Longrightarrow> (palindrome (a # xs @ [a]))"
text \<open> and prove \<close>

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
(* your definition/proof here *)
apply(induction rule:palindrome.induct)
apply(auto)
(*<*)done(*>*)
text\<open>
\endexercise

\exercise
We could also have defined @{const star} as follows:
\<close>

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

text\<open>
The single @{text r} step is performer after rather than before the @{text star'}
steps. Prove
\<close>

lemma star_trans [simp]: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
apply(induction rule: star.induct)
(*<*)
defer
apply(rename_tac u x y)
defer
(*>*)
apply(assumption)
apply(metis step)
done
lemma star'_tran: "star' r x y \<Longrightarrow>star' r y z \<Longrightarrow> star' r x z"
apply(induction rule: star'.induct)
(*<*)
defer
apply(rename_tac u x y)
defer
(*>*)
apply(assumption)
(*<*)oops(*>*)
lemma star_01 [simp]: "r x y \<Longrightarrow>star r x y"
  by (simp add: star.refl star.step)

lemma star_02: "star' r x y \<Longrightarrow> star r x y"
(* your definition/proof here *)
apply(induction rule: star'.induct)
apply (simp add: star.refl)
apply(auto)
done

lemma star'_01 [simp]: "r x y \<Longrightarrow>star' r x y"
sledgehammer
by (meson refl' step')

lemma star'_trans [simp]: "r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"
sledgehammer
  by (meson star'_01 step')

lemma star_trans_02 [simp]: "star r x y \<Longrightarrow>  r y z \<Longrightarrow> star r x z"
sledgehammer
  by simp

lemma star'_trans' [simp]: "star' r y z \<Longrightarrow>star' r x y \<Longrightarrow> star' r x z"
apply(induction rule: star'.induct)
sledgehammer
apply simp
sledgehammer
by (simp add: step')

lemma "star r x y \<Longrightarrow> star' r x y"
(* your definition/proof here *)
apply(induction rule: star.induct)
   apply (simp add: star'.refl')
sledgehammer
  by (meson refl' star'_trans' step')
text\<open>
You may need lemmas. Note that rule induction fails
if the assumption about the inductive predicate
is not the first assumption.
\endexercise

\exercise\label{exe:iter}
Analogous to @{const star}, give an inductive definition of the @{text n}-fold iteration
of a relation @{text r}: @{term "iter r n x y"} should hold if there are @{text x\<^sub>0}, \dots, @{text x\<^sub>n}
such that @{prop"x = x\<^sub>0"}, @{prop"x\<^sub>n = y"} and @{text"r x\<^bsub>i\<^esub> x\<^bsub>i+1\<^esub>"} for
all @{prop"i < n"}:
\<close>

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
(* your definition/proof here *)
it_refl:  "iter r 0 x x" |
it_step:  "iter r n x y \<Longrightarrow>r y z \<Longrightarrow> iter r (n+1) x z"
text\<open>
Correct and prove the following claim:
\<close>
lemma iter_trans [simp]: "iter r n y z \<Longrightarrow>iter r 1 x y \<Longrightarrow> iter r (n+1) x z"
  apply(induction rule: iter.induct)

   apply simp

  by (meson it_step)
lemma iter_01 [simp]: "r x y \<Longrightarrow>iter r 1 x y"

  using it_refl it_step by fastforce

lemma "star r x y \<Longrightarrow>(\<exists>n. iter r n x y)"
(* your definition/proof here *)
  apply(induction rule: star.induct)

   apply (meson it_refl)

  by (meson iter_01 iter_trans)

text\<open>
\endexercise

\exercise\label{exe:cfg}
A context-free grammar can be seen as an inductive definition where each
nonterminal $A$ is an inductively defined predicate on lists of terminal
symbols: $A(w)$ mans that $w$ is in the language generated by $A$.
For example, the production $S \to aSb$ can be viewed as the implication
@{prop"S w \<Longrightarrow> S (a # w @ [b])"} where @{text a} and @{text b} are terminal symbols,
i.e., elements of some alphabet. The alphabet can be defined as a datatype:
\<close>

datatype alpha = a | b

text\<open>
If you think of @{const a} and @{const b} as ``@{text "("}'' and  ``@{text ")"}'',
the following two grammars both generate strings of balanced parentheses
(where $\varepsilon$ is the empty word):
\[
\begin{array}{r@ {\quad}c@ {\quad}l}
S &\to& \varepsilon \quad\mid\quad aSb \quad\mid\quad SS \\
T &\to& \varepsilon \quad\mid\quad TaTb
\end{array}
\]
Define them as inductive predicates and prove their equivalence:
\<close>

inductive S :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)
S_base:  "S Nil" |
S_step1:  "S x \<Longrightarrow>S (a#x@[b])" |
S_step2:  "S x \<Longrightarrow>S y \<Longrightarrow>S (x@y)"
inductive T :: "alpha list \<Rightarrow> bool" where
(* your definition/proof here *)
T_base:  "T Nil" |
T_step:  "T x\<Longrightarrow>T y \<Longrightarrow>T(x@[a]@y@[b])"

lemma T_01 [simp]: "T y\<Longrightarrow>T x \<Longrightarrow>T(x@y)"
  apply(induction rule: T.induct)

   apply simp

  by (metis T.simps append_assoc)

lemma TS: "T w \<Longrightarrow> S w"
(* your definition/proof here *)
 apply(induction rule: T.induct)
   apply (simp add: S_base)
  by (simp add: S_step1 S_step2)

lemma ST: "S w \<Longrightarrow> T w"
(* your definition/proof here *)
  apply(induction rule: S.induct)

   apply (simp add: T_base)

  using T_base T_step apply force

  by auto
corollary SeqT: "S w \<longleftrightarrow> T w"
(* your definition/proof here *)

  using ST TS by blast
text\<open>
\endexercise
\<close>
(* your definition/proof here *)
text\<open>
\exercise
In Chapter 3 we defined a recursive evaluation function
@{text "aval ::"} @{typ "aexp \<Rightarrow> state \<Rightarrow> val"}.
Define an inductive evaluation predicate and prove that it agrees with
the recursive function:
\<close>

inductive aval_rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
(* your definition/proof here *)
ar_base0:  "aval_rel (N n) s n" |
ar_base1:  "aval_rel (V x) s (s x)" |
ar_step:  "aval_rel k s z \<Longrightarrow>aval_rel v s w \<Longrightarrow>aval_rel (Plus k v) s (z+w)"
lemma aval_rel_aval: "aval_rel k s v \<Longrightarrow> aval k s = v"
(* your definition/proof here *)
  apply(induction rule: aval_rel.induct)
    apply simp
  apply simp
  by simp

lemma aval_01 [simp]: "aval (Plus k1 k2) s = v \<Longrightarrow>(aval k1 s)=z \<Longrightarrow>(aval k2 s) = v-z"
  by simp
lemma aval_02 [simp]: "aval_rel k1 s z \<Longrightarrow>aval_rel k2 s (v-z) \<Longrightarrow> aval_rel (Plus k1 k2) s  v"
  using ar_step by fastforce

lemma aval_aval_rel: "aval k s = v \<Longrightarrow> aval_rel k s v"
(* your definition/proof here *)
  apply(induction k)
   apply (simp add: ar_base0)
  using Chapter4Guisen.aval_rel.simps aval.simps(2) apply blast
  by simp

corollary "aval_rel k s v \<longleftrightarrow> aval k s = v"
(* your definition/proof here *)
  using aval_aval_rel aval_rel_aval by blast
text\<open>
\endexercise

\exercise
Consider the stack machine from Chapter~3
and recall the concept of \concept{stack underflow}
from Exercise~\ref{exe:stack-underflow}.
Define an inductive predicate
\<close>

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
(* your definition/proof here *)

ok_base0:  "ok 0 [] 0" |
ok_base01:  "ok n [] n \<Longrightarrow> ok (Suc n) [] (Suc n)"|
ok_step00:  "ok (Suc n) sk m \<Longrightarrow>ok n ((LOAD x)#sk) m"|
ok_step01:  "ok n sk m \<Longrightarrow>ok n ((LOAD x)#sk) (Suc m)"|
ok_step10:  "ok (Suc n) sk m \<Longrightarrow>ok n ((LOADI v)#sk) m"|
ok_step11:  "ok n sk m \<Longrightarrow>ok n ((LOADI v)#sk)(Suc m)"|
ok_step2:  "ok (Suc n) sk m \<Longrightarrow>ok (Suc (Suc n)) ((ADD)#sk) m"
text\<open>
such that @{text "ok n is n'"} means that with any initial stack of length
@{text n} the instructions @{text "is"} can be executed
without stack underflow and that the final stack has length @{text n'}.

Using the introduction rules for @{const ok},
prove the following special cases: \<close>

lemma ok_0[simp]:"ok 0 [LOAD x] (Suc 0)"
(* your definition/proof here *)

  by (simp add: ok_base0 ok_step01)

lemma ok_1[simp]:"ok (Suc 0) [LOAD y] (Suc (Suc 0))"

    by (simp add: ok_base0 ok_base01 ok_step01)
lemma ok_2[simp]:"ok (Suc(Suc 0)) [ADD,LOAD y] (Suc (Suc 0))"
  by (simp add: ok_step2)
lemma ok_3[simp]:"ok (Suc(Suc(Suc 0))) [ADD,ADD,LOAD y] (Suc (Suc 0))"
  by (simp add: ok_step2)

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
(* your definition/proof here *)
  by (simp add: ok_step00)
text \<open> Prove that @{text ok} correctly computes the final stack size: \<close>

lemma ok_4:"ok n [] n'\<Longrightarrow>(n=n')"
    using ok.cases by fastforce
lemma ok_5:" \<lbrakk>\<And>stk. \<lbrakk>ok n ts n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec ts s stk) = n'; ok n (z # ts) n';
        length stk = n\<rbrakk>
       \<Longrightarrow> length (exec (z # ts) s stk) = n'"
  apply(induction stk arbitrary:ts z n')

  oops
lemma "\<lbrakk>ok n ts n'; length stk = n\<rbrakk> \<Longrightarrow> length (exec ts s stk) = n'"
(* your definition/proof here *)
  apply(induction ts arbitrary:stk)
   apply (simp add: ok_4)

text \<open>
Lemma @{thm [source] length_Suc_conv} may come in handy.

Prove that instruction sequences generated by @{text comp}
cannot cause stack underflow: \ @{text "ok n (comp a) ?"} \ for
some suitable value of @{text "?"}.
\endexercise
\<close>

end


theory Polynomial imports Main begin (*>*)

text \<open>
Let the following data type for propositional formulae be given:
\<close>

datatype form = T | Var nat | And form form | Xor form form

text \<open>
Here @{term "T"} denotes a formula that is always true, @{term "Var n"} denotes
a propositional variable, its name given by a natural number, @{term "And f1
f2"} denotes the AND combination, and @{term "Xor f1 f2"} the XOR (exclusive or)
combination of two formulae.  A constructor @{term "F"} for a formula that is
always false is not necessary, since @{term "F"} can be expressed by @{term "Xor
T T"}.

{\bf Exercise 1:} Define a function
\<close>

definition xor::"bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "\<oplus>" 60)
  where
"xor a b = ((a \<and> \<not>b) \<or> (\<not>a \<and> b))"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool"
  where
"evalf _ T = True" |
"evalf val (Var n) = val n" |
"evalf val (And f\<^sub>1 f\<^sub>2) = (evalf val f\<^sub>1 \<and> evalf val f\<^sub>2)" |
"evalf val (Xor f\<^sub>1 f\<^sub>2) = (evalf val f\<^sub>1 \<oplus> evalf val f\<^sub>2)"

text \<open>
that evaluates a formula under a given variable assignment.
\<close>

text \<open>
Propositional formulae can be represented by so-called {\it polynomials}.  A
polynomial is a list of lists of propositional variables, i.e.\ an element of
type @{typ "nat list list"}.  The inner lists (the so-called {\it monomials})
are interpreted as conjunctive combination of variables, whereas the outer list
is interpreted as exclusive-or combination of the inner lists.

{\bf Exercise 2:} Define two functions
\<close>

primrec  evalm :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> bool"
  where
"evalm _ [] = True" |
"evalm val (x#xs) = (val x \<and> evalm val xs)"

lemma evalm_correct[simp]:"evalm f (l1 @ l2) = (evalm f l1 \<and> evalm f l2)"
  apply (induction l1 arbitrary: l2) by auto

primrec evalp :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list list \<Rightarrow> bool"
  where
"evalp _ [] = False" |
"evalp val (x#xs) = (evalm val x \<oplus> evalp val xs)"

lemma evalp_correct[simp]:"evalp f (l1 @ l2) = (evalp f l1 \<oplus> evalp f l2)"
  apply (induction l1 arbitrary: l2) by (auto simp add: xor_def)

text \<open>
for evaluation of monomials and polynomials under a given variable assignment.
In particular think about how empty lists have to be evaluated.
\<close>

text \<open>
{\bf Exercise 3:} Define a function
\<close>

primrec mulpp :: "nat list list \<Rightarrow> nat list list \<Rightarrow> nat list list"
  where
"mulpp [] _ = []" |
"mulpp (x#xs) ys = (map (append x) ys) @ mulpp xs ys"

lemma mulpp_append[simp]:"mulpp (xs1 @ xs2) ys = mulpp xs1 ys @ mulpp xs2 ys"
  apply (induction xs1 arbitrary: xs2) by auto

lemma mulpp_empty_singletonL[simp]:"mulpp [[]] ys = ys"
  apply (induction ys) by auto

lemma mulpp_emptyR[simp]:"mulpp xs [] = []"
  apply (induction xs) by auto

lemma mulpp_empty_SingletonR[simp]:"mulpp xs [[]] = xs"
  apply (induction xs) by auto

lemma mulpp_map_eval[simp]:"evalp f (map (append l1) l2) = (evalm f l1 \<and> evalp f l2)"
  apply (induction l2) by (auto simp add: xor_def)

lemma eval_mulpp[simp]:"evalp f (mulpp l1 l2) = (evalp f l1 \<and> evalp f l2)"
  apply (induction l1)
  by (auto simp add: xor_def)

primrec poly :: "form \<Rightarrow> nat list list"
  where
"poly T = [[]]" |
"poly (Var n) = [[n]]" |
"poly (And f\<^sub>1 f\<^sub>2) = mulpp (poly f\<^sub>1) (poly f\<^sub>2)" |
"poly (Xor f\<^sub>1 f\<^sub>2) = (poly f\<^sub>1) @ (poly f\<^sub>2)"

text \<open>
that turns a formula into a polynomial.  You will need an auxiliary function
\<close>

text \<open>
to ``multiply'' two polynomials, i.e.\ to compute
\[
((v^1_1 \mathbin{\odot} \cdots \mathbin{\odot} v^1_{m_1}) \mathbin{\oplus} \cdots \mathbin{\oplus} (v^k_1 \mathbin{\odot} \cdots \mathbin{\odot} v^k_{m_k})) \mathbin{\odot}
((w^1_1 \mathbin{\odot} \cdots \mathbin{\odot} w^1_{n_1}) \mathbin{\oplus} \cdots \mathbin{\oplus} (w^l_1 \mathbin{\odot} \cdots \mathbin{\odot} w^l_{n_l}))
\]
where $\mathbin{\oplus}$ denotes ``exclusive or'', and $\mathbin{\odot}$ denotes
``and''.  This is done using the usual calculation rules for addition and
multiplication.
\<close>

text \<open>
{\bf Exercise 4:} Now show correctness of your function @{term "poly"}:
\<close>

theorem poly_correct: "evalf e f = evalp e (poly f)"
  apply (induction f) by (auto simp add: xor_def)

text \<open>
It is useful to prove a similar correctness theorem for @{term "mulpp"} first.
\<close>

(*<*) end (*>*)